Simplify

Simplify

module Language.JsonSchema
    ( JSONSchema
    , jsonSchemaListToIR
    , renderer
    ) where

import Core (class Eq, class Ord, Error, Unit, unit, bind, const, map, not, otherwise, pure, id, ($), (&&), (/=), (<), (<$>), (<>), (=<<), (>=), (>>>))

import Doc (Doc, Renderer, combineNames, getClasses, getTopLevels, line, lookupClassName, noForbidNamer, simpleNamer)
import IRGraph
import Control.Monad.Error.Class (throwError)

import Data.Argonaut.Core (Json, foldJson, fromArray, fromBoolean, fromObject, fromString, isBoolean, stringifyWithSpace)
import Data.Argonaut.Decode ((.??), decodeJson, class DecodeJson)
import Data.Array as A
import Data.Char as Char
import Data.Either (Either(Right, Left), either)
import Data.Foldable (class Foldable, foldM)
import Data.List (List, (:))
import Data.List as L
import Data.List.NonEmpty as NEL
import Control.Monad.State.Trans as StateT
import Control.Bind ((>>=))
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize, singular)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..))
import IR (IR, addClass, unifyTypes)
import Utils (mapM, mapMapM, mapWithIndexM)

data JSONType
    = JSONObject
    | JSONArray
    | JSONBoolean
    | JSONString
    | JSONNull
    | JSONInteger
    | JSONNumber

derive instance eqJSONType :: Eq JSONType
derive instance ordJSONType :: Ord JSONType

jsonTypeEnumMap :: StrMap JSONType
jsonTypeEnumMap = SM.fromFoldable [
    Tuple "object" JSONObject, Tuple "array" JSONArray, Tuple "boolean" JSONBoolean,
    Tuple "string" JSONString, Tuple "null" JSONNull, Tuple "integer" JSONInteger,
    Tuple "number" JSONNumber
    ]

data PathElement
    = Root
    | Definition String
    | OneOf Int
    | Property String
    | AdditionalProperty
    | Items

newtype JSONSchemaRef = JSONSchemaRef
    { path :: NEL.NonEmptyList PathElement
    , name :: Maybe String
    }

newtype JSONSchema = JSONSchema
    { definitions :: Maybe (StrMap JSONSchema)
    , ref :: Maybe JSONSchemaRef
    , types :: Maybe (Either JSONType (Set JSONType))
    , oneOf :: Maybe (Array JSONSchema)
    , properties :: Maybe (StrMap JSONSchema)
    , additionalProperties :: Either Boolean JSONSchema
    , items :: Maybe JSONSchema
    , required :: Maybe (Array String)
    , title :: Maybe String
    }

type JsonIR = StateT.StateT Unit IR

decodeEnum :: forall a. StrMap a -> Json -> Either Error a
decodeEnum sm j = do
    key <- decodeJson j
    maybe (Left "Unexpected enum key") Right $ SM.lookup key sm

instance decodeJsonType :: DecodeJson JSONType where
    decodeJson = decodeEnum jsonTypeEnumMap

instance decodeJsonSchemaRef :: DecodeJson JSONSchemaRef where
    decodeJson j = do
        refString :: String <- decodeJson j
        let pathElementsStrings = String.split (String.Pattern "/") refString
        parsed <- parseJsonSchemaRef $ L.fromFoldable pathElementsStrings
        case NEL.fromList parsed of
            Nothing -> Left "Reference must contain at least one path element"
            Just path -> pure $ JSONSchemaRef { path, name: A.last pathElementsStrings }

parseJsonSchemaRef :: List String -> Either Error (List PathElement)
parseJsonSchemaRef L.Nil =
    pure L.Nil
