implemented meta ignoring TypeTree equality function

module AST where

import Prelude
import Control.Monad.State (State, evalState, runState, get, put)
import Data.Bifunctor (bimap, rmap)
import Data.Foldable (intercalate, foldr)
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..), fromJust)
import Data.Traversable (traverse, for)
import Data.Bitraversable (bisequence)
import Data.Tuple (Tuple(..), fst, snd)

-- | 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
        | InfixConstr 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 <> ")"
    InfixConstr op -> "(InfixConstr " <> op <> ")"

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 <> "`"
  InfixConstr o -> o

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String
          | Constr 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))

-- | ONLY FOR TEST PURPOSES
-- | compare two TypeTree values on equality ignoring the meta information
eq' :: TypeTree -> TypeTree -> Boolean
eq' (Atom _ a) (Atom _ b) = a == b
eq' (List _ as) (List _ bs) = and $ zipWith eq' as bs
eq' (NTuple _ as) (NTuple _bs) = and $ zipWith eq' as bs
eq' (Binary _ o l r) (Binary o' l' r') = eqOp' o o' && eq' l l' && eq' r r'
eq' (Unary _ o e) (Unary _ o' e') = eqOp' o o' && eq' e e'
eq' (SectL _ e o) (SectL _ e' o') = eqOp' o o' && eq' e e'
eq' (SectR _ o e) (SectR _ o' e') = eqOp' o o' && eq' e e'
eq' (PrefixOp _ o) (PrefixOp _ o') = eqOp' o o'
eq' (IfExpr _ i t e) (IfExpr _ i' t' e') = eq' i i' && eq' t t' && eq' e e'
eq' (ArithSeq _ a mb mc) (ArithSeq _ a' mb' mc') = eq' a a' && eq'' mb mb' && eq'' mc mc'
 where
  eq'' Nothing Nothing = true
  eq'' (Just a) (Just b) = eq' a b
  eq'' _ _ = false
eq' (LetExpr _ d e) (LetExpr _ d' e') = and (zipWith eq'' d d') && eq' d d'
 where
  eq'' (Tuple b e) (Tuple b' e') = eq'Binding b b' && eq' e e'
eq' (Lambda _ bs e) (Lambda bs' e') = and (zipWith eq'Binding bs bs') && eq' e e'
eq' (App _ f as) (App _ f' as') = eq' f f' && and (zipWith eq' as as')
eq' (ListComp _ e qs) (ListComp e' qs') = eq' e e' && and (zipWith eq'QualTree qs qs')
eq' _ _ = false

eq'Op :: Tuple Op Meta -> Tuple Op Meta -> Boolean
eq'Op (Tuple o _) (Tuple o' _) = o == o'

eq'Binding :: TypedBinding -> TypedBinding -> Boolean
eq'Binding (Lit _ a) (Lit _ a') = a == a'
eq'Binding (ConsLit _ a as) (ConsLit _ a' as') = eq'Binding a a' && eq'Binding as as'
eq'Binding (ListLit _ bs) (ListLit _ bs') = and (zipWith eq'Binding bs bs')
eq'Binding (NTupleLit _ bs) (NTupleLit _bs') = and (zipWith eq'Binding bs bs')
eq'Binding (ConstrLit _ dc) (ConstrLit _ dc') = eq'DataConstr dc dc'
eq'Binding _ _ = false

eq'DataConstr :: DataConstr TypedBinding -> DataConstr TypedBinding -> Boolean
eq'DataConstr (PrefixDataConstr n a ps) (PrefixDataConstr n' a' ps') = n == n' && a == a' && and (zipWith eq'Binding ps ps')
eq'DataConstr (InfixDataConstr n a p l r) (InfixDataConstr n' a' p' l' r') = n == n' && a == a' && p == p' && eq'Binding l l' && eq'Binding r r'
eq'DataConstr _ _ = false

eq'QualTree :: TypeQual -> TypeQual -> Boolean
eq'QualTree (Gen _ b e) (Gen _ b' e') = eq'Binding b b' && eq' e e'
eq'QualTree (Let _ b e) (Let _ b' e') = eq'Binding b b' && eq' e e'
eq'QualTree (Guard _ e) (Guard _ e')  = eq' e e'

toOpTuple :: Op -> Tuple Op Meta
toOpTuple op = Tuple op emptyMeta

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

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

-- | Get the expression element from a given qual tree.
getQualTreeExpression :: forall b t m. QualTree b t m -> t
getQualTreeExpression (Gen _ _ e) = e
getQualTreeExpression (Let _ _ e) = e
getQualTreeExpression (Guard _ e) = e

-- TODO: Find better name.
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)

