Fix decoding of timestamp values for variables card (#1255)

{-
Copyright 2016 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.Workspace.FormBuilder.Item.Model
  ( Model
  , _name
  , _fieldType
  , _defaultValue
  , initialModel
  , genModel
  , encode
  , decode
  , EqModel(..)
  , runEqModel
  , defaultValueToVarMapValue
  , emptyValueOfFieldType
  , module SlamData.Workspace.FormBuilder.Item.FieldType
  ) where

import SlamData.Prelude

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as J
import Data.Lens (Lens', lens)
import Data.Json.Extended as EJSON
import Data.String as Str

import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.FormBuilder.Item.FieldType (FieldType(..), _FieldTypeDisplayName, allFieldTypes, fieldTypeToInputType)

import Text.Parsing.Parser as P

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

type Model =
  { name ∷ String
  , fieldType ∷ FieldType
  , defaultValue ∷ Maybe String
  }

genModel ∷ Gen.Gen Model
genModel = do
  name ← SC.arbitrary
  fieldType ← SC.arbitrary
  defaultValue ← SC.arbitrary
  pure { name, fieldType, defaultValue }

_name ∷ Lens' Model String
_name = lens _.name _ { name = _ }

_fieldType ∷ Lens' Model FieldType
_fieldType = lens _.fieldType _ { fieldType = _ }

_defaultValue ∷ Lens' Model (Maybe String)
_defaultValue = lens _.defaultValue _ { defaultValue = _ }

newtype EqModel = EqModel Model

runEqModel
  ∷ EqModel
  → Model
runEqModel (EqModel m) =
  m

instance eqEqModel ∷ Eq EqModel where
  eq (EqModel m1) (EqModel m2) =
    m1.name == m2.name
      && m1.fieldType == m2.fieldType
      && m1.defaultValue == m2.defaultValue

initialModel ∷ Model
initialModel =
  { name : ""
  , fieldType : StringFieldType
  , defaultValue : Nothing
  }

encode
  ∷ Model
  → J.Json
encode st =
  "name" := st.name
  ~> "fieldType" := st.fieldType
  ~> "defaultValue" := st.defaultValue
  ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj →
    { name : _, fieldType : _, defaultValue : _ }
      <$> obj .? "name"
      <*> obj .? "fieldType"
      <*> obj .? "defaultValue"

emptyValueOfFieldType
  ∷ FieldType
  → Port.VarMapValue
emptyValueOfFieldType tau =
  case tau of
    StringFieldType → Port.Literal $ EJSON.string ""
    BooleanFieldType → Port.Literal $ EJSON.boolean true
    NumericFieldType → Port.Literal $ EJSON.decimal zero
    DateTimeFieldType → Port.Literal $ EJSON.timestamp ""
    DateFieldType → Port.Literal $ EJSON.date ""
    TimeFieldType → Port.Literal $ EJSON.time ""
    IntervalFieldType → Port.Literal $ EJSON.interval ""
    ObjectIdFieldType → Port.Literal $ EJSON.objectId ""
    ArrayFieldType → Port.Literal $ EJSON.array mempty
    ObjectFieldType → Port.Literal $ EJSON.object mempty
    SqlExprFieldType → Port.QueryExpr ""
    SqlIdentifierFieldType → Port.QueryExpr "``"

defaultValueToVarMapValue
  ∷ FieldType
  → String
  → Maybe Port.VarMapValue
defaultValueToVarMapValue ty str =
  case ty of
    StringFieldType → Just $ Port.Literal $ EJSON.string str
    DateTimeFieldType → Just $ Port.Literal $ EJSON.timestamp (fixupDateTime str)
    DateFieldType → Just $ Port.Literal $ EJSON.date (fixupDate str)
    TimeFieldType → Just $ Port.Literal $ EJSON.time (fixupTime str)
    IntervalFieldType → Just $ Port.Literal $ EJSON.interval str
    ObjectIdFieldType → Just $ Port.Literal $ EJSON.objectId str
    SqlExprFieldType → Just $ Port.QueryExpr $ str
    SqlIdentifierFieldType → Just $ Port.QueryExpr $ "`" ⊕ str ⊕ "`"
    _ | str == "" → Nothing
    _ →
      P.runParser str EJSON.parseEJson
        # either (\_ → Nothing) (Port.Literal >>> Just)

  where
  -- TODO: we _really_ should have a better representation for date/time in ejson
  fixupDateTime :: String -> String
  fixupDateTime dt =
    let
      t = Str.drop 11 dt
      t' = fromMaybe t (Str.stripSuffix (Str.Pattern "Z") t)
    in
      Str.take 11 dt <> fixupTime t' <> "Z"
  fixupTime :: String -> String
  fixupTime t = if Str.length t == 5 then t <> ":00" else t

  -- 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

{-
Copyright 2016 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.Workspace.FormBuilder.Item.Model
  ( Model
  , _name
  , _fieldType
  , _defaultValue
  , initialModel
  , genModel
  , encode
  , decode
  , EqModel(..)
  , runEqModel
  , defaultValueToVarMapValue
  , emptyValueOfFieldType
  , module SlamData.Workspace.FormBuilder.Item.FieldType
  ) where

import SlamData.Prelude

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as J
import Data.Lens (Lens', lens)
import Data.Json.Extended as EJSON
import Data.String as Str

import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.FormBuilder.Item.FieldType (FieldType(..), _FieldTypeDisplayName, allFieldTypes, fieldTypeToInputType)

import Text.Parsing.Parser as P

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

type Model =
  { name ∷ String
  , fieldType ∷ FieldType
  , defaultValue ∷ Maybe String
  }

genModel ∷ Gen.Gen Model
genModel = do
  name ← SC.arbitrary
  fieldType ← SC.arbitrary
  defaultValue ← SC.arbitrary
  pure { name, fieldType, defaultValue }

_name ∷ Lens' Model String
_name = lens _.name _ { name = _ }

_fieldType ∷ Lens' Model FieldType
_fieldType = lens _.fieldType _ { fieldType = _ }

_defaultValue ∷ Lens' Model (Maybe String)
_defaultValue = lens _.defaultValue _ { defaultValue = _ }

newtype EqModel = EqModel Model

runEqModel
  ∷ EqModel
  → Model
runEqModel (EqModel m) =
  m

instance eqEqModel ∷ Eq EqModel where
  eq (EqModel m1) (EqModel m2) =
    m1.name == m2.name
      && m1.fieldType == m2.fieldType
      && m1.defaultValue == m2.defaultValue

initialModel ∷ Model
initialModel =
  { name : ""
  , fieldType : StringFieldType
  , defaultValue : Nothing
  }

encode
  ∷ Model
  → J.Json
encode st =
  "name" := st.name
  ~> "fieldType" := st.fieldType
  ~> "defaultValue" := st.defaultValue
  ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj →
    { name : _, fieldType : _, defaultValue : _ }
      <$> obj .? "name"
      <*> obj .? "fieldType"
      <*> obj .? "defaultValue"

emptyValueOfFieldType
  ∷ FieldType
  → Port.VarMapValue
emptyValueOfFieldType tau =
  case tau of
    StringFieldType → Port.Literal $ EJSON.string ""
    BooleanFieldType → Port.Literal $ EJSON.boolean true
    NumericFieldType → Port.Literal $ EJSON.decimal zero
    DateTimeFieldType → Port.Literal $ EJSON.timestamp ""
    DateFieldType → Port.Literal $ EJSON.date ""
    TimeFieldType → Port.Literal $ EJSON.time ""
    IntervalFieldType → Port.Literal $ EJSON.interval ""
    ObjectIdFieldType → Port.Literal $ EJSON.objectId ""
    ArrayFieldType → Port.Literal $ EJSON.array mempty
    ObjectFieldType → Port.Literal $ EJSON.object mempty
    SqlExprFieldType → Port.QueryExpr ""
    SqlIdentifierFieldType → Port.QueryExpr "``"

defaultValueToVarMapValue
  ∷ FieldType
  → String
  → Maybe Port.VarMapValue
defaultValueToVarMapValue ty str =
  case ty of
    StringFieldType → Just $ Port.Literal $ EJSON.string str
    DateTimeFieldType → Just $ Port.Literal $ EJSON.timestamp (fixupDateTime str)
    DateFieldType → Just $ Port.Literal $ EJSON.date str
    TimeFieldType → Just $ Port.Literal $ EJSON.time (fixupTime str)
    IntervalFieldType → Just $ Port.Literal $ EJSON.interval str
    ObjectIdFieldType → Just $ Port.Literal $ EJSON.objectId str
    SqlExprFieldType → Just $ Port.QueryExpr $ str
    SqlIdentifierFieldType → Just $ Port.QueryExpr $ "`" ⊕ str ⊕ "`"
    _ | str == "" → Nothing
    _ →
      P.runParser str EJSON.parseEJson
        # either (\_ → Nothing) (Port.Literal >>> Just)

  where
  -- TODO: we _really_ should have a better representation for date/time in ejson
  fixupDateTime :: String -> String
  fixupDateTime dt =
    let
      t = Str.drop 11 dt
      t' = fromMaybe t (Str.stripSuffix (Str.Pattern "Z") t)
    in
      Str.take 11 dt <> fixupTime t' <> "Z"
  fixupTime :: String -> String
  fixupTime t = if Str.length t == 5 then t <> ":00" else t


Inverse boolean string test

Inverse boolean string test

Allows { "test" : undefined } (existence) to mean test == true.

module Options
    ( OptionSpecifications
    , OptionSpecification
    , OptionValues
    , OptionValue
    , Option
    , OptionValueExtractor
    , booleanOption
    , enumOption
    , makeOptionValues
    , lookupOptionValue
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (any, elem, intercalate)
import Data.JSON.AST (Literal(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)

-- FIXME: all of this should be strongly typed and not require
-- unsafePartial.

data OptionValue
    = BooleanValue Boolean
    | EnumValue Int (Array String)

type OptionSpecification =
    { name :: String
    , description :: String
    , typeLabel :: String
    , default :: OptionValue
    }

type OptionSpecifications = Array OptionSpecification
type OptionValues = StrMap OptionValue

type OptionValueExtractor a = OptionValue -> a

type Option a = { specification :: OptionSpecification, extractor :: OptionValueExtractor a }

-- FIXME: error handling!
makeOptionValues :: OptionSpecifications -> StrMap String -> OptionValues
makeOptionValues optionSpecifications optionStrings =
    SM.mapWithKey makeOptionValue validOptions
    where
        specMap :: StrMap OptionSpecification
        specMap = SM.fromFoldable $ map (\spec -> Tuple spec.name spec) optionSpecifications

        validOptions :: StrMap String
        validOptions = SM.filterWithKey isValidOption optionStrings

        isValidOption :: String -> String -> Boolean
        isValidOption optionName value = SM.member optionName specMap

        makeOptionValue :: String -> String -> OptionValue
        makeOptionValue name optionString =
            -- Error handling here - we assume the option has a spec
            let spec = unsafePartial $ fromJust $ SM.lookup name specMap
            in
                case spec.default of
                BooleanValue _ ->
                    let l = String.toLower optionString
                    in BooleanValue $ not $ l `elem` ["false", "f", "no", "n", "0"]
                EnumValue _ cases ->
                    case A.findIndex (eq optionString) cases of
                    Just i -> EnumValue i cases
                    Nothing -> EnumValue 0 cases -- FIXME: handle error

booleanOption :: String -> String -> Boolean -> Option Boolean
booleanOption name description default =
    { specification:
        { name
        , description
        , typeLabel: "yes|no"
        , default: BooleanValue default
        }
    , extractor: \t -> unsafePartial $ extractor t
    }
    where
        extractor :: Partial => OptionValueExtractor Boolean
        extractor (BooleanValue v) = v

enumOption :: forall a. String -> String -> Array (Tuple String a) -> Option a
enumOption name description cases =
    { specification:
        { name
        , description
        , typeLabel: intercalate "|" caseNames
        , default: EnumValue 0 caseNames
        }
    , extractor: \t -> unsafePartial $ extractor t
    }
    where
        caseNames = map fst cases
        caseMap = SM.fromFoldable cases

        extractor :: Partial => OptionValueExtractor a
        extractor (EnumValue i _) =
            fromJust $ SM.lookup (fromJust $ A.index caseNames i) caseMap

lookupOptionValue :: forall a. Option a -> OptionValues -> a
lookupOptionValue { specification: { name, default }, extractor } optionValues =
    case SM.lookup name optionValues of
    Nothing -> extractor default
    Just v -> extractor v

module Options
    ( OptionSpecifications
    , OptionSpecification
    , OptionValues
    , OptionValue
    , Option
    , OptionValueExtractor
    , booleanOption
    , enumOption
    , makeOptionValues
    , lookupOptionValue
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (any, elem, intercalate)
import Data.JSON.AST (Literal(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)

-- FIXME: all of this should be strongly typed and not require
-- unsafePartial.

data OptionValue
    = BooleanValue Boolean
    | EnumValue Int (Array String)

type OptionSpecification =
    { name :: String
    , description :: String
    , typeLabel :: String
    , default :: OptionValue
    }

type OptionSpecifications = Array OptionSpecification
type OptionValues = StrMap OptionValue

type OptionValueExtractor a = OptionValue -> a

type Option a = { specification :: OptionSpecification, extractor :: OptionValueExtractor a }

-- FIXME: error handling!
makeOptionValues :: OptionSpecifications -> StrMap String -> OptionValues
makeOptionValues optionSpecifications optionStrings =
    SM.mapWithKey makeOptionValue validOptions
    where
        specMap :: StrMap OptionSpecification
        specMap = SM.fromFoldable $ map (\spec -> Tuple spec.name spec) optionSpecifications

        validOptions :: StrMap String
        validOptions = SM.filterWithKey isValidOption optionStrings

        isValidOption :: String -> String -> Boolean
        isValidOption optionName value = SM.member optionName specMap

        makeOptionValue :: String -> String -> OptionValue
        makeOptionValue name optionString =
            -- Error handling here - we assume the option has a spec
            let spec = unsafePartial $ fromJust $ SM.lookup name specMap
            in
                case spec.default of
                BooleanValue _ ->
                    let l = String.toLower optionString
                    in BooleanValue $ l `elem` ["true", "t", "yes", "y", "1"]
                EnumValue _ cases ->
                    case A.findIndex (eq optionString) cases of
                    Just i -> EnumValue i cases
                    Nothing -> EnumValue 0 cases -- FIXME: handle error

booleanOption :: String -> String -> Boolean -> Option Boolean
booleanOption name description default =
    { specification:
        { name
        , description
        , typeLabel: "yes|no"
        , default: BooleanValue default
        }
    , extractor: \t -> unsafePartial $ extractor t
    }
    where
        extractor :: Partial => OptionValueExtractor Boolean
        extractor (BooleanValue v) = v

enumOption :: forall a. String -> String -> Array (Tuple String a) -> Option a
enumOption name description cases =
    { specification:
        { name
        , description
        , typeLabel: intercalate "|" caseNames
        , default: EnumValue 0 caseNames
        }
    , extractor: \t -> unsafePartial $ extractor t
    }
    where
        caseNames = map fst cases
        caseMap = SM.fromFoldable cases

        extractor :: Partial => OptionValueExtractor a
        extractor (EnumValue i _) =
            fromJust $ SM.lookup (fromJust $ A.index caseNames i) caseMap

lookupOptionValue :: forall a. Option a -> OptionValues -> a
lookupOptionValue { specification: { name, default }, extractor } optionValues =
    case SM.lookup name optionValues of
    Nothing -> extractor default
    Just v -> extractor v


Fix tree functor instance

Fix tree functor instance

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

-- type Expr = Tree Atom (Binding Unit) Op Unit

-- type MType = Maybe Type

-- type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

toOpTuple :: Op -> Tuple Op MType
toOpTuple op = Tuple op Nothing

exprToTypeTree :: Expr -> TypeTree
exprToTypeTree (Atom _ atom) = Atom Nothing atom
exprToTypeTree (List _ exprs) = List Nothing (map exprToTypeTree exprs)
exprToTypeTree (NTuple _ exprs) = NTuple Nothing (map exprToTypeTree exprs)
exprToTypeTree (Binary _ op t1 t2) = Binary Nothing (toOpTuple op)
  (exprToTypeTree t1)
  (exprToTypeTree t2)
exprToTypeTree (Unary _ op t) = Unary Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (SectL _ t op) = SectL Nothing (exprToTypeTree t) (toOpTuple op)
exprToTypeTree (SectR _ op t) = SectR Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (PrefixOp _ op) = PrefixOp Nothing (toOpTuple op)
exprToTypeTree (IfExpr _ t1 t2 t3) = IfExpr Nothing
  (exprToTypeTree t1)
  (exprToTypeTree t2)
  (exprToTypeTree t3)
exprToTypeTree (ArithmSeq _ t1 mt2 mt3) = ArithmSeq Nothing
  (exprToTypeTree t1)
  (map exprToTypeTree mt2)
  (map exprToTypeTree mt3)
exprToTypeTree (LetExpr _ bs t) = LetExpr Nothing
  (map (\(Tuple b bt) -> Tuple (map (const Nothing) b) (exprToTypeTree bt)) bs)
  (exprToTypeTree t)
exprToTypeTree (Lambda _ bindings t) = Lambda Nothing
  (map (map (const Nothing)) bindings)
  (exprToTypeTree t)
exprToTypeTree (App _ t ts) = App Nothing (exprToTypeTree t) (map exprToTypeTree ts)
exprToTypeTree (ListComp _ t qualTrees) = ListComp Nothing
  (exprToTypeTree t)
  (map go qualTrees)
    where
    go (Gen _ b t) = Gen Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Let _ b t) = Let Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Guard _ t) = Guard Nothing (exprToTypeTree t)

binary :: Op -> TypeTree -> TypeTree -> TypeTree
binary op left right = Binary Nothing (Tuple op Nothing) left right

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorQualTree :: Functor (QualTree b e) where
  map f (Gen d b e) = Gen (f d) b e
  map f (Let d b e) = Let (f d) b e
  map f (Guard d e) = Guard (f d) e

instance functorTree :: Functor (Tree a b c) where
  map f (Atom c a) = Atom (f c) a
  map f (List c xs) = List (f c) (map f <$> xs)
  map f (NTuple c xs) = NTuple (f c) (map f <$> xs)
  map f (Binary c op t1 t2) = Binary (f c) op (map f t1) (map f t2)
  map f (Unary c op t) = Unary (f c) op (map f t)
  map f (SectL c t op) = SectL (f c) (map f t) op
  map f (SectR c op t) = SectR (f c) op (map f t)
  map f (PrefixOp c op) = PrefixOp (f c) op
  map f (IfExpr c t1 t2 t3) = IfExpr (f c) (map f t1) (map f t2) (map f t3)
  map f (ArithmSeq c t1 t2 t3) = ArithmSeq (f c) (map f t1) (map f <$> t2) (map f <$> t3)
  map f (LetExpr c bs t) = LetExpr (f c) (map (rmap (map f)) bs) (map f t)
  map f (Lambda c bs t) = Lambda (f c) bs (map f t)
  map f (App c t ts) = App (f c) (map f t) (map f <$> ts)
  map f (ListComp c t ts) = ListComp (f c) (map f t) (map go ts)
    where
    go (Gen d b e) = Gen (f d) b (map f e)
    go (Let d b e) = Let (f d) b (map f e)
    go (Guard d e) = Guard (f d) (map f e)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

-- type Expr = Tree Atom (Binding Unit) Op Unit
-- type TypeTree = Tree Atom (Binding Type) (Tuple Op Type) Type
type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding MType) TypeTree MType

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding m = Lit       m Atom
               | ConsLit   m (Binding m) (Binding m)
               | ListLit   m (List (Binding m))
               | NTupleLit m (List (Binding m))

derive instance eqBinding :: (Eq a) => Eq (Binding a)

instance functorBinding :: Functor Binding where
  map f (Lit x atom) = Lit (f x) atom
  map f (ConsLit x binding1 binding2) = ConsLit (f x) (f <$> binding1) (f <$> binding2)
  map f (ListLit x bindings) = ListLit (f x) (map f <$> bindings)
  map f (NTupleLit x bindings) = NTupleLit (f x) (map f <$> bindings)

type TypedBinding = Binding (Maybe Type)

extractFromBinding :: forall a. Binding a -> a
extractFromBinding (Lit x _)       = x
extractFromBinding (ConsLit x _ _) = x
extractFromBinding (ListLit x _)   = x
extractFromBinding (NTupleLit x _) = x

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List (Binding MType)) TypeTree

derive instance eqDefintion :: Eq Definition

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: (Show a) => Show (Binding a) where
  show binding = case binding of
    Lit m atom     -> "(Lit " <> show m <> " " <> show atom <> ")"
    ConsLit m b bs -> "(ConsLit " <> show m <> " " <> show b <> " " <> show bs <> ")"
    ListLit m bs   -> "(ListLit " <> show m <> " " <> show bs <> ")"
    NTupleLit m ls -> "(NTupleLit " <> show m <> " " <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b o m =
    Atom      m a
  | List      m (List (Tree a b o m))
  | NTuple    m (List (Tree a b o m))
  | Binary    m o (Tree a b o m) (Tree a b o m)
  | Unary     m o (Tree a b o m)
  | SectL     m (Tree a b o m) o
  | SectR     m o (Tree a b o m)
  | PrefixOp  m o
  | IfExpr    m (Tree a b o m) (Tree a b o m) (Tree a b o m)
  | ArithmSeq m (Tree a b o m) (Maybe (Tree a b o m)) (Maybe (Tree a b o m))
  | LetExpr   m (List (Tuple b (Tree a b o m))) (Tree a b o m)
  | Lambda    m (List b) (Tree a b o m)
  | App       m (Tree a b o m) (List (Tree a b o m))
  | ListComp  m (Tree a b o m) (List (QualTree b (Tree a b o m) m))

-- type Expr = Tree Atom (Binding Unit) Op Unit

-- type MType = Maybe Type

-- type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

toOpTuple :: Op -> Tuple Op MType
toOpTuple op = Tuple op Nothing

exprToTypeTree :: Expr -> TypeTree
exprToTypeTree (Atom _ atom) = Atom Nothing atom
exprToTypeTree (List _ exprs) = List Nothing (map exprToTypeTree exprs)
exprToTypeTree (NTuple _ exprs) = NTuple Nothing (map exprToTypeTree exprs)
exprToTypeTree (Binary _ op t1 t2) = Binary Nothing (toOpTuple op)
  (exprToTypeTree t1)
  (exprToTypeTree t2)
exprToTypeTree (Unary _ op t) = Unary Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (SectL _ t op) = SectL Nothing (exprToTypeTree t) (toOpTuple op)
exprToTypeTree (SectR _ op t) = SectR Nothing (toOpTuple op) (exprToTypeTree t)
exprToTypeTree (PrefixOp _ op) = PrefixOp Nothing (toOpTuple op)
exprToTypeTree (IfExpr _ t1 t2 t3) = IfExpr Nothing
  (exprToTypeTree t1)
  (exprToTypeTree t2)
  (exprToTypeTree t3)
exprToTypeTree (ArithmSeq _ t1 mt2 mt3) = ArithmSeq Nothing
  (exprToTypeTree t1)
  (map exprToTypeTree mt2)
  (map exprToTypeTree mt3)
exprToTypeTree (LetExpr _ bs t) = LetExpr Nothing
  (map (\(Tuple b bt) -> Tuple (map (const Nothing) b) (exprToTypeTree bt)) bs)
  (exprToTypeTree t)
exprToTypeTree (Lambda _ bindings t) = Lambda Nothing
  (map (map (const Nothing)) bindings)
  (exprToTypeTree t)
exprToTypeTree (App _ t ts) = App Nothing (exprToTypeTree t) (map exprToTypeTree ts)
exprToTypeTree (ListComp _ t qualTrees) = ListComp Nothing
  (exprToTypeTree t)
  (map go qualTrees)
    where
    go (Gen _ b t) = Gen Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Let _ b t) = Let Nothing (map (const Nothing) b) (exprToTypeTree t)
    go (Guard _ t) = Guard Nothing (exprToTypeTree t)

binary :: Op -> TypeTree -> TypeTree -> TypeTree
binary op left right = Binary Nothing (Tuple op Nothing) left right

data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorQualTree :: Functor (QualTree b e) where
  map f (Gen d b e) = Gen (f d) b e
  map f (Let d b e) = Let (f d) b e
  map f (Guard d e) = Guard (f d) e

instance functorTree :: Functor (Tree a b c) where
  map f (Atom c a) = Atom (f c) a
  map f (List c xs) = List (f c) (map f <$> xs)
  map f (NTuple c xs) = List (f c) (map f <$> xs)
  map f (Binary c op t1 t2) = Binary (f c) op (map f t1) (map f t2)
  map f (Unary c op t) = Unary (f c) op (map f t)
  map f (SectL c t op) = SectL (f c) (map f t) op
  map f (SectR c op t) = SectR (f c) op (map f t)
  map f (PrefixOp c op) = PrefixOp (f c) op
  map f (IfExpr c t1 t2 t3) = IfExpr (f c) (map f t1) (map f t2) (map f t3)
  map f (ArithmSeq c t1 t2 t3) = ArithmSeq (f c) (map f t1) (map f <$> t2) (map f <$> t3)
  map f (LetExpr c bs t) = LetExpr (f c) (map (rmap (map f)) bs) (map f t)
  map f (Lambda c bs t) = Lambda (f c) bs (map f t)
  map f (App c t ts) = App (f c) (map f t) (map f <$> ts)
  map f (ListComp c t ts) = ListComp (f c) (map f t) (map go ts)
    where
    go (Gen d b e) = Gen (f d) b (map f e)
    go (Let d b e) = Let (f d) b (map f e)
    go (Guard d e) = Guard (f d) (map f e)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

-- type Expr = Tree Atom (Binding Unit) Op Unit
-- type TypeTree = Tree Atom (Binding Type) (Tuple Op Type) Type
type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

type ExprQualTree = QualTree (Binding Unit) Expr Unit

type TypeQual  = QualTree (Binding MType) TypeTree MType

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding m = Lit       m Atom
               | ConsLit   m (Binding m) (Binding m)
               | ListLit   m (List (Binding m))
               | NTupleLit m (List (Binding m))

derive instance eqBinding :: (Eq a) => Eq (Binding a)

instance functorBinding :: Functor Binding where
  map f (Lit x atom) = Lit (f x) atom
  map f (ConsLit x binding1 binding2) = ConsLit (f x) (f <$> binding1) (f <$> binding2)
  map f (ListLit x bindings) = ListLit (f x) (map f <$> bindings)
  map f (NTupleLit x bindings) = NTupleLit (f x) (map f <$> bindings)

type TypedBinding = Binding (Maybe Type)

extractFromBinding :: forall a. Binding a -> a
extractFromBinding (Lit x _)       = x
extractFromBinding (ConsLit x _ _) = x
extractFromBinding (ListLit x _)   = x
extractFromBinding (NTupleLit x _) = x

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List (Binding MType)) TypeTree

derive instance eqDefintion :: Eq Definition

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: (Show a) => Show (Binding a) where
  show binding = case binding of
    Lit m atom     -> "(Lit " <> show m <> " " <> show atom <> ")"
    ConsLit m b bs -> "(ConsLit " <> show m <> " " <> show b <> " " <> show bs <> ")"
    ListLit m bs   -> "(ListLit " <> show m <> " " <> show bs <> ")"
    NTupleLit m ls -> "(NTupleLit " <> show m <> " " <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str


Add patterns to lambda in the frontend

Add patterns to lambda in the frontend

module Web
  ( exprToJQuery
  , Handler ()
  ) where

import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import DOM

import Data.Traversable (for, zipWithA)
import Data.Maybe
import Data.Array ((..), length)
import Data.StrMap (lookup)
import Data.Tuple
import Control.Apply ((*>))

import AST
import Evaluator

type Handler = forall eff. Expr -> Path -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Env -> Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery env expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = do
    J.on "click" (\je _ -> J.stopImmediatePropagation je *> handler expr p) j
    J.addClass "clickable" j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom (Num n)     -> makeDiv (show n) ["atom", "num"]
    Atom (Bool true)  -> makeDiv "True"  ["atom", "bool"]
    Atom (Bool false) -> makeDiv "False" ["atom", "bool"]
    Atom (Name name) -> do
      jName <- makeDiv name ["atom", "name"]
      case lookup name env of
        Just [Tuple [] _] -> addHandler (p End) jName
        _                 -> return jName
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)
    List es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      list js
    SectL e op -> do
      j <- go (p <<< Fst) e
      jop <- makeDiv (show op) ["op"]
      section j jop
    SectR op e -> do
      jop <- makeDiv (show op) ["op"]
      j <- go (p <<< Fst) e
      section jop j
    Prefix op -> makeDiv ("(" ++ show op ++ ")") ["prefix", "op"]
    Lambda binds body -> do
      jBinds <- for binds binding
      jBody <- go (p <<< Fst) body
      lambda jBinds jBody >>= addHandler (p End)
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs >>= addHandler (p End)

binding :: forall eff. Binding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Lit (Num n)     -> makeDiv (show n) ["atom", "name"]
  Lit (Bool true) -> makeDiv "True" ["atom", "name"]
  Lit (Bool false)-> makeDiv "False" ["atom", "name"]
  Lit (Name name) -> makeDiv name ["atom", "name"]
  ConsLit b bs -> do
    jCons <- makeDiv "" []
    makeDiv "(" ["brace"] >>= flip J.append jCons
    binding b             >>= flip J.append jCons
    makeDiv ":" ["brace"] >>= flip J.append jCons
    binding bs            >>= flip J.append jCons
    makeDiv ")" ["brace"] >>= flip J.append jCons
  ListLit bs -> do
    jList <- makeDiv "" []
    makeDiv "[" ["brace"] >>= flip J.append jList
    for bs $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," ["comma"] >>= flip J.append jList
    makeDiv "]" ["brace"] >>= flip J.append jList

lambda :: forall eff. [J.JQuery] -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody = do
  jLam <- makeDiv "" ["lambda"]
  open <- makeDiv "(" ["brace"]
  J.append open jLam
  bs <- makeDiv "\\" ["backslash"]
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" ["arrow"]
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" ["brace"]
  J.append close jLam
  return jLam

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 = do
  jSect <- makeDiv "" ["section"]
  open <- makeDiv "(" ["brace"]
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" ["brace"]
  J.append close jSect
  return jSect

list :: forall eff. [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "" ["list"]
  open <- makeDiv "[" ["brace"]
  J.append open dls
  sep js dls
  close <- makeDiv "]" ["brace"]
  J.append close dls
  return dls
  where
  sep []     dls = return unit
  sep [j]    dls = void $ J.append j dls
  sep (j:js) dls = do
    J.append j dls
    comma <- makeDiv "," ["comma"]
    J.append comma dls
    sep js dls

app :: forall eff. J.JQuery -> [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" ["app"]
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

module Web
  ( exprToJQuery
  , Handler ()
  ) where

import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import DOM

import Data.Traversable (for, zipWithA)
import Data.Maybe
import Data.Array ((..), length)
import Data.StrMap (lookup)
import Data.Tuple
import Control.Apply ((*>))

import AST
import Evaluator

type Handler = forall eff. Expr -> Path -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Env -> Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery env expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = do
    J.on "click" (\je _ -> J.stopImmediatePropagation je *> handler expr p) j
    J.addClass "clickable" j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom (Num n)     -> makeDiv (show n) ["atom", "num"]
    Atom (Bool true)  -> makeDiv "True"  ["atom", "bool"]
    Atom (Bool false) -> makeDiv "False" ["atom", "bool"]
    Atom (Name name) -> do
      jName <- makeDiv name ["atom", "name"]
      case lookup name env of
        Just [Tuple [] _] -> addHandler (p End) jName
        _                 -> return jName
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)
    List es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      list js
    SectL e op -> do
      j <- go (p <<< Fst) e
      jop <- makeDiv (show op) ["op"]
      section j jop
    SectR op e -> do
      jop <- makeDiv (show op) ["op"]
      j <- go (p <<< Fst) e
      section jop j
    Prefix op -> makeDiv ("(" ++ show op ++ ")") ["prefix", "op"]
    Lambda binds body -> do
      jBinds <- for binds binding
      jBody <- go (p <<< Fst) body
      lambda jBinds jBody
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs >>= addHandler (p End)

binding :: forall eff. Binding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Lit (Name name) -> makeDiv name ["atom", "name"]

lambda :: forall eff. [J.JQuery] -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody = do
  jLam <- makeDiv "" ["lambda"]
  open <- makeDiv "(" ["brace"]
  J.append open jLam
  bs <- makeDiv "\\" ["backslash"]
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" ["arrow"]
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" ["brace"]
  J.append close jLam
  return jLam

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 = do
  jSect <- makeDiv "" ["section"]
  open <- makeDiv "(" ["brace"]
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" ["brace"]
  J.append close jSect
  return jSect

list :: forall eff. [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "" ["list"]
  open <- makeDiv "[" ["brace"]
  J.append open dls
  sep js dls
  close <- makeDiv "]" ["brace"]
  J.append close dls
  return dls
  where
  sep []     dls = return unit
  sep [j]    dls = void $ J.append j dls
  sep (j:js) dls = do
    J.append j dls
    comma <- makeDiv "," ["comma"]
    J.append comma dls
    sep js dls

app :: forall eff. J.JQuery -> [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" ["app"]
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d


Better handling of null in C#

Better handling of null in C#

Original commit 15bc3224b115ec743bbc76374e6a4d38bb7db350

module CSharp
    ( renderCSharpClass
    ) where

import Doc
import IR
import Prelude

import Data.Foldable (for_, intercalate)
import Data.Map as Map
import Data.Set as Set
import Data.Tuple as Tuple
import Data.List as L
import Data.List ((:))
import Data.Maybe (Maybe(..))

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: Set.Set IRType -> String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp x <> "?" else renderTypeToCSharp x
    Nothing -> "Either<" <> intercalate ", " (Set.map renderTypeToCSharp s) <> ">"

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass { name } -> name
    IRUnion types -> renderUnionToCSharp types

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> line do
            string "public "
            string $ renderTypeToCSharp ptype
            words ["", pname, "{ get; set; }"]
    line "}"

module CSharp
    ( renderCSharpClass
    ) where

import Doc
import IR
import Prelude

import Data.Foldable (for_, intercalate)
import Data.Map as Map
import Data.Set as Set
import Data.Tuple as Tuple

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass { name } -> name
    IRUnion types -> "Either<" <> intercalate ", " (Set.map renderTypeToCSharp types) <> ">"

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> line do
            string "public "
            string $ renderTypeToCSharp ptype
            words ["", pname, "{ get; set; }"]
    line "}"


`keepIf` function.

`keepIf` function.

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , distinct'
  , zip
  , runSignal
  , unwrap
  , keepIf
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
        sub(val);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = seed;
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(eq) {
  return function(constant) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val)(newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import distinctRefP """
  function distinctRefP(constant, sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (val !== newval) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  }""" :: forall a c. Fn2 (c -> Signal c) (Signal a) (Signal a)

distinct' :: forall a. Signal a -> Signal a
distinct' = runFn2 distinctRefP constant

foreign import zipP """
  function zipP(constant, f, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(f(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(f(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(f(val1)(val2));
    });
    return out;
  }""" :: forall a b c d. Fn4 (d -> Signal d) (a -> b -> c) (Signal a) (Signal b) (Signal c)

zip :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
zip f a b = runFn4 zipP constant f a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

foreign import keepIfP """
  function keepIfP(constant, fn, seed, sig) {
    var out = constant(fn(sig.get()) ? sig.get() : seed);
    sig.subscribe(function(val) { if (fn(val)) out.set(val); });
    return out;
  }""" :: forall a c. Fn4 (c -> Signal c) (a -> Boolean) a (Signal a) (Signal a)

keepIf :: forall a. (a -> Boolean) -> a -> Signal a -> Signal a
keepIf = runFn4 keepIfP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

lift2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
lift2 f a b = f <~ a ~ b

lift3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
lift3 f a b c = f <~ a ~ b ~ c

lift4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
lift4 f a b c d = f <~ a ~ b ~ c ~ d

lift5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
lift5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , distinct'
  , zip
  , runSignal
  , unwrap
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
        sub(val);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = seed;
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(eq) {
  return function(constant) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val)(newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import distinctRefP """
  function distinctRefP(constant, sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (val !== newval) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  }""" :: forall a c. Fn2 (c -> Signal c) (Signal a) (Signal a)

distinct' :: forall a. Signal a -> Signal a
distinct' = runFn2 distinctRefP constant

foreign import zipP """
  function zipP(constant, f, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(f(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(f(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(f(val1)(val2));
    });
    return out;
  }""" :: forall a b c d. Fn4 (d -> Signal d) (a -> b -> c) (Signal a) (Signal b) (Signal c)

zip :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
zip f a b = runFn4 zipP constant f a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

lift2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
lift2 f a b = f <~ a ~ b

lift3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
lift3 f a b c = f <~ a ~ b ~ c

lift4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
lift4 f a b c d = f <~ a ~ b ~ c ~ d

lift5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
lift5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e


Lex haskell-style multiline strings

Lex haskell-style multiline strings

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String
import qualified Data.String.Regex as Rx

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (Integer n1)        (Integer n2)        = n1 == n2
  (==) (Float n1)          (Float n2)          = n1 == n2
  (==) (Hex n1)            (Hex n2)            = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (Natural (buildNat ns.str 0 0)) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case {} of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral line col (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral line col (i + 1) "\"" handleMultiline of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    handleMultiline :: String -> String
    handleMultiline = Rx.replace (Rx.regex "\\\\(\\s*)\\n(\\s*)\\\\" "g") ""

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms (t : ts) (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Line -> Column -> Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral line col start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal at line " ++ show line ++ ", column " ++ show col
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (Integer n1)        (Integer n2)        = n1 == n2
  (==) (Float n1)          (Float n2)          = n1 == n2
  (==) (Hex n1)            (Hex n2)            = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (Natural (buildNat ns.str 0 0)) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case {} of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral line col (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral line col (i + 1) "\"" id of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms (t : ts) (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Line -> Column -> Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral line col start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal at line " ++ show line ++ ", column " ++ show col
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false