parseJsonSchemaRef ("#" : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Root : restParsed
parseJsonSchemaRef ("definitions" : name : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Definition name : restParsed
parseJsonSchemaRef _ =
    Left "Could not parse JSON Schema reference"

decodeTypes :: Json -> Either Error (Either JSONType (Set JSONType))
decodeTypes j =
    foldJson
        (\_ -> Left "`types` cannot be null")
        (\_ -> Left "`types` cannot be a boolean")
        (\_ -> Left "`types` cannot be a number")
        (\s -> do
            t <- decodeEnum jsonTypeEnumMap j
            pure $ Left t)
        (\a -> do
            l <- traverse (decodeEnum jsonTypeEnumMap) a
            pure $ Right $ S.fromFoldable l)
        (\_ -> Left "`Types` cannot be an object")
        j

decodeAdditionalProperties :: Maybe Json -> Either Error (Either Boolean JSONSchema)
decodeAdditionalProperties Nothing = Right $ Left true
decodeAdditionalProperties (Just j)
    | isBoolean j = do
        b <- decodeJson j
        pure $ Left b
    | otherwise = do
        js <- decodeJson j
        pure $ Right js

instance decodeJsonSchema :: DecodeJson JSONSchema where
    decodeJson j = do
        obj <- decodeJson j
        definitions <- obj .?? "definitions"
        ref <- obj .?? "$ref"

        typ <- obj .?? "type"
        -- TODO this sucks
        types <- maybe (pure Nothing) (map Just) (decodeTypes <$> typ)

        oneOf <- obj .?? "oneOf"
        properties <- obj .?? "properties"
        additionalProperties <- decodeAdditionalProperties $ SM.lookup "additionalProperties" obj
        items <- obj .?? "items"
        required <- obj .?? "required"
        title <- obj .?? "title"
        pure $ JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required, title }

lookupRef :: JSONSchema -> List PathElement -> List PathElement -> JSONSchema -> Either Error (Tuple JSONSchema (List PathElement))
lookupRef root reversePath ref local@(JSONSchema localProps) =
    case ref of
    L.Nil -> Right $ Tuple local reversePath
    Root : rest -> lookupRef root (L.singleton Root) rest root
    pathElement : rest -> do
        js <- follow pathElement
        lookupRef root (pathElement : reversePath) rest js
    where
        follow :: PathElement -> Either Error JSONSchema
        follow (Definition name) = maybe (Left "Reference not found") Right $ localProps.definitions >>= SM.lookup name
        follow (OneOf i) = maybe (Left "Invalid OneOf index") Right $ localProps.oneOf >>= (\oo -> A.index oo i)
        follow (Property name) = maybe (Left "Property not found") Right $ localProps.properties >>= SM.lookup name
        follow AdditionalProperty = either (const $ Left "AdditionalProperties not found") Right localProps.additionalProperties
        follow Items = maybe (Left "Items not found") Right localProps.items
        follow Root = Left "Cannot follow Root"

jsonUnifyTypes :: IRType -> IRType -> JsonIR IRType
jsonUnifyTypes a b = StateT.lift $ unifyTypes a b

toIRAndUnify :: forall a f. Foldable f => (Int -> a -> JsonIR IRType) -> f a -> JsonIR IRType
toIRAndUnify toIR l = do
    irs <- mapWithIndexM toIR $ A.fromFoldable l
    foldM jsonUnifyTypes IRAnything irs

jsonSchemaToIR :: JSONSchema -> List PathElement -> Named String -> JSONSchema -> JsonIR IRType
jsonSchemaToIR root reversePath name schema@(JSONSchema schemaProps)
    | Just (JSONSchemaRef { path, name }) <- schemaProps.ref =
        case lookupRef root reversePath (NEL.toList path) schema of
        Left err -> throwError err
        Right (Tuple js jsReversePath) -> jsonSchemaToIR root jsReversePath (maybe (Inferred "Something") Given name) js
    | Just (Left jt) <- schemaProps.types =
        jsonTypeToIR root reversePath name jt schema
    | Just (Right jts) <- schemaProps.types =
        toIRAndUnify (\_ jt -> jsonTypeToIR root reversePath name jt schema) jts
    | Just jss <- schemaProps.oneOf =
        toIRAndUnify (\i -> jsonSchemaToIR root (OneOf i : reversePath) name) jss
    | otherwise =
        pure IRAnything

jsonSchemaListToIR :: forall t. Traversable t => Named String -> t JSONSchema -> IR IRType
jsonSchemaListToIR name l = do
    irTypes <- StateT.evalStateT (mapM (\js -> jsonSchemaToIR js (L.singleton Root) name js) l) unit
    foldM unifyTypes IRAnything irTypes

jsonTypeToIR :: JSONSchema -> List PathElement -> Named String -> JSONType -> JSONSchema -> JsonIR IRType
jsonTypeToIR root reversePath name jsonType (JSONSchema schema) =
    case jsonType of
    JSONObject ->
        case schema.properties of
        Just sm -> do
            let propMap = M.fromFoldable $ SM.toUnfoldable sm :: Array (Tuple String JSONSchema)
            props <- mapMapM (\n -> jsonSchemaToIR root (Property n : reversePath) $ Inferred n) propMap
            let required = maybe S.empty S.fromFoldable schema.required
            let title = maybe name Given schema.title
            nulled <- mapMapM (\n -> if S.member n required then pure else jsonUnifyTypes IRNull) props
            StateT.lift $ addClass $ makeClass title nulled
        Nothing ->
            case schema.additionalProperties of
            Left true ->
                pure $ IRMap IRAnything
            Left false ->
                pure $ IRAnything
            Right js -> do
                ir <- jsonSchemaToIR root (AdditionalProperty : reversePath) singularName js
                pure $ IRMap ir
    JSONArray ->
        case schema.items of
        Just js -> do
            ir <- jsonSchemaToIR root (Items : reversePath) singularName js
            pure $ IRArray ir
        Nothing -> pure $ IRArray IRAnything
    JSONBoolean -> pure IRBool
    JSONString -> pure IRString
    JSONNull -> pure IRNull
    JSONInteger -> pure IRInteger
    JSONNumber -> pure IRDouble
    where
        singularName = Inferred $ singular $ namedValue name

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "Schema"
    , aceMode: "json"
    , extension: "schema"
    , doc: jsonSchemaDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer jsonNameStyle -- FIXME: put title on top levels, too
        , unions: Nothing
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128 && c /= '/'

jsonNameStyle :: String -> String
jsonNameStyle =
    legalize >>> camelCase >>> capitalize

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = jsonNameStyle $ combineNames names

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

typeJson :: String -> Doc Json
typeJson s = fromObject <$> typeStrMap s

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRAnything -> pure $ SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- jsonForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" itemType sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- jsonForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" propertyType sm
    IRUnion ur -> do
        types <- mapUnionM jsonForType ur
        let typesJson = fromArray $ A.fromFoldable types
        pure $ SM.insert "oneOf" typesJson SM.empty

jsonForType :: IRType -> Doc Json
jsonForType t = do
    sm <- strMapForType t
    pure $ fromObject sm

strMapForOneOfTypes :: List IRType -> Doc (StrMap Json)
strMapForOneOfTypes L.Nil = pure $ SM.empty
strMapForOneOfTypes (t : L.Nil) = strMapForType t
strMapForOneOfTypes typeList = do
    objList <- mapM jsonForType typeList
    pure $ SM.insert "oneOf" (fromArray $ A.fromFoldable objList) SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { names, properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (const jsonForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable propsMap :: List (Tuple String Json))
    let withProperties = SM.insert "properties" (fromObject propsSM) sm
    let withRequired = SM.insert "required" (fromArray requiredProps) withProperties
    let withTitle = SM.insert "title" (fromString $ combineNames names) withRequired
    pure $ Tuple className $ fromObject withTitle

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    -- FIXME: give a title to top-levels, too
    topLevel <- strMapForOneOfTypes =<< M.values <$> getTopLevels
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json

module Language.JsonSchema
    ( JSONSchema
    , jsonSchemaListToIR
    , renderer
    ) where

import Core (class Eq, class Ord, Error, Unit, unit, bind, const, map, not, otherwise, pure, ($), (&&), (/=), (<), (<$>), (<>), (=<<), (>=), (>>>))

import Doc (Doc, Renderer, combineNames, getClasses, getTopLevels, line, lookupClassName, noForbidNamer, simpleNamer)
import IRGraph
import Control.Monad.Error.Class (throwError)

import Data.Argonaut.Core (Json, foldJson, fromArray, fromBoolean, fromObject, fromString, isBoolean, stringifyWithSpace)
import Data.Argonaut.Decode ((.??), decodeJson, class DecodeJson)
import Data.Array as A
import Data.Char as Char
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldM)
import Data.List (List, (:))
import Data.List as L
import Data.List.NonEmpty as NEL
import Control.Monad.State.Trans as StateT
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize, singular)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..))
import IR (IR, addClass, unifyTypes)
import Utils (mapM, mapMapM, mapWithIndexM)

data JSONType
    = JSONObject
    | JSONArray
    | JSONBoolean
    | JSONString
    | JSONNull
    | JSONInteger
    | JSONNumber

derive instance eqJSONType :: Eq JSONType
derive instance ordJSONType :: Ord JSONType

jsonTypeEnumMap :: StrMap JSONType
jsonTypeEnumMap = SM.fromFoldable [
    Tuple "object" JSONObject, Tuple "array" JSONArray, Tuple "boolean" JSONBoolean,
    Tuple "string" JSONString, Tuple "null" JSONNull, Tuple "integer" JSONInteger,
    Tuple "number" JSONNumber
    ]

data PathElement
    = Root
    | Definition String
    | OneOf Int
    | Property String
    | AdditionalProperty
    | Items

newtype JSONSchemaRef = JSONSchemaRef
    { path :: NEL.NonEmptyList PathElement
    , name :: Maybe String
    }