qualTreeMap :: forall b b' t t' m m'.
     (b -> b')
  -> (t -> t')
  -> (m -> m')
  -> QualTree b t m
  -> QualTree b' t' m'
qualTreeMap fb ft f (Gen x b t) = Gen (f x) (fb b) (ft t)
qualTreeMap fb ft f (Let x b t) = Let (f x) (fb b) (ft t)
qualTreeMap fb ft f (Guard x t) = Guard (f x) (ft t)

treeMap :: forall a a' b b' o o' m m'.
     (a -> a')        -- ^ Function applied to the atom element
  -> (b -> b')        -- ^ Function applied to the binding element
  -> (o -> o')        -- ^ Function applied to the operator element
  -> (m -> m')        -- ^ Function applied to the meta element
  -> Tree a b o m     -- ^ Tree to be transformed
  -> Tree a' b' o' m' -- ^ Transformed tree
treeMap fa fb fo f (Atom x a) = Atom (f x) (fa a)
treeMap fa fb fo f (List x es) = List (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (NTuple x es) = NTuple (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (Binary x o e1 e2) =
  Binary (f x) (fo o)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
treeMap fa fb fo f (Unary x o e) = Unary (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (SectL x e o) = SectL (f x) (treeMap fa fb fo f e) (fo o)
treeMap fa fb fo f (SectR x o e) = SectR (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (PrefixOp x o) = PrefixOp (f x) (fo o)
treeMap fa fb fo f (IfExpr x e1 e2 e3) =
  IfExpr (f x)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
    (treeMap fa fb fo f e3)
treeMap fa fb fo f (ArithmSeq x e me1 me2) =
  ArithmSeq (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) me1)
    (map (treeMap fa fb fo f) me2)
treeMap fa fb fo f (LetExpr x defs e) =
  LetExpr (f x)
    (map (bimap fb (treeMap fa fb fo f)) defs)
    (treeMap fa fb fo f e)
treeMap fa fb fo f (Lambda x bs e) = Lambda (f x) (map fb bs) (treeMap fa fb fo f e)
treeMap fa fb fo f (App x e es) =
  App (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (ListComp x e qualTrees) =
  ListComp (f x)
    (treeMap fa fb fo f e)
    (map (qualTreeMap fb (treeMap fa fb fo f) f) qualTrees)

-- | Inserts Meta information into the given tree node
insertIntoTree :: forall a b c d. d -> Tree a b c d -> Tree a b c d
insertIntoTree x (Atom _ atom) = Atom x atom
insertIntoTree x (List _ ts) = List x ts
insertIntoTree x (NTuple _ ts) = NTuple x ts
insertIntoTree x (Binary _ op t1 t2) = Binary x op t1 t2
insertIntoTree x (Unary _ op t) = Unary x op t
insertIntoTree x (SectL _ t op) = SectL x t op
insertIntoTree x (SectR _ op t) = SectR x op t
insertIntoTree x (PrefixOp _ op) = PrefixOp x op
insertIntoTree x (IfExpr _ t1 t2 t3) = IfExpr x t1 t2 t3
insertIntoTree x (ArithmSeq _ t1 t2 t3) = ArithmSeq x t1 t2 t3
insertIntoTree x (LetExpr _ bs t) = LetExpr x bs t
insertIntoTree x (Lambda _ b t) = Lambda x b t
insertIntoTree x (App _ t ts) = App x t ts
insertIntoTree x (ListComp _ t ts) = ListComp x t ts

-- | Extracts Meta information from the given node
extractFromTree :: forall a b c d. Tree a b c d -> d
extractFromTree (Atom c _) = c
extractFromTree (List c _) = c
extractFromTree (NTuple c _) = c
extractFromTree (Binary c _ _ _) = c
extractFromTree (Unary c _ _) = c
extractFromTree (SectL c _ _) = c
extractFromTree (SectR c _ _) = c
extractFromTree (PrefixOp c _) = c
extractFromTree (IfExpr c _ _ _) = c
extractFromTree (ArithmSeq c _ _ _) = c
extractFromTree (LetExpr c _ _) = c
extractFromTree (Lambda c _ _) = c
extractFromTree (App c _ _) = c
extractFromTree (ListComp c _ _) = c

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

extractFromQualTree :: forall b t m. QualTree b t m -> m
extractFromQualTree (Gen x _ _) = x
extractFromQualTree (Let x _ _) = x
extractFromQualTree (Guard x _) = x

-- | Return a list of child nodes of a given tree.
getTreeChildren :: forall a b o m. Tree a b o m -> List (Tree a b o m)
getTreeChildren (List _ es) = es
getTreeChildren (NTuple _ es) = es
getTreeChildren (Binary _ _ e1 e2) = e1 : e2 : Nil
getTreeChildren (Unary _ _ e) = e : Nil
getTreeChildren (SectL _ e _) = e : Nil
getTreeChildren (SectR _ _ e) = e : Nil
getTreeChildren (IfExpr _ e1 e2 e3) = e1 : e2 : e3 : Nil
getTreeChildren (ArithmSeq _ e me1 me2) = e : (maybeTreeChilden me1) <> (maybeTreeChilden me2)
  where
  maybeTreeChilden (Just t) = t : Nil
  maybeTreeChilden _ = Nil
getTreeChildren (LetExpr _ defs e) = e : (map snd defs)
getTreeChildren (App _ e es) = e : es
getTreeChildren (ListComp _ e quals) = e : (map getQualTreeExpression quals)
getTreeChildren _ = Nil

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type Index = Int
type MIndex = Maybe Index
type MIType = Tuple MType Index

type Meta' = { mindex :: MIndex ,mtype :: MType }
newtype Meta = Meta Meta'

emptyMeta' :: Meta'
emptyMeta' = {mindex: Nothing, mtype: Nothing}

emptyMeta :: Meta
emptyMeta = Meta emptyMeta'

idxMeta :: Int -> Meta
idxMeta i = Meta {mindex: Just i, mtype: Nothing}

instance showMeta :: Show Meta where
  show (Meta meta) = "Meta { mindex: " <> show meta.mindex <> ", mtype: " <> show meta.mtype <> "}"

instance eqMeta :: Eq Meta where
  eq a b = getMetaMIndex a `eq` getMetaMIndex b && getMetaMType a `eq` getMetaMType b

getMetaMIndex :: Meta -> MIndex
getMetaMIndex (Meta meta) = meta.mindex

getMetaMType :: Meta -> MType
getMetaMType (Meta meta) = meta.mtype

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

makeIndexTuple :: Meta -> State Index Meta
makeIndexTuple (Meta meta) = do
  idx <- get
  let new = Meta $ meta {mindex = Just idx}
  put (idx + 1)
  pure new

makeIndexOpTuple :: (Tuple Op Meta) -> State Index (Tuple Op Meta)
makeIndexOpTuple (Tuple op (Meta meta)) = do
  idx <- get
  let new = Tuple op (Meta $ meta {mindex = Just idx})
  put (idx + 1)
  pure new

-- | Transform the given definition into an indexed definition.
makeIndexedDefinition :: Definition -> Index -> Tuple IndexedDefinition Index
makeIndexedDefinition (Def name bindings expr) beginWith =
  let idxAndBindings = runState (toIndexedBindings bindings) beginWith
      idxAndExpr = runState (toIndexedTree expr) (snd idxAndBindings)
  in Tuple (IndexedDef name (fst idxAndBindings) (fst idxAndExpr)) (snd idxAndExpr)
  where
  toIndexedBindings = traverse $ traverseBinding makeIndexTuple
  toIndexedTree expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

makeIndexedTree :: TypeTree -> TypeTree
makeIndexedTree expr = evalState (makeIndexedTree' expr) 0
  where
    -- Traverse the tree and assign indices in ascending order.
    makeIndexedTree' :: TypeTree -> State Index TypeTree
    makeIndexedTree' expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

insertIntoIndexedTree :: MType -> TypeTree -> TypeTree
insertIntoIndexedTree t expr = insertIntoTree (Meta $ meta {mtype = t}) expr
  where
    meta = extractFromTree >>> (\(Meta meta) -> meta) $ expr

definitionIndex :: Partial => IndexedDefinition -> Index
definitionIndex (IndexedDef name bindings expr) = index expr

opIndex :: Partial => (Tuple Op Meta) -> Index
opIndex = snd >>> getMetaMIndex >>> fromJust

bindingIndex :: Partial => (Binding Meta) -> Index
bindingIndex = extractFromBinding >>> getMetaMIndex >>> fromJust

index :: Partial => TypeTree -> Index
index = extractFromTree >>> getMetaMIndex >>> fromJust

traverseBinding :: forall m m' f. Monad f =>
     (m -> f m')
  -> Binding m
  -> f (Binding m')
traverseBinding f (Lit t atom) = do
  t' <- f t
  pure $ Lit t' atom
traverseBinding f (ConsLit t b1 b2) = do
  t' <- f t
  b1' <- traverseBinding f b1
  b2' <- traverseBinding f b2
  pure $ ConsLit t' b1' b2'
traverseBinding f (ListLit t bs) = do
  t' <- f t
  bs' <- traverse (traverseBinding f) bs
  pure $ ListLit t' bs'
traverseBinding f (NTupleLit t bs) = do
  t' <- f t
  bs' <- traverse (traverseBinding f) bs
  pure $ NTupleLit t' bs'
traverseBinding f (ConstrLit t constr) = do
  t' <- f t
  constr' <- case constr of
                  PrefixDataConstr name len ps -> do
                    ps' <- for ps (traverseBinding f)
                    pure $ PrefixDataConstr name len ps'
                  InfixDataConstr op a p l r -> do
                    l' <- traverseBinding f l
                    r' <- traverseBinding f r
                    pure $ InfixDataConstr op a p l' r'
  pure $ ConstrLit t' constr'

traverseQualTree :: forall b b' e e' m m' f. Monad f =>
     (b -> f b')
  -> (e -> f e')
  -> (m -> f m')
  -> QualTree b e m
  -> f (QualTree b' e' m')
traverseQualTree fb fe f (Gen t b e) = do
  t' <- f t
  b' <- fb b
  e' <- fe e
  pure $ Gen t' b' e'
traverseQualTree fb fe f (Let t b e) = do
  t' <- f t
  b' <- fb b
  e' <- fe e
  pure $ Let t' b' e'
traverseQualTree fb fe f (Guard t e) = do
  t' <- f t
  e' <- fe e
  pure $ Guard t' e'

traverseTree :: forall b b' o o' m m' f. Monad f =>
     (b -> f b')
  -> (o -> f o')
  -> (m -> f m')
  -> Tree Atom b o m
  -> f (Tree Atom b' o' m')
traverseTree fb fo f expr@(Atom t atom) = do
  t' <- f t
  pure $ Atom t' atom
traverseTree fb fo f expr@(List t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ List t' es'
traverseTree fb fo f expr@(NTuple t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ NTuple t' es'
traverseTree fb fo f expr@(Binary t o e1 e2) = do
  t' <- f t
  o' <- fo o
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  pure $ Binary t' o' e1' e2'
traverseTree fb fo f expr@(Unary t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ Unary t' o' e'
traverseTree fb fo f expr@(SectL t e o) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  o' <- fo o
  pure $ SectL t' e' o'
traverseTree fb fo f expr@(SectR t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ SectR t' o' e'
traverseTree fb fo f expr@(PrefixOp t o) = do
  t' <- f t
  o' <- fo o
  pure $ PrefixOp t' o'
traverseTree fb fo f expr@(IfExpr t e1 e2 e3) = do
  t' <- f t
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  e3' <- traverseTree fb fo f e3
  pure $ IfExpr t' e1' e2' e3'
traverseTree fb fo f expr@(ArithmSeq t e me1 me2) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  me1' <- traverse (traverseTree fb fo f) me1
  me2' <- traverse (traverseTree fb fo f) me2
  pure $ ArithmSeq t' e' me1' me2'
traverseTree fb fo f expr@(LetExpr t defs e) = do
  t' <- f t
  defs' <- traverse (bimap fb (traverseTree fb fo f) >>> bisequence) defs
  e' <- traverseTree fb fo f e
  pure $ LetExpr t' defs' e'
traverseTree fb fo f expr@(Lambda t bs e) = do
  t' <- f t
  bs' <- traverse fb bs
  e' <- traverseTree fb fo f e
  pure $ Lambda t' bs' e'
traverseTree fb fo f expr@(App t e es) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  es' <- traverse (traverseTree fb fo f) es
  pure $ App t' e' es'
traverseTree fb fo f expr@(ListComp t e quals) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  quals' <- traverse (traverseQualTree fb (traverseTree fb fo f) f) quals
  pure $ ListComp t' e' quals'

type ExprQualTree = QualTree (Binding Unit) Expr Unit
type TypeQual = QualTree (Binding Meta) TypeTree Meta

type TVar = String

data Type
    = TypVar TVar -- Typ Variables x.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | TList Type
    | TTuple (List Type)
    | TTypeCons String (List Type)
    | TypeError TypeError
    | UnknownType

-- ADT Definition
--
-- The definition of a Type consists of the name of the type,
-- followd by type variables, over which it is parametrized
-- and a list of Data Constructors, each having a name,
-- and a list of types, which are their parameters.
data ADTDef
  = ADTDef String (List TVar) (List (DataConstr Type))

-- Translates an ADT definition into a list of Definitions
--
-- e.g:
--
-- the definition
--
--  data Maybe a
--    = Nothing
--    | Just a
--
-- will be translated to
--
--  Nothing :: Maybe a
--  Nothing = Nothing
--  Just :: a -> Maybe a
--  Just = Just
--
-- where the left hand side is just the name,
-- and the right hand side is an actual expression.
compileADTDef :: ADTDef -> List Definition
compileADTDef (ADTDef tname tvars constrs) =
  map (compileDataConstr (TTypeCons tname (map TypVar tvars))) constrs

-- compileADTDef :: ADTDef -> Def
-- compileADTDef (ADTDef tname tvars

derive instance eqADTDef :: Eq ADTDef

instance showADTDef :: Show ADTDef where
  show (ADTDef n vs cs) =
    "data "
    <> n
    <> " "
    <> intercalate " " (map show vs)
    <> "\n  = "
    <> intercalate "\n  | " (map show cs)

-- DataConstrtructor parameterized over its parameters,
-- to use it for both, type definitions and data.

data Associativity
  = LEFTASSOC
  | RIGHTASSOC
  | ASSOC

derive instance eqAssociativity :: Eq Associativity

data DataConstr param
  = PrefixDataConstr String Int (List param)
  | InfixDataConstr String Associativity Int param param

-- This will be called by compileADTDef and does the actual work.
compileDataConstr :: Type -> DataConstr Type -> Definition
compileDataConstr t (PrefixDataConstr name _ ps) =
  Def name Nil (Atom (Meta (emptyMeta' {mtype = Just (foldr TypArr t ps)})) (Constr name))
compileDataConstr t (InfixDataConstr op assoc prec l r) =
  Def op Nil (PrefixOp meta (Tuple (InfixConstr op) meta))
 where
  typ = TypArr l (TypArr r t)
  meta = Meta $ emptyMeta' {mtype = Just typ}

instance functorDataConstr :: Functor DataConstr where
  map f (PrefixDataConstr s i ps) = PrefixDataConstr s i (map f ps)
  map f (InfixDataConstr s a i p1 p2) = InfixDataConstr s a i (f p1) (f p2)

instance showDataConstr :: (Show param) => Show (DataConstr param) where
  show (PrefixDataConstr n _ ts)
    = n <> " " <> intercalate " " (map show ts)
  show (InfixDataConstr o ASSOC _ l r)
    = show l <> " " <> o <> " " <> show r
  show (InfixDataConstr o RIGHTASSOC _ l r)
    = show l <> " " <> o <> " (" <> show r <> ")"
  show (InfixDataConstr o LEFTASSOC _ l r)
    = "(" <> show l <> ") " <> o <> " " <> show r

derive instance eqDataConstr :: (Eq params) => Eq (DataConstr params)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownDataConstructor String
  | UnknownError String
  | NoInstanceOfEnum Type
  | PatternMismatch TypedBinding 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))
               | ConstrLit m (DataConstr (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)
  map f (ConstrLit x c) = ConstrLit (f x) (map (map f) c)

-- | Given a binding, return a list of (direct) children bindings.
getBindingChildren :: forall m. Binding m -> List (Binding m)
getBindingChildren (ConsLit _ b1 b2) = b1 : b2 : Nil
getBindingChildren (ListLit _ bs) = bs
getBindingChildren (NTupleLit _ bs) = bs
getBindingChildren _ = Nil

type TypedBinding = Binding Meta

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

-- | A definition with indexed bindings and an indexed expression.
data IndexedDefinition = IndexedDef String (List TypedBinding) TypeTree

derive instance eqDefintion :: Eq Definition
derive instance eqIndexedDefintion :: Eq IndexedDefinition

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
    Constr string -> "Constr " <> 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 <> ")"
    ConstrLit m c  -> "(ConstrLit " <> show m <> " " <> show c <> ")"

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

instance showIndexedDefinition :: Show IndexedDefinition where
  show (IndexedDef name bindings body) = "IndexedDef " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (UnknownType) = "(UnknownType)"
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"
  show (TTypeCons name ps) = "(TTypeCons " <> show name <> " " <> intercalate " " (map show ps) <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

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 (UnknownDataConstructor a) = "(UnknownDataConstructor " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (PatternMismatch b t) = "(PatternMismatch " <> show b <> " " <> show t <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintAtom :: Atom -> String
prettyPrintAtom (AInt n) = show n
prettyPrintAtom (Bool b) = show b
prettyPrintAtom (Char c) = c
prettyPrintAtom (Name s) = s
prettyPrintAtom (Constr s) = s

prettyPrintBinding :: forall m. Binding m -> String
prettyPrintBinding (Lit _ atom) = prettyPrintAtom atom
prettyPrintBinding (ConsLit _ b1 b2) = "("
    <> prettyPrintBinding b1
    <> ":"
    <> prettyPrintBinding b2
    <> ")"
prettyPrintBinding (ListLit _ bs) = "[" <> intercalate ", " (map prettyPrintBinding bs) <> "]"
prettyPrintBinding (NTupleLit _ bs) = "(" <> intercalate ", " (map prettyPrintBinding bs) <> ")"
prettyPrintBinding (ConstrLit _ (PrefixDataConstr name _ ps)) = "(" <> name <> " " <> intercalate " " (map prettyPrintBinding ps) <> ")"
prettyPrintBinding (ConstrLit _ (InfixDataConstr name _ _ l r)) = "(" <> prettyPrintBinding l <> " " <> name <> " " <> prettyPrintBinding r <> ")"

prettyPrintType :: Type -> String
prettyPrintType (UnknownType) = "?"
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 (TList t) = "[" <> prettyPrintType t <> "]"
prettyPrintType (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
prettyPrintType (TTypeCons name ps)
  = name <> " " <> intercalate " " (map prettyPrintType ps)

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 (UnknownDataConstructor var) = "UnknownDataConstructor: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (PatternMismatch b t) = "PatternMismatch: The pattern " <> prettyPrintBinding b <> " doesn't match with " <> prettyPrintType t
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

module AST where

import Prelude
import Control.Monad.State (State, evalState, runState, get, put)
import Data.Bifunctor (bimap, rmap)
import Data.Foldable (intercalate, foldr)
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..), fromJust)
import Data.Traversable (traverse, for)
import Data.Bitraversable (bisequence)
import Data.Tuple (Tuple(..), fst, snd)

-- | 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
        | InfixConstr 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 <> ")"
    InfixConstr op -> "(InfixConstr " <> op <> ")"

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 <> "`"
  InfixConstr o -> o

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String
          | Constr 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))

toOpTuple :: Op -> Tuple Op Meta
toOpTuple op = Tuple op emptyMeta

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

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

-- | Get the expression element from a given qual tree.
getQualTreeExpression :: forall b t m. QualTree b t m -> t
getQualTreeExpression (Gen _ _ e) = e
getQualTreeExpression (Let _ _ e) = e
getQualTreeExpression (Guard _ e) = e

-- TODO: Find better name.
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)

qualTreeMap :: forall b b' t t' m m'.
     (b -> b')
  -> (t -> t')
  -> (m -> m')
  -> QualTree b t m
  -> QualTree b' t' m'
qualTreeMap fb ft f (Gen x b t) = Gen (f x) (fb b) (ft t)
qualTreeMap fb ft f (Let x b t) = Let (f x) (fb b) (ft t)
qualTreeMap fb ft f (Guard x t) = Guard (f x) (ft t)

treeMap :: forall a a' b b' o o' m m'.
     (a -> a')        -- ^ Function applied to the atom element
  -> (b -> b')        -- ^ Function applied to the binding element
  -> (o -> o')        -- ^ Function applied to the operator element
  -> (m -> m')        -- ^ Function applied to the meta element
  -> Tree a b o m     -- ^ Tree to be transformed
  -> Tree a' b' o' m' -- ^ Transformed tree
treeMap fa fb fo f (Atom x a) = Atom (f x) (fa a)
treeMap fa fb fo f (List x es) = List (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (NTuple x es) = NTuple (f x) (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (Binary x o e1 e2) =
  Binary (f x) (fo o)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
treeMap fa fb fo f (Unary x o e) = Unary (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (SectL x e o) = SectL (f x) (treeMap fa fb fo f e) (fo o)
treeMap fa fb fo f (SectR x o e) = SectR (f x) (fo o) (treeMap fa fb fo f e)
treeMap fa fb fo f (PrefixOp x o) = PrefixOp (f x) (fo o)
treeMap fa fb fo f (IfExpr x e1 e2 e3) =
  IfExpr (f x)
    (treeMap fa fb fo f e1)
    (treeMap fa fb fo f e2)
    (treeMap fa fb fo f e3)
treeMap fa fb fo f (ArithmSeq x e me1 me2) =
  ArithmSeq (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) me1)
    (map (treeMap fa fb fo f) me2)
treeMap fa fb fo f (LetExpr x defs e) =
  LetExpr (f x)
    (map (bimap fb (treeMap fa fb fo f)) defs)
    (treeMap fa fb fo f e)
treeMap fa fb fo f (Lambda x bs e) = Lambda (f x) (map fb bs) (treeMap fa fb fo f e)
treeMap fa fb fo f (App x e es) =
  App (f x)
    (treeMap fa fb fo f e)
    (map (treeMap fa fb fo f) es)
treeMap fa fb fo f (ListComp x e qualTrees) =
  ListComp (f x)
    (treeMap fa fb fo f e)
    (map (qualTreeMap fb (treeMap fa fb fo f) f) qualTrees)

-- | Inserts Meta information into the given tree node
insertIntoTree :: forall a b c d. d -> Tree a b c d -> Tree a b c d
insertIntoTree x (Atom _ atom) = Atom x atom
insertIntoTree x (List _ ts) = List x ts
insertIntoTree x (NTuple _ ts) = NTuple x ts
insertIntoTree x (Binary _ op t1 t2) = Binary x op t1 t2
insertIntoTree x (Unary _ op t) = Unary x op t
insertIntoTree x (SectL _ t op) = SectL x t op
insertIntoTree x (SectR _ op t) = SectR x op t
insertIntoTree x (PrefixOp _ op) = PrefixOp x op
insertIntoTree x (IfExpr _ t1 t2 t3) = IfExpr x t1 t2 t3
insertIntoTree x (ArithmSeq _ t1 t2 t3) = ArithmSeq x t1 t2 t3
insertIntoTree x (LetExpr _ bs t) = LetExpr x bs t
insertIntoTree x (Lambda _ b t) = Lambda x b t
insertIntoTree x (App _ t ts) = App x t ts
insertIntoTree x (ListComp _ t ts) = ListComp x t ts

-- | Extracts Meta information from the given node
extractFromTree :: forall a b c d. Tree a b c d -> d
extractFromTree (Atom c _) = c
extractFromTree (List c _) = c
extractFromTree (NTuple c _) = c
extractFromTree (Binary c _ _ _) = c
extractFromTree (Unary c _ _) = c
extractFromTree (SectL c _ _) = c
extractFromTree (SectR c _ _) = c
extractFromTree (PrefixOp c _) = c
extractFromTree (IfExpr c _ _ _) = c
extractFromTree (ArithmSeq c _ _ _) = c
extractFromTree (LetExpr c _ _) = c
extractFromTree (Lambda c _ _) = c
extractFromTree (App c _ _) = c
extractFromTree (ListComp c _ _) = c

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

extractFromQualTree :: forall b t m. QualTree b t m -> m
extractFromQualTree (Gen x _ _) = x
extractFromQualTree (Let x _ _) = x
extractFromQualTree (Guard x _) = x

-- | Return a list of child nodes of a given tree.
getTreeChildren :: forall a b o m. Tree a b o m -> List (Tree a b o m)
getTreeChildren (List _ es) = es
getTreeChildren (NTuple _ es) = es
getTreeChildren (Binary _ _ e1 e2) = e1 : e2 : Nil
getTreeChildren (Unary _ _ e) = e : Nil
getTreeChildren (SectL _ e _) = e : Nil
getTreeChildren (SectR _ _ e) = e : Nil
getTreeChildren (IfExpr _ e1 e2 e3) = e1 : e2 : e3 : Nil
getTreeChildren (ArithmSeq _ e me1 me2) = e : (maybeTreeChilden me1) <> (maybeTreeChilden me2)
  where
  maybeTreeChilden (Just t) = t : Nil
  maybeTreeChilden _ = Nil
getTreeChildren (LetExpr _ defs e) = e : (map snd defs)
getTreeChildren (App _ e es) = e : es
getTreeChildren (ListComp _ e quals) = e : (map getQualTreeExpression quals)
getTreeChildren _ = Nil

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

type Index = Int
type MIndex = Maybe Index
type MIType = Tuple MType Index

type Meta' = { mindex :: MIndex ,mtype :: MType }
newtype Meta = Meta Meta'

emptyMeta' :: Meta'
emptyMeta' = {mindex: Nothing, mtype: Nothing}

emptyMeta :: Meta
emptyMeta = Meta emptyMeta'

idxMeta :: Int -> Meta
idxMeta i = Meta {mindex: Just i, mtype: Nothing}

instance showMeta :: Show Meta where
  show (Meta meta) = "Meta { mindex: " <> show meta.mindex <> ", mtype: " <> show meta.mtype <> "}"

instance eqMeta :: Eq Meta where
  eq a b = getMetaMIndex a `eq` getMetaMIndex b && getMetaMType a `eq` getMetaMType b

getMetaMIndex :: Meta -> MIndex
getMetaMIndex (Meta meta) = meta.mindex

getMetaMType :: Meta -> MType
getMetaMType (Meta meta) = meta.mtype

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

makeIndexTuple :: Meta -> State Index Meta
makeIndexTuple (Meta meta) = do
  idx <- get
  let new = Meta $ meta {mindex = Just idx}
  put (idx + 1)
  pure new

makeIndexOpTuple :: (Tuple Op Meta) -> State Index (Tuple Op Meta)
makeIndexOpTuple (Tuple op (Meta meta)) = do
  idx <- get
  let new = Tuple op (Meta $ meta {mindex = Just idx})
  put (idx + 1)
  pure new

-- | Transform the given definition into an indexed definition.
makeIndexedDefinition :: Definition -> Index -> Tuple IndexedDefinition Index
makeIndexedDefinition (Def name bindings expr) beginWith =
  let idxAndBindings = runState (toIndexedBindings bindings) beginWith
      idxAndExpr = runState (toIndexedTree expr) (snd idxAndBindings)
  in Tuple (IndexedDef name (fst idxAndBindings) (fst idxAndExpr)) (snd idxAndExpr)
  where
  toIndexedBindings = traverse $ traverseBinding makeIndexTuple
  toIndexedTree expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

makeIndexedTree :: TypeTree -> TypeTree
makeIndexedTree expr = evalState (makeIndexedTree' expr) 0
  where
    -- Traverse the tree and assign indices in ascending order.
    makeIndexedTree' :: TypeTree -> State Index TypeTree
    makeIndexedTree' expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

insertIntoIndexedTree :: MType -> TypeTree -> TypeTree
insertIntoIndexedTree t expr = insertIntoTree (Meta $ meta {mtype = t}) expr
  where
    meta = extractFromTree >>> (\(Meta meta) -> meta) $ expr

definitionIndex :: Partial => IndexedDefinition -> Index
definitionIndex (IndexedDef name bindings expr) = index expr

opIndex :: Partial => (Tuple Op Meta) -> Index
opIndex = snd >>> getMetaMIndex >>> fromJust

bindingIndex :: Partial => (Binding Meta) -> Index
bindingIndex = extractFromBinding >>> getMetaMIndex >>> fromJust

index :: Partial => TypeTree -> Index
index = extractFromTree >>> getMetaMIndex >>> fromJust

traverseBinding :: forall m m' f. Monad f =>
     (m -> f m')
  -> Binding m
  -> f (Binding m')
traverseBinding f (Lit t atom) = do
  t' <- f t
  pure $ Lit t' atom
traverseBinding f (ConsLit t b1 b2) = do
  t' <- f t
  b1' <- traverseBinding f b1
  b2' <- traverseBinding f b2
  pure $ ConsLit t' b1' b2'
traverseBinding f (ListLit t bs) = do
  t' <- f t
  bs' <- traverse (traverseBinding f) bs
  pure $ ListLit t' bs'
traverseBinding f (NTupleLit t bs) = do
  t' <- f t
  bs' <- traverse (traverseBinding f) bs
  pure $ NTupleLit t' bs'
traverseBinding f (ConstrLit t constr) = do
  t' <- f t
  constr' <- case constr of
                  PrefixDataConstr name len ps -> do
                    ps' <- for ps (traverseBinding f)
                    pure $ PrefixDataConstr name len ps'
                  InfixDataConstr op a p l r -> do
                    l' <- traverseBinding f l
                    r' <- traverseBinding f r
                    pure $ InfixDataConstr op a p l' r'
  pure $ ConstrLit t' constr'

traverseQualTree :: forall b b' e e' m m' f. Monad f =>
     (b -> f b')
  -> (e -> f e')
  -> (m -> f m')
  -> QualTree b e m
  -> f (QualTree b' e' m')
traverseQualTree fb fe f (Gen t b e) = do
  t' <- f t
  b' <- fb b
  e' <- fe e
  pure $ Gen t' b' e'
traverseQualTree fb fe f (Let t b e) = do
  t' <- f t
  b' <- fb b
  e' <- fe e
  pure $ Let t' b' e'
traverseQualTree fb fe f (Guard t e) = do
  t' <- f t
  e' <- fe e
  pure $ Guard t' e'

traverseTree :: forall b b' o o' m m' f. Monad f =>
     (b -> f b')
  -> (o -> f o')
  -> (m -> f m')
  -> Tree Atom b o m
  -> f (Tree Atom b' o' m')
traverseTree fb fo f expr@(Atom t atom) = do
  t' <- f t
  pure $ Atom t' atom
traverseTree fb fo f expr@(List t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ List t' es'
traverseTree fb fo f expr@(NTuple t es) = do
  t' <- f t
  es' <- traverse (traverseTree fb fo f) es
  pure $ NTuple t' es'
traverseTree fb fo f expr@(Binary t o e1 e2) = do
  t' <- f t
  o' <- fo o
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  pure $ Binary t' o' e1' e2'
traverseTree fb fo f expr@(Unary t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ Unary t' o' e'
traverseTree fb fo f expr@(SectL t e o) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  o' <- fo o
  pure $ SectL t' e' o'
traverseTree fb fo f expr@(SectR t o e) = do
  t' <- f t
  o' <- fo o
  e' <- traverseTree fb fo f e
  pure $ SectR t' o' e'
traverseTree fb fo f expr@(PrefixOp t o) = do
  t' <- f t
  o' <- fo o
  pure $ PrefixOp t' o'
traverseTree fb fo f expr@(IfExpr t e1 e2 e3) = do
  t' <- f t
  e1' <- traverseTree fb fo f e1
  e2' <- traverseTree fb fo f e2
  e3' <- traverseTree fb fo f e3
  pure $ IfExpr t' e1' e2' e3'
traverseTree fb fo f expr@(ArithmSeq t e me1 me2) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  me1' <- traverse (traverseTree fb fo f) me1
  me2' <- traverse (traverseTree fb fo f) me2
  pure $ ArithmSeq t' e' me1' me2'
traverseTree fb fo f expr@(LetExpr t defs e) = do
  t' <- f t
  defs' <- traverse (bimap fb (traverseTree fb fo f) >>> bisequence) defs
  e' <- traverseTree fb fo f e
  pure $ LetExpr t' defs' e'
traverseTree fb fo f expr@(Lambda t bs e) = do
  t' <- f t
  bs' <- traverse fb bs
  e' <- traverseTree fb fo f e
  pure $ Lambda t' bs' e'
traverseTree fb fo f expr@(App t e es) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  es' <- traverse (traverseTree fb fo f) es
  pure $ App t' e' es'
traverseTree fb fo f expr@(ListComp t e quals) = do
  t' <- f t
  e' <- traverseTree fb fo f e
  quals' <- traverse (traverseQualTree fb (traverseTree fb fo f) f) quals
  pure $ ListComp t' e' quals'

type ExprQualTree = QualTree (Binding Unit) Expr Unit
type TypeQual = QualTree (Binding Meta) TypeTree Meta

type TVar = String

data Type
    = TypVar TVar -- Typ Variables x.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | TList Type
    | TTuple (List Type)
    | TTypeCons String (List Type)
    | TypeError TypeError
    | UnknownType

-- ADT Definition
--
-- The definition of a Type consists of the name of the type,
-- followd by type variables, over which it is parametrized
-- and a list of Data Constructors, each having a name,
-- and a list of types, which are their parameters.
data ADTDef
  = ADTDef String (List TVar) (List (DataConstr Type))

-- Translates an ADT definition into a list of Definitions
--
-- e.g:
--
-- the definition
--
--  data Maybe a
--    = Nothing
--    | Just a
--
-- will be translated to
--
--  Nothing :: Maybe a
--  Nothing = Nothing
--  Just :: a -> Maybe a
--  Just = Just
--
-- where the left hand side is just the name,
-- and the right hand side is an actual expression.
compileADTDef :: ADTDef -> List Definition
compileADTDef (ADTDef tname tvars constrs) =
  map (compileDataConstr (TTypeCons tname (map TypVar tvars))) constrs

-- compileADTDef :: ADTDef -> Def
-- compileADTDef (ADTDef tname tvars

derive instance eqADTDef :: Eq ADTDef

instance showADTDef :: Show ADTDef where
  show (ADTDef n vs cs) =
    "data "
    <> n
    <> " "
    <> intercalate " " (map show vs)
    <> "\n  = "
    <> intercalate "\n  | " (map show cs)

-- DataConstrtructor parameterized over its parameters,
-- to use it for both, type definitions and data.

data Associativity
  = LEFTASSOC
  | RIGHTASSOC
  | ASSOC

derive instance eqAssociativity :: Eq Associativity

data DataConstr param
  = PrefixDataConstr String Int (List param)
  | InfixDataConstr String Associativity Int param param

-- This will be called by compileADTDef and does the actual work.
compileDataConstr :: Type -> DataConstr Type -> Definition
compileDataConstr t (PrefixDataConstr name _ ps) =
  Def name Nil (Atom (Meta (emptyMeta' {mtype = Just (foldr TypArr t ps)})) (Constr name))
compileDataConstr t (InfixDataConstr op assoc prec l r) =
  Def op Nil (PrefixOp meta (Tuple (InfixConstr op) meta))
 where
  typ = TypArr l (TypArr r t)
  meta = Meta $ emptyMeta' {mtype = Just typ}

instance functorDataConstr :: Functor DataConstr where
  map f (PrefixDataConstr s i ps) = PrefixDataConstr s i (map f ps)
  map f (InfixDataConstr s a i p1 p2) = InfixDataConstr s a i (f p1) (f p2)

instance showDataConstr :: (Show param) => Show (DataConstr param) where
  show (PrefixDataConstr n _ ts)
    = n <> " " <> intercalate " " (map show ts)
  show (InfixDataConstr o ASSOC _ l r)
    = show l <> " " <> o <> " " <> show r
  show (InfixDataConstr o RIGHTASSOC _ l r)
    = show l <> " " <> o <> " (" <> show r <> ")"
  show (InfixDataConstr o LEFTASSOC _ l r)
    = "(" <> show l <> ") " <> o <> " " <> show r

derive instance eqDataConstr :: (Eq params) => Eq (DataConstr params)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownDataConstructor String
  | UnknownError String
  | NoInstanceOfEnum Type
  | PatternMismatch TypedBinding 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))
               | ConstrLit m (DataConstr (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)
  map f (ConstrLit x c) = ConstrLit (f x) (map (map f) c)

-- | Given a binding, return a list of (direct) children bindings.
getBindingChildren :: forall m. Binding m -> List (Binding m)
getBindingChildren (ConsLit _ b1 b2) = b1 : b2 : Nil
getBindingChildren (ListLit _ bs) = bs
getBindingChildren (NTupleLit _ bs) = bs
getBindingChildren _ = Nil

type TypedBinding = Binding Meta

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

-- | A definition with indexed bindings and an indexed expression.
data IndexedDefinition = IndexedDef String (List TypedBinding) TypeTree

derive instance eqDefintion :: Eq Definition
derive instance eqIndexedDefintion :: Eq IndexedDefinition

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
    Constr string -> "Constr " <> 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 <> ")"
    ConstrLit m c  -> "(ConstrLit " <> show m <> " " <> show c <> ")"

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

instance showIndexedDefinition :: Show IndexedDefinition where
  show (IndexedDef name bindings body) = "IndexedDef " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (UnknownType) = "(UnknownType)"
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"
  show (TTypeCons name ps) = "(TTypeCons " <> show name <> " " <> intercalate " " (map show ps) <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

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 (UnknownDataConstructor a) = "(UnknownDataConstructor " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (PatternMismatch b t) = "(PatternMismatch " <> show b <> " " <> show t <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

prettyPrintAtom :: Atom -> String
prettyPrintAtom (AInt n) = show n
prettyPrintAtom (Bool b) = show b
prettyPrintAtom (Char c) = c
prettyPrintAtom (Name s) = s
prettyPrintAtom (Constr s) = s

prettyPrintBinding :: forall m. Binding m -> String
prettyPrintBinding (Lit _ atom) = prettyPrintAtom atom
prettyPrintBinding (ConsLit _ b1 b2) = "("
    <> prettyPrintBinding b1
    <> ":"
    <> prettyPrintBinding b2
    <> ")"
prettyPrintBinding (ListLit _ bs) = "[" <> intercalate ", " (map prettyPrintBinding bs) <> "]"
prettyPrintBinding (NTupleLit _ bs) = "(" <> intercalate ", " (map prettyPrintBinding bs) <> ")"
prettyPrintBinding (ConstrLit _ (PrefixDataConstr name _ ps)) = "(" <> name <> " " <> intercalate " " (map prettyPrintBinding ps) <> ")"
prettyPrintBinding (ConstrLit _ (InfixDataConstr name _ _ l r)) = "(" <> prettyPrintBinding l <> " " <> name <> " " <> prettyPrintBinding r <> ")"

prettyPrintType :: Type -> String
prettyPrintType (UnknownType) = "?"
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 (TList t) = "[" <> prettyPrintType t <> "]"
prettyPrintType (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
prettyPrintType (TTypeCons name ps)
  = name <> " " <> intercalate " " (map prettyPrintType ps)

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 (UnknownDataConstructor var) = "UnknownDataConstructor: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (PatternMismatch b t) = "PatternMismatch: The pattern " <> prettyPrintBinding b <> " doesn't match with " <> prettyPrintType t
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str


Alignment

Alignment

Original commit ec61f3c37b9ac3953d5ba01384bd061078e5522a

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (forEnumerated_, removeElement, sortByKey, sortByKeyM, mapM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenNames

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass: elmNamer nameForClass
        , unionName: Just $ elmNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelNameFromGiven: const "Root"
        , forbiddenFromTopLevelNameGiven
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> a -> Maybe String -> NamingResult
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbidAlso: alsoForbiddenForTypeName name }

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

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

forbiddenFromTopLevelNameGiven :: String -> Array String
forbiddenFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    givenTopLevel <- upperNameStyle <$> getTopLevelNameGiven
    let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    classes <- getClasses
    unions <- getUnions
    classNames <- mapM (\t -> lookupClassName $ fst t) classes
    unionNames <- mapM lookupUnionName unions
    let exports = givenTopLevel : topLevelDecoder : topLevelEncoder : (L.concat $ classNames : unionNames : L.Nil)
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--     import Json.Decode exposing (decodeString)"""
    line $ "--     import " <> givenTopLevel <> " exposing (" <> topLevelDecoder <> ")"
    line """--
-- and you're off to the races with
--"""
    line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> givenTopLevel <> " exposing"
    indent do
        forWithPrefix_ exports "( " ", " \parenOrComma name ->
            line $ parenOrComma <> name
        line ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array exposing (Array, map)
import Dict exposing (Dict, map, toList)

-- top level type
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> givenTopLevel <> " = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> givenTopLevel
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> givenTopLevel <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    blank
    line "-- JSON types"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeDefinition i cls
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line "-- decoders and encoders"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeFunctions i cls
    for_ unions \types -> do
        blank
        renderUnionFunctions types
    blank
    line """--- encoder helpers

makeArrayEncoder : (a -> Jenc.Value) -> Array a -> Jenc.Value
makeArrayEncoder f arr =
    Jenc.array (Array.map f arr)

makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName s

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "makeArrayEncoder" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName s

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition classIndex className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions classIndex className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"

typeRenderer :: (Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit) -> Int -> IRClassData -> Doc Unit
typeRenderer renderer classIndex (IRClassData { properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer classIndex className propertyNames propsList

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    unionName <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: Set IRType -> Doc Unit
renderUnionFunctions allTypes = do
    unionName <- lookupUnionName allTypes
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"


seems to work

seems to work

module Data.Foreign.OOFFI
  ( method0, method0Eff, method0C, method0EffC
  , method1, method1Eff, method1C, method1EffC
  , method2, method2Eff, method2C, method2EffC
  , method3, method3Eff, method3C, method3EffC
  , method4, method4Eff, method4C, method4EffC
  , method5, method5Eff, method5C, method5EffC
  , getter,   getterC
  , modifier, modifierC
  , setter,   setterC
  , instantiate0, instantiate0From
  , instantiate1, instantiate1From
  , instantiate2, instantiate2From
  , instantiate3, instantiate3From
  , instantiate4, instantiate4From
  , instantiate5, instantiate5From ) where

import Data.Function
import Control.Monad.Eff
import Context

gc = (>>=) getContext

foreign import method0Impl
  "function method0Impl(fnName, o){\
  \  return o[fnName]();\
  \}" :: forall o ret. Fn2 String o ret

method0    = runFn2 method0Impl
method0C s = gc \c -> method0 s c

foreign import method0EffImpl
  "function method0EffImpl(fnName, o){\
  \  return function(){\
  \    return o[fnName]();\
  \  };\
  \}" :: forall o a eff. Fn2 String o (Eff eff a)

method0Eff    = runFn2 method0EffImpl
method0EffC s = gc \c -> method0Eff s c

foreign import method1Impl
  "function method1Impl(fnName, o, a){\
  \  return o[fnName](a);\
  \}" :: forall o a ret. Fn3 String o a ret

method1      = runFn3 method1Impl
method1C s a = gc \c -> method1 s c a -- creative anachronism?

foreign import method1EffImpl
  "function method1EffImpl(fnName, o, a){\
  \  return function(){\
  \    return o[fnName](a);\
  \  };\
  \}" :: forall o a b eff. Fn3 String o a (Eff eff b)

method1Eff      = runFn3 method1EffImpl
method1EffC s a = gc \c -> method1Eff s c a

foreign import method2Impl
  "function method2Impl(fnName, o, a, b){\
  \  return o[fnName](a, b);\
  \}" :: forall o a b ret. Fn4 String o a b ret

method2        = runFn4 method2Impl
method2C s a b = gc \c -> method2 s c a b

foreign import method2EffImpl
  "function method2EffImpl(fnName, o, a, b){\
  \  return function(){\
  \    return o[fnName](a, b);\
  \  };\
  \}" :: forall o a b c eff. Fn4 String o a b (Eff eff c)

method2Eff        = runFn4 method2EffImpl
method2EffC s a b = gc \c -> method2Eff s c a b

foreign import method3Impl
  "function method3Impl(fnName, o, a, b, c){\
  \  return o[fnName](a, b, c);\
  \}" :: forall o a b c ret. Fn5 String o a b c ret

method3          = runFn5 method3Impl
method3C s a b c = gc \c' -> method3 s c' a b c

foreign import method3EffImpl
  "function method3EffImpl(fnName, o, a, b, c){\
  \  return function(){\
  \    return o[fnName](a, b, c);\
  \  };\
  \}" :: forall o a b c d eff. Fn5 String o a b c (Eff eff d)

method3Eff          = runFn5 method3EffImpl
method3EffC s a b c = gc \c' -> method3Eff s c' a b c

foreign import method4Impl
  "function method4Impl(fnName, o, a, b, c, e){\
  \  return o[fnName](a, b, c, e);\
  \}" :: forall o a b c e ret. Fn6 String o a b c e ret

method4            = runFn6 method4Impl
method4C s a b c d = gc \c' -> method4 s c' a b c d

foreign import method4EffImpl
  "function method4EffImpl(fnName, o, a, b, c, e){\
  \  return function(){\
  \    return o[fnName](a, b, c, e);\
  \  };\
  \}" :: forall o a b c e f eff. Fn6 String o a b c e (Eff eff f)

method4Eff            = runFn6 method4EffImpl
method4EffC s a b c d = gc \c' -> method4Eff s c' a b c d

foreign import method5Impl
  "function method5Impl(fnName, o, a, b, c, e, f){\
  \  return o[fnName](a, b, c, e, f);\
  \}" :: forall o a b c e f ret. Fn7 String o a b c e f ret

method5              = runFn7 method5Impl
method5C s a b c d e = gc \c' -> method5 s c' a b c d e

foreign import method5EffImpl
  "function method5EffImpl(fnName, o, a, b, c, e, f){\
  \  return function(){\
  \    return o[fnName](a, b, c, e, f);\
  \  };\
  \}" :: forall o a b c e f g eff. Fn7 String o a b c e f (Eff eff g)

method5Eff              = runFn7 method5EffImpl
method5EffC s a b c d e = gc \c' -> method5Eff s c' a b c d e

foreign import getterImpl
  "function getterImpl(propName, o){\
  \  return function(){\
  \    return o[propName];\
  \  };\
  \}" :: forall o a eff. Fn2 String o (Eff eff a)

getter    = runFn2 getterImpl
getterC s = gc \c -> getter s c

foreign import modifierImpl
  "function modifierImpl(propName, o, fn){\
  \  return function(){\
  \    o[propName] = fn(o[propName]);\
  \    return o[propName];\
  \  };\
  \}" :: forall o a b eff. Fn3 String o (a -> b) (Eff eff b)

modifier      = runFn3 modifierImpl
modifierC s f = gc \c -> modifier s c f

foreign import setterImpl
  "function setterImpl(propName, o, v){\
  \  return function(){\
  \    o[propName] = v;\
  \    return v;\
  \  };\
  \}" :: forall o v eff. Fn3 String o v (Eff eff v)

setter      = runFn3 setterImpl
setterC s v = gc \c -> setter s c v

foreign import instantiate0FromImpl """
  function instantiate0FromImpl(string, o){
    return function(){
      return new o[string]();
    };
  }""" :: forall a o e. Fn2 String o (Eff e a)

instantiate0From = runFn2 instantiate0FromImpl

instantiate0 :: forall a e. String -> Eff e a
instantiate0 s = getContext >>= instantiate0From s

foreign import instantiate1FromImpl """
  function instantiate1FromImpl(string, o, x){
    return function(){
      return new o[string](x);
    };
  }""" :: forall a b o e. Fn3 String o a (Eff e b)

instantiate1From = runFn3 instantiate1FromImpl

instantiate1 :: forall a b e. String -> a -> Eff e b
instantiate1 s a = getContext >>= \c -> instantiate1From s c a

foreign import instantiate2FromImpl """
  function instantiate2FromImpl(string, o, x, y){
    return function(){
      return new o[string](x, y);
    };
  }""" :: forall a b c o e. Fn4 String o a b (Eff e c)

instantiate2From = runFn4 instantiate2FromImpl

instantiate2 :: forall a b c e. String -> a -> b -> Eff e c
instantiate2 s a b = getContext >>= \c -> instantiate2From s c a b

foreign import instantiate3FromImpl """
  function instantiate3FromImpl(string, o, x, y, z){
    return function(){
      return new o[string](x, y, z);
    };
  }""" :: forall a b c d o e. Fn5 String o a b c (Eff e d)

instantiate3From = runFn5 instantiate3FromImpl

instantiate3 :: forall a b c d e. String -> a -> b -> c -> Eff e d
instantiate3 s a b c = getContext >>= \c' -> instantiate3From s c' a b c

foreign import instantiate4FromImpl """
  function instantiate4FromImpl(string, o, w, x, y, z){
    return function(){
      return new o[string](w, x, y, z);
    };
  }""" :: forall a b c d e f o. Fn6 String o a b c d (Eff e f)

instantiate4From = runFn6 instantiate4FromImpl

instantiate4 :: forall a b c d e eff. String -> a -> b -> c -> d -> Eff eff e
instantiate4 s a b c d = getContext >>= \c' -> instantiate4From s c' a b c d

foreign import instantiate5FromImpl """
  function instantiate5FromImpl(string, o, v, w, x, y, z){
    return function(){
      return new o[string](v, w, x, y, z);
    };
  }""" :: forall a b c d e f g o. Fn7 String o a b c d f (Eff e g)

instantiate5From = runFn7 instantiate5FromImpl

instantiate5 :: forall a b c d e f eff. String -> a -> b -> c -> d -> e -> Eff eff f
instantiate5 s a b c d e = getContext >>= \c' -> instantiate5From s c' a b c d e

module Data.Foreign.OOFFI
  ( method0, method0Eff, method0C, method0EffC
  , method1, method1Eff, method1C, method1EffC
  , method2, method2Eff, method2C, method2EffC
  , method3, method3Eff, method3C, method3EffC
  , method4, method4Eff, method4C, method4EffC
  , method5, method5Eff, method5C, method5EffC
  , getter,   getterC
  , modifier, modifierC
  , setter,   setterC
  , instantiate0, instantiate0From
  , instantiate1, instantiate1From
  , instantiate2, instantiate2From
  , instantiate3, instantiate3From
  , instantiate4, instantiate4From
  , instantiate5, instantiate5From ) where

import Data.Function
import Control.Monad.Eff
import Context

gc = (>>=) getContext

foreign import method0Impl
  "function method0Impl(fnName, o){\
  \  return o[fnName]();\
  \}" :: forall o ret. Fn2 String o ret

method0    = runFn2 method0Impl
method0C s = gc \c -> method0 s c

foreign import method0EffImpl
  "function method0EffImpl(fnName, o){\
  \  return function(){\
  \    return o[fnName]();\
  \  };\
  \}" :: forall o a eff. Fn2 String o (Eff eff a)

method0Eff    = runFn2 method0EffImpl
method0EffC s = gc \c -> method0Eff s c

foreign import method1Impl
  "function method1Impl(fnName, o, a){\
  \  return o[fnName](a);\
  \}" :: forall o a ret. Fn3 String o a ret

method1      = runFn3 method1Impl
method1C s a = gc \c -> method1 s c a -- creative anachronism?

foreign import method1EffImpl
  "function method1EffImpl(fnName, o, a){\
  \  return function(){\
  \    return o[fnName](a);\
  \  };\
  \}" :: forall o a b eff. Fn3 String o a (Eff eff b)

method1Eff      = runFn3 method1EffImpl
method1EffC s a = gc \c -> method1Eff s c a

foreign import method2Impl
  "function method2Impl(fnName, o, a, b){\
  \  return o[fnName](a, b);\
  \}" :: forall o a b ret. Fn4 String o a b ret

method2        = runFn4 method2Impl
method2C s a b = gc \c -> method2 s c a b

foreign import method2EffImpl
  "function method2EffImpl(fnName, o, a, b){\
  \  return function(){\
  \    return o[fnName](a, b);\
  \  };\
  \}" :: forall o a b c eff. Fn4 String o a b (Eff eff c)

method2Eff        = runFn4 method2EffImpl
method2EffC s a b = gc \c -> method2Eff s c a b

foreign import method3Impl
  "function method3Impl(fnName, o, a, b, c){\
  \  return o[fnName](a, b, c);\
  \}" :: forall o a b c ret. Fn5 String o a b c ret

method3          = runFn5 method3Impl
method3C s a b c = gc \c' -> method3 s c' a b c

foreign import method3EffImpl
  "function method3EffImpl(fnName, o, a, b, c){\
  \  return function(){\
  \    return o[fnName](a, b, c);\
  \  };\
  \}" :: forall o a b c d eff. Fn5 String o a b c (Eff eff d)

method3Eff          = runFn5 method3EffImpl
method3EffC s a b c = gc \c' -> method3Eff s c' a b c

foreign import method4Impl
  "function method4Impl(fnName, o, a, b, c, e){\
  \  return o[fnName](a, b, c, e);\
  \}" :: forall o a b c e ret. Fn6 String o a b c e ret

method4            = runFn6 method4Impl
method4C s a b c d = gc \c' -> method4 s c' a b c d

foreign import method4EffImpl
  "function method4EffImpl(fnName, o, a, b, c, e){\
  \  return function(){\
  \    return o[fnName](a, b, c, e);\
  \  };\
  \}" :: forall o a b c e f eff. Fn6 String o a b c e (Eff eff f)

method4Eff            = runFn6 method4EffImpl
method4EffC s a b c d = gc \c' -> method4Eff s c' a b c d

foreign import method5Impl
  "function method5Impl(fnName, o, a, b, c, e, f){\
  \  return o[fnName](a, b, c, e, f);\
  \}" :: forall o a b c e f ret. Fn7 String o a b c e f ret

method5              = runFn7 method5Impl
method5C s a b c d e = gc \c' -> method5 s c' a b c d e

foreign import method5EffImpl
  "function method5EffImpl(fnName, o, a, b, c, e, f){\
  \  return function(){\
  \    return o[fnName](a, b, c, e, f);\
  \  };\
  \}" :: forall o a b c e f g eff. Fn7 String o a b c e f (Eff eff g)

method5Eff              = runFn7 method5EffImpl
method5EffC s a b c d e = gc \c' -> method5Eff s c' a b c d e

foreign import getterImpl
  "function getterImpl(propName, o){\
  \  return function(){\
  \    return o[propName];\
  \  };\
  \}" :: forall o a eff. Fn2 String o (Eff eff a)

getter    = runFn2 getterImpl
getterC s = gc \c -> getter s c

foreign import modifierImpl
  "function modifierImpl(propName, o, fn){\
  \  return function(){\
  \    o[propName] = fn(o[propName]);\
  \    return o[propName];\
  \  };\
  \}" :: forall o a b eff. Fn3 String o (a -> b) (Eff eff b)

modifier    = runFn3 modifierImpl
modifierC s = gc \c -> modifier s c

foreign import setterImpl
  "function setterImpl(propName, o, v){\
  \  return function(){\
  \    o[propName] = v;\
  \    return v;\
  \  };\
  \}" :: forall o v eff. Fn3 String o v (Eff eff v)

setter = runFn3 setterImpl
setterC s = gc \c -> setter s c

foreign import instantiate0FromImpl """
  function instantiate0FromImpl(string, o){
    return function(){
      return new o[string]();
    };
  }""" :: forall a o e. Fn2 String o (Eff e a)

instantiate0From = runFn2 instantiate0FromImpl

instantiate0 :: forall a e. String -> Eff e a
instantiate0 s = getContext >>= instantiate0From s

foreign import instantiate1FromImpl """
  function instantiate1FromImpl(string, o, x){
    return function(){
      return new o[string](x);
    };
  }""" :: forall a b o e. Fn3 String o a (Eff e b)

instantiate1From = runFn3 instantiate1FromImpl

instantiate1 :: forall a b e. String -> a -> Eff e b
instantiate1 s a = getContext >>= \c -> instantiate1From s c a

foreign import instantiate2FromImpl """
  function instantiate2FromImpl(string, o, x, y){
    return function(){
      return new o[string](x, y);
    };
  }""" :: forall a b c o e. Fn4 String o a b (Eff e c)

instantiate2From = runFn4 instantiate2FromImpl

instantiate2 :: forall a b c e. String -> a -> b -> Eff e c
instantiate2 s a b = getContext >>= \c -> instantiate2From s c a b

foreign import instantiate3FromImpl """
  function instantiate3FromImpl(string, o, x, y, z){
    return function(){
      return new o[string](x, y, z);
    };
  }""" :: forall a b c d o e. Fn5 String o a b c (Eff e d)

instantiate3From = runFn5 instantiate3FromImpl

instantiate3 :: forall a b c d e. String -> a -> b -> c -> Eff e d
instantiate3 s a b c = getContext >>= \c' -> instantiate3From s c' a b c

foreign import instantiate4FromImpl """
  function instantiate4FromImpl(string, o, w, x, y, z){
    return function(){
      return new o[string](w, x, y, z);
    };
  }""" :: forall a b c d e f o. Fn6 String o a b c d (Eff e f)

instantiate4From = runFn6 instantiate4FromImpl

instantiate4 :: forall a b c d e eff. String -> a -> b -> c -> d -> Eff eff e
instantiate4 s a b c d = getContext >>= \c' -> instantiate4From s c' a b c d

foreign import instantiate5FromImpl """
  function instantiate5FromImpl(string, o, v, w, x, y, z){
    return function(){
      return new o[string](v, w, x, y, z);
    };
  }""" :: forall a b c d e f g o. Fn7 String o a b c d f (Eff e g)

instantiate5From = runFn7 instantiate5FromImpl

instantiate5 :: forall a b c d e f eff. String -> a -> b -> c -> d -> e -> Eff eff f
instantiate5 s a b c d e = getContext >>= \c' -> instantiate5From s c' a b c d e


Fix typo

Fix typo

-- | This module defines the `MonadWriter` type class and its instances.

module Control.Monad.Writer.Class where

import Prelude

import Data.Tuple (Tuple(..))

-- | The `MonadTell w` type class represents those monads which support a
-- | monoidal accumulator of type `w`, were `tell` appends a value to the
-- | accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
class Monad m <= MonadTell w m | m -> w where
  tell :: w -> m Unit

-- | An extension of the `MonadTell` class that introduces some operations on
-- | the accumulator:
-- |
-- | - `listen` modifies the result to include the changes to the accumulator.
-- | - `pass` applies the returned function to the accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Laws in addition to the `MonadTell` law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
-- | - `listen (pure a) = pure (Tuple a mempty)`
-- | - `listen (writer a x) = tell x $> Tuple a x`
class MonadTell w m <= MonadWriter w m | m -> w where
  listen :: forall a. m a -> m (Tuple a w)
  pass :: forall a. m (Tuple a (w -> w)) -> m a

-- | Projects a value from modifications made to the accumulator during an
-- | action.
listens :: forall w m a b. MonadWriter w m => (w -> b) -> m a -> m (Tuple a b)
listens f m = do
  Tuple a w <- listen m
  pure $ Tuple a (f w)

-- | Modify the final accumulator value by applying a function.
censor :: forall w m a. MonadWriter w m => (w -> w) -> m a -> m a
censor f m = pass do
  a <- m
  pure $ Tuple a f

-- | This module defines the `MonadWriter` type class and its instances.

module Control.Monad.Writer.Class where

import Prelude

import Data.Tuple (Tuple(..))

-- | The `MonadWriter w` type class represents those monads which support a
-- | monoidal accumulator of type `w`, were `tell` appends a value to the
-- | accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
class Monad m <= MonadTell w m | m -> w where
  tell :: w -> m Unit

-- | An extension of the `MonadTell` class that introduces some operations on
-- | the accumulator:
-- |
-- | - `listen` modifies the result to include the changes to the accumulator.
-- | - `pass` applies the returned function to the accumulator.
-- |
-- | An implementation is provided for `WriterT`, and for other monad
-- | transformers defined in this library.
-- |
-- | Laws in addition to the `MonadTell` law:
-- |
-- | - `do { tell x ; tell y } = tell (x <> y)`
-- | - `listen (pure a) = pure (Tuple a mempty)`
-- | - `listen (writer a x) = tell x $> Tuple a x`
class MonadTell w m <= MonadWriter w m | m -> w where
  listen :: forall a. m a -> m (Tuple a w)
  pass :: forall a. m (Tuple a (w -> w)) -> m a

-- | Projects a value from modifications made to the accumulator during an
-- | action.
listens :: forall w m a b. MonadWriter w m => (w -> b) -> m a -> m (Tuple a b)
listens f m = do
  Tuple a w <- listen m
  pure $ Tuple a (f w)

-- | Modify the final accumulator value by applying a function.
censor :: forall w m a. MonadWriter w m => (w -> w) -> m a -> m a
censor f m = pass do
  a <- m
  pure $ Tuple a f