newtype JSONSchema = JSONSchema
    { definitions :: Maybe (StrMap JSONSchema)
    , ref :: Maybe JSONSchemaRef
    , types :: Maybe (Either JSONType (Set JSONType))
    , oneOf :: Maybe (Array JSONSchema)
    , properties :: Maybe (StrMap JSONSchema)
    , additionalProperties :: Either Boolean JSONSchema
    , items :: Maybe JSONSchema
    , required :: Maybe (Array String)
    , title :: Maybe String
    }

type JsonIR = StateT.StateT Unit IR

decodeEnum :: forall a. StrMap a -> Json -> Either Error a
decodeEnum sm j = do
    key <- decodeJson j
    maybe (Left "Unexpected enum key") Right $ SM.lookup key sm

instance decodeJsonType :: DecodeJson JSONType where
    decodeJson = decodeEnum jsonTypeEnumMap

instance decodeJsonSchemaRef :: DecodeJson JSONSchemaRef where
    decodeJson j = do
        refString :: String <- decodeJson j
        let pathElementsStrings = String.split (String.Pattern "/") refString
        parsed <- parseJsonSchemaRef $ L.fromFoldable pathElementsStrings
        case NEL.fromList parsed of
            Nothing -> Left "Reference must contain at least one path element"
            Just path -> pure $ JSONSchemaRef { path, name: A.last pathElementsStrings }

parseJsonSchemaRef :: List String -> Either Error (List PathElement)
parseJsonSchemaRef L.Nil =
    pure L.Nil
parseJsonSchemaRef ("#" : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Root : restParsed
parseJsonSchemaRef ("definitions" : name : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Definition name : restParsed
parseJsonSchemaRef _ =
    Left "Could not parse JSON Schema reference"

decodeTypes :: Json -> Either Error (Either JSONType (Set JSONType))
decodeTypes j =
    foldJson
        (\_ -> Left "`types` cannot be null")
        (\_ -> Left "`types` cannot be a boolean")
        (\_ -> Left "`types` cannot be a number")
        (\s -> do
            t <- decodeEnum jsonTypeEnumMap j
            pure $ Left t)
        (\a -> do
            l <- traverse (decodeEnum jsonTypeEnumMap) a
            pure $ Right $ S.fromFoldable l)
        (\_ -> Left "`Types` cannot be an object")
        j

decodeAdditionalProperties :: Maybe Json -> Either Error (Either Boolean JSONSchema)
decodeAdditionalProperties Nothing = Right $ Left true
decodeAdditionalProperties (Just j)
    | isBoolean j = do
        b <- decodeJson j
        pure $ Left b
    | otherwise = do
        js <- decodeJson j
        pure $ Right js

instance decodeJsonSchema :: DecodeJson JSONSchema where
    decodeJson j = do
        obj <- decodeJson j
        definitions <- obj .?? "definitions"
        ref <- obj .?? "$ref"

        typ <- obj .?? "type"
        -- TODO this sucks
        types <- maybe (pure Nothing) (map Just) (decodeTypes <$> typ)

        oneOf <- obj .?? "oneOf"
        properties <- obj .?? "properties"
        additionalProperties <- decodeAdditionalProperties $ SM.lookup "additionalProperties" obj
        items <- obj .?? "items"
        required <- obj .?? "required"
        title <- obj .?? "title"
        pure $ JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required, title }

lookupRef :: JSONSchema -> List PathElement -> List PathElement -> JSONSchema -> Either Error (Tuple JSONSchema (List PathElement))
-- FIXME: don't deconstruct all the properties
lookupRef root reversePath ref local@(JSONSchema { definitions, oneOf, properties, additionalProperties, items }) =
    case ref of
    L.Nil -> Right $ Tuple local reversePath
    Root : rest -> lookupRef root (L.singleton Root) rest root
    Definition name : rest ->
    -- FIXME: use >>= for all these maybes
        case definitions of
        Just sm ->
            case SM.lookup name sm of
            Just js -> recur (Definition name) rest js
            Nothing -> Left "Reference not found"
        Nothing -> Left "Definitions not found"
    OneOf i : rest ->
        case oneOf of
        Just oo ->
            case A.index oo i of
            Just js -> recur (OneOf i) rest js
            Nothing -> Left "Invalid OneOf index"
        Nothing -> Left "OneOf not found"
    Property name : rest ->
        case properties of
        Just props ->
            case SM.lookup name props of
            Just js -> recur (Property name) rest js
            Nothing -> Left "Property not found"
        Nothing -> Left "Properties not found"
    AdditionalProperty : rest ->
        case additionalProperties of
        Right js -> recur AdditionalProperty rest js
        _ -> Left "AdditionalProperties not found"
    Items : rest ->
        case items of
        Just js -> recur Items rest js
        Nothing -> Left "Items not found"
    where
        recur pathElement rest js = lookupRef root (pathElement : reversePath) rest js

jsonUnifyTypes :: IRType -> IRType -> JsonIR IRType
jsonUnifyTypes a b = StateT.lift $ unifyTypes a b

toIRAndUnify :: forall a f. Foldable f => (Int -> a -> JsonIR IRType) -> f a -> JsonIR IRType
toIRAndUnify toIR l = do
    irs <- mapWithIndexM toIR $ A.fromFoldable l
    foldM jsonUnifyTypes IRAnything irs

jsonSchemaToIR :: JSONSchema -> List PathElement -> Named String -> JSONSchema -> JsonIR IRType
-- FIXME: don't deconstruct all the properties
jsonSchemaToIR root reversePath name schema@(JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required })
    | Just (JSONSchemaRef { path, name }) <- ref =
        case lookupRef root reversePath (NEL.toList path) schema of
        Left err -> throwError err
        Right (Tuple js jsReversePath) -> jsonSchemaToIR root jsReversePath (maybe (Inferred "Something") Given name) js
    | Just (Left jt) <- types =
        jsonTypeToIR root reversePath name jt schema
    | Just (Right jts) <- types =
        toIRAndUnify (\_ jt -> jsonTypeToIR root reversePath name jt schema) jts
    | Just jss <- oneOf =
        toIRAndUnify (\i -> jsonSchemaToIR root (OneOf i : reversePath) name) jss
    | otherwise =
        pure IRAnything

jsonSchemaListToIR :: forall t. Traversable t => Named String -> t JSONSchema -> IR IRType
jsonSchemaListToIR name l = do
    irTypes <- StateT.evalStateT (mapM (\js -> jsonSchemaToIR js (L.singleton Root) name js) l) unit
    foldM unifyTypes IRAnything irTypes

jsonTypeToIR :: JSONSchema -> List PathElement -> Named String -> JSONType -> JSONSchema -> JsonIR IRType
jsonTypeToIR root reversePath name jsonType (JSONSchema schema) =
    case jsonType of
    JSONObject ->
        case schema.properties of
        Just sm -> do
            let propMap = M.fromFoldable $ SM.toUnfoldable sm :: Array (Tuple String JSONSchema)
            props <- mapMapM (\n -> jsonSchemaToIR root (Property n : reversePath) $ Inferred n) propMap
            let required = maybe S.empty S.fromFoldable schema.required
            let title = maybe name Given schema.title
            nulled <- mapMapM (\n -> if S.member n required then pure else jsonUnifyTypes IRNull) props
            StateT.lift $ addClass $ makeClass title nulled
        Nothing ->
            case schema.additionalProperties of
            Left true ->
                pure $ IRMap IRAnything
            Left false ->
                pure $ IRAnything
            Right js -> do
                ir <- jsonSchemaToIR root (AdditionalProperty : reversePath) singularName js
                pure $ IRMap ir
    JSONArray ->
        case schema.items of
        Just js -> do
            ir <- jsonSchemaToIR root (Items : reversePath) singularName js
            pure $ IRArray ir
        Nothing -> pure $ IRArray IRAnything
    JSONBoolean -> pure IRBool
    JSONString -> pure IRString
    JSONNull -> pure IRNull
    JSONInteger -> pure IRInteger
    JSONNumber -> pure IRDouble
    where
        singularName = Inferred $ singular $ namedValue name

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "Schema"
    , aceMode: "json"
    , extension: "schema"
    , doc: jsonSchemaDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer jsonNameStyle -- FIXME: put title on top levels, too
        , unions: Nothing
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128 && c /= '/'

jsonNameStyle :: String -> String
jsonNameStyle =
    legalize >>> camelCase >>> capitalize

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = jsonNameStyle $ combineNames names

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

typeJson :: String -> Doc Json
typeJson s = fromObject <$> typeStrMap s

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRAnything -> pure $ SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- jsonForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" itemType sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- jsonForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" propertyType sm
    IRUnion ur -> do
        types <- mapUnionM jsonForType ur
        let typesJson = fromArray $ A.fromFoldable types
        pure $ SM.insert "oneOf" typesJson SM.empty

jsonForType :: IRType -> Doc Json
jsonForType t = do
    sm <- strMapForType t
    pure $ fromObject sm

strMapForOneOfTypes :: List IRType -> Doc (StrMap Json)
strMapForOneOfTypes L.Nil = pure $ SM.empty
strMapForOneOfTypes (t : L.Nil) = strMapForType t
strMapForOneOfTypes typeList = do
    objList <- mapM jsonForType typeList
    pure $ SM.insert "oneOf" (fromArray $ A.fromFoldable objList) SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { names, properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (const jsonForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable propsMap :: List (Tuple String Json))
    let withProperties = SM.insert "properties" (fromObject propsSM) sm
    let withRequired = SM.insert "required" (fromArray requiredProps) withProperties
    let withTitle = SM.insert "title" (fromString $ combineNames names) withRequired
    pure $ Tuple className $ fromObject withTitle

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    -- FIXME: give a title to top-levels, too
    topLevel <- strMapForOneOfTypes =<< M.values <$> getTopLevels
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json


Make code more readable by using better variable names

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          c1 = (even x) && (odd y)
          c2 = (even y) && (odd x)
          color = if c1 || c2 then colorSquareOne else colorSquareTwo
          piece = if (y < layers) && (c1 || c2)
                  then Just (createPiece playerOne)
                  else if (y >= height - layers) && (c1 || c2)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Fix Markdown highlighting

Fix Markdown highlighting

module App.Notebook.Ace (acePostRender, ref, AceKnot()) where

import Input.Notebook (CellResultContent(..), Input(..))

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (Ref(), RefVal(), readRef, newRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), EAce(), Editor(), TextMode())
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId)

import Optic.Core
import Optic.Refractor.Lens

type AceKnot = Tuple CellId (M.Map CellId EditSession)

foreign import markdownMode """
  var markdownMode = "ace/mode/markdown";
""" :: TextMode
foreign import plainTextMode """
  var plainTextMode = "ace/mode/plain_text";
""" :: TextMode

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

initialize :: forall eff. RefVal AceKnot -> HTMLElement ->
              Driver Input (ace :: EAce | eff) ->
              Eff (HalogenEffects (ace :: EAce | eff)) Unit
initialize m b d = do
  els <- getElementsByClassName "ace-container" b
  Tuple _ mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace
      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (_2 %~ M.insert cid session)
    Editor.onFocus editor do
      modifyRef m (_1 .~ cid)
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceKnot
                        -> Input
                        -> Driver Input (now :: Now, ace :: EAce | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
handleInput m (RunCell cellId _) d = do
  Tuple _ m' <- readRef m
  now' <- now
  maybe (return unit) (getValue >=> d <<< CellResult cellId now' <<< Right <<< AceContent) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (_2 %~ M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceKnot -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: EAce | eff) -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

ref :: forall e.  Eff (ref :: Ref | e) (RefVal AceKnot)
ref = newRef (Tuple 0 M.empty)

module App.Notebook.Ace (acePostRender, ref, AceKnot()) where

import Input.Notebook (CellResultContent(..), Input(..))

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (Ref(), RefVal(), readRef, newRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), EAce(), Editor(), TextMode())
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId)

import Optic.Core
import Optic.Refractor.Lens

type AceKnot = Tuple CellId (M.Map CellId EditSession)

foreign import markdownMode """
  var markdownMode = "/ace/mode/markdown";
""" :: TextMode
foreign import plainTextMode """
  var plainTextMode = "ace/mode/plain_text";
""" :: TextMode

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

initialize :: forall eff. RefVal AceKnot -> HTMLElement ->
              Driver Input (ace :: EAce | eff) ->
              Eff (HalogenEffects (ace :: EAce | eff)) Unit
initialize m b d = do
  els <- getElementsByClassName "ace-container" b
  Tuple _ mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace
      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (_2 %~ M.insert cid session)
    Editor.onFocus editor do
      modifyRef m (_1 .~ cid)
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceKnot
                        -> Input
                        -> Driver Input (now :: Now, ace :: EAce | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
handleInput m (RunCell cellId _) d = do
  Tuple _ m' <- readRef m
  now' <- now
  maybe (return unit) (getValue >=> d <<< CellResult cellId now' <<< Right <<< AceContent) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (_2 %~ M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceKnot -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: EAce | eff) -> Eff (HalogenEffects (now :: Now, ace :: EAce | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

ref :: forall e.  Eff (ref :: Ref | e) (RefVal AceKnot)
ref = newRef (Tuple 0 M.empty)


Fix forkAff documentation typo

Fix forkAff documentation typo

module Effect.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invincible
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , effectCanceler
  , fiberCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Lazy (class Lazy)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Parallel.Class (sequential, parallel) as Exports
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.Duration (Milliseconds(..)) as Exports
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error, error)
import Effect.Exception (Error, error, message) as Exports
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff a` is an asynchronous computation with effects. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using
-- | `makeAff` or `liftEffect`.
foreign import data Aff ∷ Type → Type

instance functorAff ∷ Functor Aff where
  map = _map

instance applyAff ∷ Apply Aff where
  apply = ap

instance applicativeAff ∷ Applicative Aff where
  pure = _pure

instance bindAff ∷ Bind Aff where
  bind = _bind

instance monadAff ∷ Monad Aff

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where
  mempty = pure mempty

instance altAff ∷ Alt Aff where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus Aff where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec Aff where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error Aff where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error Aff where
  catchError = _catchError

instance monadEffectAff ∷ MonadEffect Aff where
  liftEffect = _liftEffect

instance lazyAff ∷ Lazy (Aff a) where
  defer f = pure unit >>= f

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ Type → Type

instance functorParAff ∷ Functor ParAff where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply ParAff where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative ParAff where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt ParAff where
  alt = _parAffAlt

instance plusParAff ∷ Plus ParAff where
  empty = parallel empty

instance alternativeParAff ∷ Alternative ParAff

instance parallelAff ∷ Parallel ParAff Aff where
  parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a)
  sequential = _sequential

type OnComplete a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Effect Unit) → Effect Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber a = Fiber
  { run ∷ Effect Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit))
  , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit)
  , onComplete ∷ OnComplete a → Effect (Effect Unit)
  , isSuspended ∷ Effect Boolean
  }

instance functorFiber ∷ Functor Fiber where
  map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply Fiber where
  apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative Fiber where
  pure a = unsafePerformEffect (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ a. Error → Fiber a → Aff Unit
killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _
  then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit))
  else makeAff \k → effectCanceler <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ Fiber ~> Aff
joinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler = Canceler (Error → Aff Unit)

derive instance newtypeCanceler ∷ Newtype Canceler _

instance semigroupCanceler ∷ Semigroup Canceler where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid Canceler where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ Canceler
nonCanceler = Canceler (const (pure unit))

-- | A canceler from an Effect action.
effectCanceler ∷ Effect Unit → Canceler
effectCanceler = Canceler <<< const <<< liftEffect

-- | A canceler from a Fiber.
fiberCanceler ∷ ∀ a. Fiber a → Canceler
fiberCanceler = Canceler <<< flip killFiber

-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`.
launchAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`.
launchAff_ ∷ ∀ a. Aff a → Effect Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runAff k aff = launchAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ a. Aff a → Aff (Fiber a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ a. Aff a → Aff (Fiber a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ Milliseconds → Aff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ a. Aff a
never = makeAff \_ → pure mempty

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ a. Aff a → Aff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ a. Aff a → Aff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ a. Aff Unit → Aff a → Aff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invincible ∷ ∀ a. Aff a → Aff a
invincible a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ a. Aff a → Canceler → Aff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised a =
  { fiber ∷ Fiber a
  , supervisor ∷ Supervisor
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ a. Aff a → Aff a
supervise aff =
  generalBracket (liftEffect acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised a → Aff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Effect (Supervised a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ Type
foreign import _pure ∷ ∀ a. a → Aff a
foreign import _throwError ∷ ∀ a. Error → Aff a
foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a
foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a)
foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b
foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b
foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit)
foreign import _liftEffect ∷ ∀ a. Effect a → Aff a
foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b
foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b
foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a
foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a))
foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a))
foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler)
foreign import _sequential ∷ ParAff ~> Aff

type BracketConditions a b =
  { killed ∷ Error → a → Aff Unit
  , failed ∷ Error → a → Aff Unit
  , completed ∷ b → a → Aff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b

-- | Constructs an `Aff` from low-level `Effect` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a

makeFiber ∷ ∀ a. Aff a → Effect (Fiber a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Effect.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , invincible
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , effectCanceler
  , fiberCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Lazy (class Lazy)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Parallel.Class (sequential, parallel) as Exports
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Data.Time.Duration (Milliseconds(..)) as Exports
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error, error)
import Effect.Exception (Error, error, message) as Exports
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff a` is an asynchronous computation with effects. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Effect` effects using
-- | `makeAff` or `liftEffect`.
foreign import data Aff ∷ Type → Type

instance functorAff ∷ Functor Aff where
  map = _map

instance applyAff ∷ Apply Aff where
  apply = ap

instance applicativeAff ∷ Applicative Aff where
  pure = _pure

instance bindAff ∷ Bind Aff where
  bind = _bind

instance monadAff ∷ Monad Aff

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff a) where
  mempty = pure mempty

instance altAff ∷ Alt Aff where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus Aff where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec Aff where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error Aff where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error Aff where
  catchError = _catchError

instance monadEffectAff ∷ MonadEffect Aff where
  liftEffect = _liftEffect

instance lazyAff ∷ Lazy (Aff a) where
  defer f = pure unit >>= f

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ Type → Type

instance functorParAff ∷ Functor ParAff where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply ParAff where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative ParAff where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt ParAff where
  alt = _parAffAlt

instance plusParAff ∷ Plus ParAff where
  empty = parallel empty

instance alternativeParAff ∷ Alternative ParAff

instance parallelAff ∷ Parallel ParAff Aff where
  parallel = (unsafeCoerce ∷ ∀ a. Aff a → ParAff a)
  sequential = _sequential

type OnComplete a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Effect Unit) → Effect Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber a = Fiber
  { run ∷ Effect Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Effect Unit) (Effect (Effect Unit))
  , join ∷ (Either Error a → Effect Unit) → Effect (Effect Unit)
  , onComplete ∷ OnComplete a → Effect (Effect Unit)
  , isSuspended ∷ Effect Boolean
  }

instance functorFiber ∷ Functor Fiber where
  map f t = unsafePerformEffect (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply Fiber where
  apply t1 t2 = unsafePerformEffect (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative Fiber where
  pure a = unsafePerformEffect (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ a. Error → Fiber a → Aff Unit
killFiber e (Fiber t) = liftEffect t.isSuspended >>= if _
  then liftEffect $ void $ Fn.runFn2 t.kill e (const (pure unit))
  else makeAff \k → effectCanceler <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ Fiber ~> Aff
joinFiber (Fiber t) = makeAff \k → effectCanceler <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler = Canceler (Error → Aff Unit)

derive instance newtypeCanceler ∷ Newtype Canceler _

instance semigroupCanceler ∷ Semigroup Canceler where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid Canceler where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ Canceler
nonCanceler = Canceler (const (pure unit))

-- | A canceler from an Effect action.
effectCanceler ∷ Effect Unit → Canceler
effectCanceler = Canceler <<< const <<< liftEffect

-- | A canceler from a Fiber.
fiberCanceler ∷ ∀ a. Fiber a → Canceler
fiberCanceler = Canceler <<< flip killFiber

-- | Forks an `Aff` from an `Effect` context, returning the `Fiber`.
launchAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Effect` context, discarding the `Fiber`.
launchAff_ ∷ ∀ a. Aff a → Effect Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Effect` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ a. Aff a → Effect (Fiber a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runAff k aff = launchAff $ liftEffect <<< k =<< try aff

-- | Forks an `Aff` from an `Effect` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Effect` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ a. (Either Error a → Effect Unit) → Aff a → Effect (Fiber Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEffect <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ a. Aff a → Aff (Fiber a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ a. Aff a → Aff (Fiber a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ Milliseconds → Aff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ a. Aff a
never = makeAff \_ → pure mempty

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ a. Aff a → Aff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ a. Aff a → Aff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ a. Aff Unit → Aff a → Aff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
invincible ∷ ∀ a. Aff a → Aff a
invincible a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ a. Aff a → Canceler → Aff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ a b. Aff a → (a → Aff Unit) → (a → Aff b) → Aff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised a =
  { fiber ∷ Fiber a
  , supervisor ∷ Supervisor
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ a. Aff a → Aff a
supervise aff =
  generalBracket (liftEffect acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised a → Aff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Effect (Supervised a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ Type
foreign import _pure ∷ ∀ a. a → Aff a
foreign import _throwError ∷ ∀ a. Error → Aff a
foreign import _catchError ∷ ∀ a. Aff a → (Error → Aff a) → Aff a
foreign import _fork ∷ ∀ a. Boolean → Aff a → Aff (Fiber a)
foreign import _map ∷ ∀ a b. (a → b) → Aff a → Aff b
foreign import _bind ∷ ∀ a b. Aff a → (a → Aff b) → Aff b
foreign import _delay ∷ ∀ a. Fn.Fn2 (Unit → Either a Unit) Number (Aff Unit)
foreign import _liftEffect ∷ ∀ a. Effect a → Aff a
foreign import _parAffMap ∷ ∀ a b. (a → b) → ParAff a → ParAff b
foreign import _parAffApply ∷ ∀ a b. ParAff (a → b) → ParAff a → ParAff b
foreign import _parAffAlt ∷ ∀ a. ParAff a → ParAff a → ParAff a
foreign import _makeFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Fiber a))
foreign import _makeSupervisedFiber ∷ ∀ a. Fn.Fn2 FFIUtil (Aff a) (Effect (Supervised a))
foreign import _killAll ∷ Fn.Fn3 Error Supervisor (Effect Unit) (Effect Canceler)
foreign import _sequential ∷ ParAff ~> Aff

type BracketConditions a b =
  { killed ∷ Error → a → Aff Unit
  , failed ∷ Error → a → Aff Unit
  , completed ∷ b → a → Aff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ a b. Aff a → BracketConditions a b → (a → Aff b) → Aff b

-- | Constructs an `Aff` from low-level `Effect` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ a. ((Either Error a → Effect Unit) → Effect Canceler) → Aff a

makeFiber ∷ ∀ a. Aff a → Effect (Fiber a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Use existing fromJust

Use existing fromJust

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Prelude.Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Prelude.Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance enumMonth :: Data.Enum.Enum Month where

  toEnum 0  = Just January
  toEnum 1  = Just February
  toEnum 2  = Just March
  toEnum 3  = Just April
  toEnum 4  = Just May
  toEnum 5  = Just June
  toEnum 6  = Just July
  toEnum 7  = Just August
  toEnum 8  = Just September
  toEnum 8  = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum _  = Nothing

  fromEnum January   = 0
  fromEnum February  = 1
  fromEnum March     = 2
  fromEnum April     = 3
  fromEnum May       = 4
  fromEnum June      = 5
  fromEnum July      = 6
  fromEnum August    = 7
  fromEnum September = 8
  fromEnum October   = 9
  fromEnum November  = 10
  fromEnum December  = 11

instance showMonth :: Prelude.Show Month where

  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumDayOfWeek :: Data.Enum.Enum DayOfWeek where

  toEnum 0  = Just Sunday
  toEnum 1  = Just Monday
  toEnum 2  = Just Tuesday
  toEnum 3  = Just Wednesday
  toEnum 4  = Just Thursday
  toEnum 5  = Just Friday
  toEnum 6  = Just Saturday
  toEnum _  = Nothing

  fromEnum Sunday    = 0
  fromEnum Monday    = 1
  fromEnum Tuesday   = 2
  fromEnum Wednesday = 3
  fromEnum Thursday  = 4
  fromEnum Friday    = 5
  fromEnum Saturday  = 6

instance showDayOfWeek :: Prelude.Show DayOfWeek where

  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import now
  "function now() { \
  \  return DateTime(new Date()); \
  \}" :: forall e. Eff (now :: Now | e) Date

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

instance showDate :: Prelude.Show Date where
  show = liftDate $ jsDateMethod "toString"

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  ) where

import Prelude
import Data.Enum
import Data.Maybe
import Control.Monad.Eff

unsafeFromJust :: forall a. Maybe a -> a
unsafeFromJust (Just a) = a

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Prelude.Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Prelude.Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance enumMonth :: Data.Enum.Enum Month where

  toEnum 0  = Just January
  toEnum 1  = Just February
  toEnum 2  = Just March
  toEnum 3  = Just April
  toEnum 4  = Just May
  toEnum 5  = Just June
  toEnum 6  = Just July
  toEnum 7  = Just August
  toEnum 8  = Just September
  toEnum 8  = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum _  = Nothing

  fromEnum January   = 0
  fromEnum February  = 1
  fromEnum March     = 2
  fromEnum April     = 3
  fromEnum May       = 4
  fromEnum June      = 5
  fromEnum July      = 6
  fromEnum August    = 7
  fromEnum September = 8
  fromEnum October   = 9
  fromEnum November  = 10
  fromEnum December  = 11

instance showMonth :: Prelude.Show Month where

  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumDayOfWeek :: Data.Enum.Enum DayOfWeek where

  toEnum 0  = Just Sunday
  toEnum 1  = Just Monday
  toEnum 2  = Just Tuesday
  toEnum 3  = Just Wednesday
  toEnum 4  = Just Thursday
  toEnum 5  = Just Friday
  toEnum 6  = Just Saturday
  toEnum _  = Nothing

  fromEnum Sunday    = 0
  fromEnum Monday    = 1
  fromEnum Tuesday   = 2
  fromEnum Wednesday = 3
  fromEnum Thursday  = 4
  fromEnum Friday    = 5
  fromEnum Saturday  = 6

instance showDayOfWeek :: Prelude.Show DayOfWeek where

  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import now
  "function now() { \
  \  return DateTime(new Date()); \
  \}" :: forall e. Eff (now :: Now | e) Date

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = unsafeFromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

instance showDate :: Prelude.Show Date where
  show = liftDate $ jsDateMethod "toString"


Fix doc typo in Data.Semigroup.Last

Fix doc typo in Data.Semigroup.Last

module Data.Semigroup.Last where

import Prelude

import Data.Eq (class Eq1)
import Data.Ord (class Ord1)

-- | Semigroup where `append` always takes the second option.
-- |
-- | ``` purescript
-- | Last x <> Last y == Last y
-- | ```
newtype Last a = Last a

derive newtype instance eqLast :: Eq a => Eq (Last a)
derive instance eq1Last :: Eq1 Last

derive newtype instance ordLast :: Ord a => Ord (Last a)
derive instance ord1Last :: Ord1 Last

derive newtype instance boundedLast :: Bounded a => Bounded (Last a)

instance showLast :: Show a => Show (Last a) where
  show (Last a) = "(Last " <> show a <> ")"

derive instance functorLast :: Functor Last

instance applyLast :: Apply Last where
  apply (Last f) (Last x) = Last (f x)

instance applicativeLast :: Applicative Last where
  pure = Last

instance bindLast :: Bind Last where
  bind (Last x) f = f x

instance monadLast :: Monad Last

instance semigroupLast :: Semigroup (Last a) where
  append _ x = x

module Data.Semigroup.Last where

import Prelude

import Data.Eq (class Eq1)
import Data.Ord (class Ord1)

-- | Semigroup where `append` always takes the second option.
-- |
-- | ``` purescript
-- | Last x <> Last y == Last x
-- | ```
newtype Last a = Last a

derive newtype instance eqLast :: Eq a => Eq (Last a)
derive instance eq1Last :: Eq1 Last

derive newtype instance ordLast :: Ord a => Ord (Last a)
derive instance ord1Last :: Ord1 Last

derive newtype instance boundedLast :: Bounded a => Bounded (Last a)

instance showLast :: Show a => Show (Last a) where
  show (Last a) = "(Last " <> show a <> ")"

derive instance functorLast :: Functor Last

instance applyLast :: Apply Last where
  apply (Last f) (Last x) = Last (f x)

instance applicativeLast :: Applicative Last where
  pure = Last

instance bindLast :: Bind Last where
  bind (Last x) f = f x

instance monadLast :: Monad Last

instance semigroupLast :: Semigroup (Last a) where
  append _ x = x


Added `monadErrorMaybe` instance

Added `monadErrorMaybe` instance

module Control.Monad.Error.Class where

import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Maybe.Trans
import Control.Monad.Reader.Trans
import Control.Monad.Writer.Trans
import Control.Monad.State.Trans
import Data.Either
import Data.Maybe
import Data.Monoid

class MonadError e m where
  throwError :: forall a. e -> m a
  catchError :: forall a. m a -> (e -> m a) -> m a

instance monadErrorEither :: MonadError e (Either e) where
  throwError = Left
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadErrorMaybe :: MonadError Unit Maybe where
  throwError = const Nothing
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

instance monadErrorErrorT :: (Monad m) => MonadError e (ErrorT e m) where
  throwError e = ErrorT $ return (Left e)
  catchError m h = ErrorT $ do
    a <- runErrorT m
    case a of
      Left e -> runErrorT (h e)
      Right x -> return (Right x)

instance monadErrorMaybeT :: (Monad m, MonadError e m) => MonadError e (MaybeT m) where
  throwError e = lift (throwError e)
  catchError = liftCatchMaybe catchError

instance monadErrorReaderT :: (Monad m, MonadError e m) => MonadError e (ReaderT r m) where
  throwError e = lift (throwError e)
  catchError = liftCatchReader catchError

instance monadErrorWriterT :: (Monad m, Monoid w, MonadError e m) => MonadError e (WriterT w m) where
  throwError e = lift (throwError e)
  catchError = liftCatchWriter catchError

instance monadErrorStateT :: (Monad m, MonadError e m) => MonadError e (StateT s m) where
  throwError e = lift (throwError e)
  catchError = liftCatchState catchError

module Control.Monad.Error.Class where

import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Maybe.Trans
import Control.Monad.Reader.Trans
import Control.Monad.Writer.Trans
import Control.Monad.State.Trans
import Data.Either
import Data.Monoid

class MonadError e m where
  throwError :: forall a. e -> m a
  catchError :: forall a. m a -> (e -> m a) -> m a

instance monadErrorError :: MonadError e (Either e) where
  throwError = Left
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadErrorErrorT :: (Monad m) => MonadError e (ErrorT e m) where
  throwError e = ErrorT $ return (Left e)
  catchError m h = ErrorT $ do
    a <- runErrorT m
    case a of
      Left e -> runErrorT (h e)
      Right x -> return (Right x)

instance monadErrorMaybeT :: (Monad m, MonadError e m) => MonadError e (MaybeT m) where
  throwError e = lift (throwError e)
  catchError = liftCatchMaybe catchError

instance monadErrorReaderT :: (Monad m, MonadError e m) => MonadError e (ReaderT r m) where
  throwError e = lift (throwError e)
  catchError = liftCatchReader catchError

instance monadErrorWriterT :: (Monad m, Monoid w, MonadError e m) => MonadError e (WriterT w m) where
  throwError e = lift (throwError e)
  catchError = liftCatchWriter catchError

instance monadErrorStateT :: (Monad m, MonadError e m) => MonadError e (StateT s m) where
  throwError e = lift (throwError e)
  catchError = liftCatchState catchError


Re-format parsed values in variables Sql generation

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.SqlSquared.Tagged where

import SlamData.Prelude

import Data.Array as A
import Data.Int as Int
import Data.Formatter.DateTime as Fd
import Data.DateTime as DT
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Data.String.Regex.Unsafe as URX

import SqlSquared (Sql)
import SqlSquared as Sql

import Utils (hush, stringToNumber, stringToBoolean)

newtype ParseError = ParseError String

derive newtype instance eqParseError ∷ Eq ParseError
derive newtype instance ordParseError ∷ Ord ParseError
derive instance newtypeParseError ∷ Newtype ParseError _

instance showParseError ∷ Show ParseError where
  show (ParseError msg) = "(ParseError " <> show msg <> ")"

dateFormat :: String
dateFormat = "YYYY-MM-DD"

timeFormat :: String
timeFormat = "HH:mm:ss"

dateTimeFormat :: String
dateTimeFormat = "YYYY-MM-DDTHH:mm:ssZ"

-- Truncate value to only include YYYY-MM-DD part, in case of Quasar mongo
-- connector issue that cannot represent dates distinct from datetimes.
fixupDate ∷ String → String
fixupDate = Str.take 10

parseTime ∷ String → ParseError ⊹ DT.Time
parseTime = bimap ParseError DT.time ∘ Fd.unformatDateTime timeFormat ∘ tweak
  where
  tweak ∷ String → String
  tweak s
    | Str.length s ≡ 19 = s <> "Z"
    | Str.charAt 10 s ≡ Just ' ' = tweak (Str.take 10 s <> "T" <> Str.drop 11 s)
    | otherwise = s

parseDate ∷ String → ParseError ⊹ DT.Date
parseDate = bimap ParseError DT.date ∘ Fd.unformatDateTime dateFormat ∘ fixupDate

parseDateTime ∷ String → ParseError ⊹ DT.DateTime
parseDateTime = lmap ParseError ∘ Fd.unformatDateTime dateTimeFormat ∘ tweak
  where
  -- The `datetime-local` HTML picker omits the `Z` from the format, so if it's
  -- missing from the input, add it.
  tweak ∷ String → String
  tweak s
    | Str.length s ≡ 19 = s <> "Z"
    | otherwise = s

dateSql ∷ String → Either ParseError Sql
dateSql s = do
  d ← parseDate s
  s' ← lmap ParseError $ Fd.formatDateTime dateFormat (DT.DateTime d bottom)
  pure $ Sql.invokeFunction "DATE" $ pure $ Sql.string s'

timeSql ∷ String → Either ParseError Sql
timeSql s = do
  t ← parseTime s
  s' ← lmap ParseError $ Fd.formatDateTime timeFormat (DT.DateTime bottom t)
  pure $ Sql.invokeFunction "TIME" $ pure $ Sql.string s'

datetimeSql ∷ String → Either ParseError Sql
datetimeSql s = do
  dt ← parseDateTime s
  s' ← lmap ParseError $ Fd.formatDateTime dateTimeFormat dt
  pure $ Sql.invokeFunction "TIMESTAMP" $ pure $ Sql.string s'

intervalSql ∷ String → Either ParseError Sql
intervalSql s = do
  if RX.test rgx s
    then pure $ Sql.invokeFunction "INTERVAL" $ pure $ Sql.string s
    else Left (ParseError ("Failed to parse interval from " <> show s))
  where
  rgx =
    URX.unsafeRegex
      "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?"
      RXF.noFlags

oidSql ∷ String → Either ParseError Sql
oidSql =
  pure ∘ Sql.invokeFunction "OID" ∘ pure ∘ Sql.string

numSql ∷ String → Either ParseError Sql
numSql s =
 case stringToNumber s of
  Nothing → Left (ParseError ("Failed to parse number from " <> show s))
  Just num → pure $ Sql.num num

intSql ∷ String → Either ParseError Sql
intSql s =
 case Int.fromString s of
  Nothing → Left (ParseError ("Failed to parse integer from " <> show s))
  Just int → pure $ Sql.int int

boolSql ∷ String → Either ParseError Sql
boolSql s =
  case stringToBoolean s of
    Nothing → Left (ParseError ("Failed to parse boolean from " <> show s))
    Just bool → pure $ Sql.bool bool

allSqls ∷ String → Array Sql
allSqls s =
  -- TODO: check whether we do want to ignore potential errors here? -gb
  A.mapMaybe (\f → hush (f s))
    [ dateSql, timeSql, datetimeSql, intervalSql, numSql, intSql, boolSql ]

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.SqlSquared.Tagged where

import SlamData.Prelude

import Data.Array as A
import Data.Int as Int
import Data.Formatter.DateTime as Fd
import Data.DateTime as DT
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Data.String.Regex.Unsafe as URX

import SqlSquared (Sql)
import SqlSquared as Sql

import Utils (hush, stringToNumber, stringToBoolean)

newtype ParseError = ParseError String

derive newtype instance eqParseError ∷ Eq ParseError
derive newtype instance ordParseError ∷ Ord ParseError
derive instance newtypeParseError ∷ Newtype ParseError _

instance showParseError ∷ Show ParseError where
  show (ParseError msg) = "(ParseError " <> show msg <> ")"

-- Truncate value to only include YYYY-MM-DD part, in case of Quasar mongo
-- connector issue that cannot represent dates distinct from datetimes.
fixupDate ∷ String → String
fixupDate = Str.take 10

parseTime ∷ String → ParseError ⊹ DT.Time
parseTime = bimap ParseError DT.time ∘ Fd.unformatDateTime "HH:mm:ss" ∘ tweak
  where
  tweak ∷ String → String
  tweak s
    | Str.length s ≡ 19 = s <> "Z"
    | Str.charAt 10 s ≡ Just ' ' = tweak (Str.take 10 s <> "T" <> Str.drop 11 s)
    | otherwise = s

parseDate ∷ String → ParseError ⊹ DT.Date
parseDate = bimap ParseError DT.date ∘ Fd.unformatDateTime "YYYY-MM-DD" ∘ fixupDate

parseDateTime ∷ String → ParseError ⊹ DT.DateTime
parseDateTime = lmap ParseError ∘ Fd.unformatDateTime "YYYY-MM-DDTHH:mm:ssZ" ∘ tweak
  where
  -- The `datetime-local` HTML picker omits the `Z` from the format, so if it's
  -- missing from the input, add it.
  tweak ∷ String → String
  tweak s
    | Str.length s ≡ 19 = s <> "Z"
    | otherwise = s

dateSql ∷ String → Either ParseError Sql
dateSql s = do
  _ ← parseDate s
  pure $ Sql.invokeFunction "DATE" $ pure $ Sql.string s

timeSql ∷ String → Either ParseError Sql
timeSql s = do
  _ ← parseTime s
  pure $ Sql.invokeFunction "TIME" $ pure $ Sql.string s

datetimeSql ∷ String → Either ParseError Sql
datetimeSql s = do
  _ ← parseDateTime s
  pure $ Sql.invokeFunction "TIMESTAMP" $ pure $ Sql.string s

intervalSql ∷ String → Either ParseError Sql
intervalSql s = do
  if RX.test rgx s
    then pure $ Sql.invokeFunction "INTERVAL" $ pure $ Sql.string s
    else Left (ParseError ("Failed to parse interval from " <> show s))
  where
  rgx =
    URX.unsafeRegex
      "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?"
      RXF.noFlags

oidSql ∷ String → Either ParseError Sql
oidSql =
  pure ∘ Sql.invokeFunction "OID" ∘ pure ∘ Sql.string

numSql ∷ String → Either ParseError Sql
numSql s =
 case stringToNumber s of
  Nothing → Left (ParseError ("Failed to parse number from " <> show s))
  Just num → pure $ Sql.num num

intSql ∷ String → Either ParseError Sql
intSql s =
 case Int.fromString s of
  Nothing → Left (ParseError ("Failed to parse integer from " <> show s))
  Just int → pure $ Sql.int int

boolSql ∷ String → Either ParseError Sql
boolSql s =
  case stringToBoolean s of
    Nothing → Left (ParseError ("Failed to parse boolean from " <> show s))
    Just bool → pure $ Sql.bool bool

allSqls ∷ String → Array Sql
allSqls s =
  -- TODO: check whether we do want to ignore potential errors here? -gb
  A.mapMaybe (\f → hush (f s))
    [ dateSql, timeSql, datetimeSql, intervalSql, numSql, intSql, boolSql ]