Fix show instances

Fix show instances

module AST where

import Prelude
import Data.List

-- | 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 | Div | Mod
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar

instance eqOp :: Eq Op where
  eq Composition Composition = true
  eq Power Power = true
  eq Mul  Mul  = true
  eq Div  Div  = true
  eq Mod Mod = true
  eq Add  Add  = true
  eq Sub Sub = true
  eq Colon  Colon  = true
  eq Append Append = true
  eq Equ  Equ  = true
  eq Neq  Neq  = true
  eq Lt  Lt  = true
  eq Leq  Leq  = true
  eq Gt  Gt  = true
  eq Geq Geq = true
  eq And And = true
  eq Or Or = true
  eq Dollar Dollar = true
  eq _ _ = false

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

instance eqAtom :: Eq Atom where
  eq (AInt i)   (AInt j) =  i == j
  eq (Bool b1) (Bool b2) = b1 == b2
  eq (Char s1) (Char s2) = s1 == s2
  eq (Name s1) (Name s2) = s1 == s2
  eq _ _ = false

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.
data Expr = Atom Atom
          | List (List Expr)
          | NTuple (List Expr)
          | Binary Op Expr Expr
          | Unary Op Expr
          | SectL Expr Op
          | SectR Op Expr
          | IfExpr Expr Expr Expr
          | Lambda (List Binding) Expr
          | App Expr (List Expr)

instance eqEpr :: Eq Expr where
  eq (Atom a1)           (Atom a2)         = a1 == a2
  eq (List l1)           (List l2)         = l1 == l2
  eq (NTuple l1)         (NTuple l2)       = l1 == l2
  eq (Binary o1 e1 e2)   (Binary o2 e3 e4) = o1 == o2 && e1 == e3 && e2 == e4
  eq (Unary o1 e1)       (Unary o2 e2)     = o1 == o2 && e1 == e2
  eq (SectL e1 o1)       (SectL e2 o2)     = e1 == e2 && o1 == o2
  eq (SectR o1 e1)       (SectR o2 e2)     = o1 == o2 && e1 == e2
  eq (IfExpr c1 t1 e1)   (IfExpr c2 t2 e2) = c1 == c2 && t1 == t2 && e1 == e2
  eq (Lambda bs1 e1)     (Lambda bs2 e2)   = bs1 == bs2 && e1 == e2
  eq (App e1 l1)         (App e2 l2)       = e1 == e2 && l1 == l2
  eq _                   _                 = false

foldExpr :: forall a.
               (Atom -> a)
            -> ((List a) -> a)
            -> ((List a) -> a)
            -> (Op -> a -> a -> a)
            -> (Op -> a -> a)
            -> (a -> Op -> a)
            -> (Op -> a -> a)
            -> (a -> a -> a -> a)
            -> ((List Binding) -> a -> a)
            -> (a -> (List a) -> a)
            -> Expr -> a
foldExpr atom list ntuple binary unary sectl sectr ifexpr lambda app = go
  where
  go (Atom a)          = atom a
  go (List es)         = list (go <$> es)
  go (NTuple es)       = ntuple (go <$> es)
  go (Binary op e1 e2) = binary op (go e1) (go e2)
  go (Unary op e)      = unary op (go e)
  go (SectL e op)      = sectl (go e) op
  go (SectR op e)      = sectr op (go e)
  go (IfExpr c te ee)  = ifexpr (go c) (go te) (go ee)
  go (Lambda bs e)     = lambda bs (go e)
  go (App e es)        = app (go e) (go <$> es)

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

instance eqBinding :: Eq Binding where
  eq (Lit a1) (Lit a2) = a1 == a2
  eq (ConsLit b1 b2) (ConsLit b3 b4) = b1 == b3 && b2 == b4
  eq (ListLit l1) (ListLit l2) = l1 == l2
  eq (NTupleLit l1) (NTupleLit l2) = l1 == l2
  eq _ _ = false

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

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Div    -> "Div"
    Mod    -> "Mod"
    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"

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

instance showExpr :: Show Expr where
  show expr = case expr of
    Atom atom       -> "(Atom " ++ show atom ++ ")"
    List ls         -> "(List " ++ show ls ++ ")"
    NTuple ls       -> "(NTuple " ++ show ls ++ ")"
    Binary op e1 e2 -> "(Binary " ++ show op ++ " " ++ show e1 ++ " " ++ show e2 ++ ")"
    Unary op e      -> "(Unary " ++ show op ++ " " ++ show e ++ ")"
    SectL expr op   -> "(SectL " ++ show expr ++ " " ++ show op ++ ")"
    SectR op expr   -> "(SectR " ++ show op ++ " " ++ show expr ++ ")"
    IfExpr c te ee  -> "(IfExpr " ++ show c ++ " " ++ show te ++ " " ++ show ee ++ ")"
    Lambda binds body -> "(Lambda " ++ show binds ++ " " ++ show body ++ ")"
    App func args   -> "(App " ++ show func ++ " " ++ show args ++ ")"

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

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

module AST where

import Prelude
import Data.List

-- | 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 | Div | Mod
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar

instance eqOp :: Eq Op where
  eq Composition Composition = true
  eq Power Power = true
  eq Mul  Mul  = true
  eq Div  Div  = true
  eq Mod Mod = true
  eq Add  Add  = true
  eq Sub Sub = true
  eq Colon  Colon  = true
  eq Append Append = true
  eq Equ  Equ  = true
  eq Neq  Neq  = true
  eq Lt  Lt  = true
  eq Leq  Leq  = true
  eq Gt  Gt  = true
  eq Geq Geq = true
  eq And And = true
  eq Or Or = true
  eq Dollar Dollar = true
  eq _ _ = false

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

instance eqAtom :: Eq Atom where
  eq (AInt i)   (AInt j) =  i == j
  eq (Bool b1) (Bool b2) = b1 == b2
  eq (Char s1) (Char s2) = s1 == s2
  eq (Name s1) (Name s2) = s1 == s2
  eq _ _ = false

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.
data Expr = Atom Atom
          | List (List Expr)
          | NTuple (List Expr)
          | Binary Op Expr Expr
          | Unary Op Expr
          | SectL Expr Op
          | SectR Op Expr
          | IfExpr Expr Expr Expr
          | Lambda (List Binding) Expr
          | App Expr (List Expr)

instance eqEpr :: Eq Expr where
  eq (Atom a1)           (Atom a2)         = a1 == a2
  eq (List l1)           (List l2)         = l1 == l2
  eq (NTuple l1)         (NTuple l2)       = l1 == l2
  eq (Binary o1 e1 e2)   (Binary o2 e3 e4) = o1 == o2 && e1 == e3 && e2 == e4
  eq (Unary o1 e1)       (Unary o2 e2)     = o1 == o2 && e1 == e2
  eq (SectL e1 o1)       (SectL e2 o2)     = e1 == e2 && o1 == o2
  eq (SectR o1 e1)       (SectR o2 e2)     = o1 == o2 && e1 == e2
  eq (IfExpr c1 t1 e1)   (IfExpr c2 t2 e2) = c1 == c2 && t1 == t2 && e1 == e2
  eq (Lambda bs1 e1)     (Lambda bs2 e2)   = bs1 == bs2 && e1 == e2
  eq (App e1 l1)         (App e2 l2)       = e1 == e2 && l1 == l2
  eq _                   _                 = false

foldExpr :: forall a.
               (Atom -> a)
            -> ((List a) -> a)
            -> ((List a) -> a)
            -> (Op -> a -> a -> a)
            -> (Op -> a -> a)
            -> (a -> Op -> a)
            -> (Op -> a -> a)
            -> (a -> a -> a -> a)
            -> ((List Binding) -> a -> a)
            -> (a -> (List a) -> a)
            -> Expr -> a
foldExpr atom list ntuple binary unary sectl sectr ifexpr lambda app = go
  where
  go (Atom a)          = atom a
  go (List es)         = list (go <$> es)
  go (NTuple es)       = ntuple (go <$> es)
  go (Binary op e1 e2) = binary op (go e1) (go e2)
  go (Unary op e)      = unary op (go e)
  go (SectL e op)      = sectl (go e) op
  go (SectR op e)      = sectr op (go e)
  go (IfExpr c te ee)  = ifexpr (go c) (go te) (go ee)
  go (Lambda bs e)     = lambda bs (go e)
  go (App e es)        = app (go e) (go <$> es)

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

instance eqBinding :: Eq Binding where
  eq (Lit a1) (Lit a2) = a1 == a2
  eq (ConsLit b1 b2) (ConsLit b3 b4) = b1 == b3 && b2 == b4
  eq (ListLit l1) (ListLit l2) = l1 == l2
  eq (NTupleLit l1) (NTupleLit l2) = l1 == l2
  eq _ _ = false

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

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Div    -> "Div"
    Mod    -> "Mod"
    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"

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

instance showExpr :: Show Expr where
  show expr = case expr of
    Atom atom       -> "(Atom " ++ show atom ++ ")"
    List ls         -> "(List " ++ show ls ++ ")"
    NTuple ls       -> "(NTuple " ++ show ls ++ ")"
    Binary op e1 e2 -> "(Binary " ++ show op ++ " " ++ show e1 ++ " " ++ show e2 ++ ")"
    Unary op e      -> "(Unary " ++ show op ++ " " ++ show e ++ ")"
    SectL expr op   -> "(SectL " ++ show expr ++ " " ++ show op ++ ")"
    SectR op expr   -> "(SectR " ++ show op ++ " " ++ show expr ++ ")"
    IfExpr c te ee  -> "(IfExpr " ++ show c ++ " " ++ show te ++ " " ++ show ee ++ ")"
    Lambda binds body -> "(Lambda " ++ show binds ++ " " ++ show body ++ ")"
    App func args   -> "(App " ++ show func ++ " " ++ show args ++ ")"

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

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


Defined Show instance for the Meta type and redefined it accordingly

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(..))
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 MType
toOpTuple op = Tuple op Nothing

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

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

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

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

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 MIndex = Maybe (Tuple Int Int)

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

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

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

type Index = Int
type MIType = Tuple MType Index
type IndexedTypeTree = Tree Atom (Binding MIType) (Tuple Op MIType) MIType

makeIndexTuple :: MType -> State Index MIType
makeIndexTuple mt = do
  idx <- get
  let new = Tuple mt idx
  put (idx + 1)
  pure new

makeIndexOpTuple :: (Tuple Op MType) -> State Index (Tuple Op MIType)
makeIndexOpTuple (Tuple op mt) = do
  idx <- get
  let new = Tuple op (Tuple mt 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 -> IndexedTypeTree
makeIndexedTree expr = evalState (makeIndexedTree' expr) 0
  where
    -- Traverse the tree and assign indices in ascending order.
    makeIndexedTree' :: TypeTree -> State Index IndexedTypeTree
    makeIndexedTree' expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

removeIndices :: IndexedTypeTree -> TypeTree
removeIndices = treeMap id (map fst) (\(Tuple op mit) -> Tuple op (fst mit)) fst

insertIntoIndexedTree :: MType -> IndexedTypeTree -> IndexedTypeTree
insertIntoIndexedTree t expr = insertIntoTree (Tuple t idx) expr
  where idx = snd $ extractFromTree expr

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

opIndex :: (Tuple Op MIType) -> Index
opIndex (Tuple op (Tuple mt idx)) = idx

bindingIndex :: (Binding MIType) -> Index
bindingIndex = extractFromBinding >>> snd

index :: IndexedTypeTree -> Index
index = extractFromTree >>> snd

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 MType) TypeTree MType
type IndexedQualTree = QualTree (Binding MIType) IndexedTypeTree MIType

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 (Just $ foldr TypArr t ps) (Constr name))
compileDataConstr t (InfixDataConstr op assoc prec l r) =
  Def op Nil (PrefixOp (Just typ) (Tuple (InfixConstr op) (Just typ)))
 where
  typ = TypArr l (TypArr r t)

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 IndexedTypedBinding 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 (Maybe Type)
type IndexedTypedBinding = Binding MIType

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

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

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(..))
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 MType
toOpTuple op = Tuple op Nothing

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

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

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

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

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 MIndex = Maybe (Tuple Int Int)

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

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

type Index = Int
type MIType = Tuple MType Index
type IndexedTypeTree = Tree Atom (Binding MIType) (Tuple Op MIType) MIType

makeIndexTuple :: MType -> State Index MIType
makeIndexTuple mt = do
  idx <- get
  let new = Tuple mt idx
  put (idx + 1)
  pure new

makeIndexOpTuple :: (Tuple Op MType) -> State Index (Tuple Op MIType)
makeIndexOpTuple (Tuple op mt) = do
  idx <- get
  let new = Tuple op (Tuple mt 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 -> IndexedTypeTree
makeIndexedTree expr = evalState (makeIndexedTree' expr) 0
  where
    -- Traverse the tree and assign indices in ascending order.
    makeIndexedTree' :: TypeTree -> State Index IndexedTypeTree
    makeIndexedTree' expr = traverseTree (traverseBinding makeIndexTuple) makeIndexOpTuple makeIndexTuple expr

removeIndices :: IndexedTypeTree -> TypeTree
removeIndices = treeMap id (map fst) (\(Tuple op mit) -> Tuple op (fst mit)) fst

insertIntoIndexedTree :: MType -> IndexedTypeTree -> IndexedTypeTree
insertIntoIndexedTree t expr = insertIntoTree (Tuple t idx) expr
  where idx = snd $ extractFromTree expr

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

opIndex :: (Tuple Op MIType) -> Index
opIndex (Tuple op (Tuple mt idx)) = idx

bindingIndex :: (Binding MIType) -> Index
bindingIndex = extractFromBinding >>> snd

index :: IndexedTypeTree -> Index
index = extractFromTree >>> snd

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 MType) TypeTree MType
type IndexedQualTree = QualTree (Binding MIType) IndexedTypeTree MIType

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 (Just $ foldr TypArr t ps) (Constr name))
compileDataConstr t (InfixDataConstr op assoc prec l r) =
  Def op Nil (PrefixOp (Just typ) (Tuple (InfixConstr op) (Just typ)))
 where
  typ = TypArr l (TypArr r t)

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 IndexedTypedBinding 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 (Maybe Type)
type IndexedTypedBinding = Binding MIType

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

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

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


Make IRNothing "anything" in enums

Make IRNothing "anything" in enums

Original commit 90b4029a2e61fdfe1001f15776aa43f3326341dd

module Doc
    ( Doc
    , Renderer
    , Transforms
    , Namer
    , getTopLevels
    , getSingleTopLevel
    , getModuleName
    , getForSingleOrMultipleTopLevels
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , getTopLevelNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , lookupTopLevelName
    , forEachTopLevel_
    , forEachClass_
    , forEachUnion_
    , combineNames
    , NamingResult
    , transformNames
    , transformPropertyNames
    , simpleNamer
    , noForbidNamer
    , forbidNamer
    , unionNameIntercalated
    , unionIsNotSimpleNullable
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Array as A
import Data.Foldable (for_, any, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, maybe, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.String.Util (times) as String
import Data.Tuple (Tuple(..), fst, snd)
import Utils (sortByKeyM)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type NamingResult = { name :: String, forbid :: Array String }
type Namer a = a -> Maybe String -> NamingResult

type Transforms =
    { nameForClass :: Namer IRClassData
    , nextName :: String -> String
    , forbiddenNames :: Array String
    , topLevelName :: Namer String
    , unions :: Maybe
        { predicate :: IRUnionRep -> Boolean
        , properName :: Namer (Named (Set String))
        , nameFromTypes :: Namer (Array String)
        }
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map IRUnionRep String
    , topLevelNames :: Map String String
    , unions :: Array IRUnionRep -- FIXME: we do we even keep this?
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph@(IRGraph { toplevels }) =
    let topLevelTuples = map (\n -> Tuple n n) $ M.keys toplevels
        forbiddenFromStart = S.fromFoldable t.forbiddenNames
        { names: topLevelNames, forbidden: forbiddenAfterTopLevels } = transformNames t.topLevelName t.nextName forbiddenFromStart topLevelTuples
        classes = classesInGraph graph
        { names: classNames, forbidden: forbiddenAfterClasses } = transformNames t.nameForClass t.nextName forbiddenAfterTopLevels classes
        { unions, unionNames } = doUnions classNames forbiddenAfterClasses
    in
        evalRWS w { graph, classNames, unionNames, topLevelNames, unions } { indent: 0 } # snd
    where
        doUnions :: Map Int String -> Set String -> { unions :: Array IRUnionRep, unionNames :: Map IRUnionRep String }
        doUnions classNames forbidden = case t.unions of
            Nothing -> { unions: [], unionNames: M.empty }
            Just { predicate, properName, nameFromTypes } ->
                let unions = A.fromFoldable $ filterTypes (unionPredicate predicate) graph
                    unionNames = (transformNames (unionNamer nameFromTypes properName classNames) t.nextName forbidden $ L.fromFoldable $ map (\s -> Tuple s s) unions).names
                in
                    { unions, unionNames }

        unionPredicate :: (IRUnionRep -> Boolean) -> IRType -> Maybe IRUnionRep
        unionPredicate p (IRUnion ur) = if p ur then Just ur else Nothing
        unionPredicate _ _ = Nothing

        unionNamer :: Namer (Array String) -> Namer (Named (Set String)) -> Map Int String -> Namer IRUnionRep
        unionNamer nameFromTypes properName classNames union@(IRUnionRep { names }) =
            if namedValue names == S.empty then
                let typeStrings = map (typeNameForUnion graph classNames) $ A.sort $ A.fromFoldable $ unionToSet union
                in
                    nameFromTypes typeStrings
            else
                properName names

transformNames :: forall a b. Ord a => Ord b => Namer b -> (String -> String) -> Set String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
transformNames legalize otherize illegalNames names =
    process S.empty illegalNames M.empty names
    where
        makeName :: b -> NamingResult -> Set String -> Set String -> NamingResult
        makeName name result@{ name: tryName, forbid } forbiddenInScope forbiddenForAll =
            if S.member tryName forbiddenInScope || any (\x -> S.member x forbiddenForAll) forbid then
                makeName name (legalize name (Just $ otherize tryName)) forbiddenInScope forbiddenForAll
            else
                result
        process :: Set String -> Set String -> Map a String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
        process forbiddenInScope forbiddenForAll mapSoFar l =
            case l of
            L.Nil -> { names: mapSoFar, forbidden: forbiddenForAll }
            (Tuple identifier inputs) : rest ->
                let { name, forbid } = makeName inputs (legalize inputs Nothing) forbiddenInScope forbiddenForAll
                    newForbiddenInScope = S.insert name forbiddenInScope
                    newForbiddenForAll = S.union (S.fromFoldable forbid) forbiddenForAll
                    newMap = M.insert identifier name mapSoFar
                in
                    process newForbiddenInScope newForbiddenForAll newMap rest

transformPropertyNames :: Namer String -> (String -> String) -> Array String -> Map String IRType -> Map String String
transformPropertyNames legalize otherize illegalNamesArray properties =
    let illegalNames = S.fromFoldable illegalNamesArray
    in
        _.names $ transformNames legalize otherize illegalNames $ map (\n -> Tuple n n) $ M.keys properties

forbidNamer :: forall a. Ord a => (a -> String) -> (String -> Array String) -> Namer a
forbidNamer namer forbidder _ (Just name) = { name, forbid: forbidder name }
forbidNamer namer forbidder x Nothing =
    let name = namer x
    in { name, forbid: forbidder name }

simpleNamer :: forall a. Ord a => (a -> String) -> Namer a
simpleNamer namer = forbidNamer namer A.singleton

noForbidNamer :: forall a. Ord a => (a -> String) -> Namer a
noForbidNamer namer = forbidNamer namer (const [])

typeNameForUnion :: IRGraph -> Map Int String -> IRType -> String
typeNameForUnion graph classNames = case _ of
    IRNothing -> "anything"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph classNames a <> "_array"
    IRClass i -> lookupName i classNames
    IRMap t -> typeNameForUnion graph classNames t <> "_map"
    IRUnion _ -> "union"

unionNameIntercalated :: (String -> String) -> String -> Array String -> String
unionNameIntercalated nameStyle orString names =
    names
    <#> nameStyle
    # intercalate orString

unionIsNotSimpleNullable :: IRUnionRep -> Boolean
unionIsNotSimpleNullable ur = isNothing $ nullableFromSet $ unionToSet ur

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  classNames <- getClassNames
  pure $ typeNameForUnion g classNames typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevels :: Doc (Map String IRType)
getTopLevels = do
    IRGraph { toplevels } <- getGraph
    pure toplevels

getSingleTopLevel :: Doc (Maybe (Tuple String IRType))
getSingleTopLevel = do
    topLevels <- getTopLevels
    case M.toUnfoldable topLevels :: List _ of
        t : L.Nil -> pure $ Just t
        _ -> pure Nothing

getModuleName :: (String -> String) -> Doc String
getModuleName nameStyler = do
    single <- getSingleTopLevel
    pure $ maybe "QuickType" (fst >>> nameStyler) single

getForSingleOrMultipleTopLevels :: forall a. a -> a -> Doc a
getForSingleOrMultipleTopLevels forSingle forMultiple = do
    single <- getSingleTopLevel
    pure $ maybe forMultiple (const forSingle) single

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List IRUnionRep)
getUnions = do
    unsorted <- M.keys <$> getUnionNames
    sortByKeyM lookupUnionName unsorted

getUnionNames :: Doc (Map IRUnionRep String)
getUnionNames = Doc (asks _.unionNames)

getTopLevelNames :: Doc (Map String String)
getTopLevelNames = Doc (asks _.topLevelNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = do
    unsorted <- classesInGraph <$> getGraph
    sortByKeyM (\t -> lookupClassName (fst t)) unsorted

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: IRUnionRep -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

lookupTopLevelName :: String -> Doc String
lookupTopLevelName n = do
    topLevelNames <- getTopLevelNames
    pure $ lookupName n topLevelNames

forEachTopLevel_ :: (String -> IRType -> Doc Unit) -> Doc Unit
forEachTopLevel_ f = do
    topLevels <- getTopLevels
    for_ (M.toUnfoldable topLevels :: List _) \(Tuple topLevelNameGiven topLevelType) -> do
        topLevelName <- lookupTopLevelName topLevelNameGiven
        f topLevelName topLevelType

forEachClass_ :: (String -> Map String IRType -> Doc Unit) -> Doc Unit
forEachClass_ f = do
    classes <- getClasses
    for_ classes \(Tuple i (IRClassData { properties })) -> do
        className <- lookupClassName i
        f className properties

forEachUnion_ :: (String -> Set IRType -> Doc Unit) -> Doc Unit
forEachUnion_ f = do
    unions <- getUnions
    for_ unions \ur -> do
        let allTypes = unionToSet ur
        unionName <- lookupUnionName ur
        f unionName allTypes

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = String.times "    " indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a

combineNames :: Named (Set String) -> String
combineNames names =
    let s = namedValue names
    in case L.fromFoldable s of
    L.Nil -> "NONAME"
    name : L.Nil -> name
    firstName : rest ->
        let a = String.toCharArray firstName
            { p, s } = L.foldl prefixSuffixFolder { p: a, s: A.reverse a } rest
            prefix = if A.length p > 2 then p else []
            suffix = if A.length s > 2 then A.reverse s else []
            name = String.fromCharArray $ A.concat [prefix, suffix]
        in
            if String.length name > 2 then
                name
            else
                firstName

commonPrefix :: Array Char -> Array Char -> Array Char
commonPrefix a b =
    let l = A.length $ A.takeWhile id $ A.zipWith eq a b
    in A.take l a

prefixSuffixFolder :: { p :: Array Char, s :: Array Char } -> String -> { p :: Array Char, s :: Array Char }
prefixSuffixFolder { p, s } x =
    let a = String.toCharArray x
        newP = commonPrefix p a
        newS = commonPrefix s (A.reverse a)
    in { p: newP, s: newS }

module Doc
    ( Doc
    , Renderer
    , Transforms
    , Namer
    , getTopLevels
    , getSingleTopLevel
    , getModuleName
    , getForSingleOrMultipleTopLevels
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , getTopLevelNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , lookupTopLevelName
    , forEachTopLevel_
    , forEachClass_
    , forEachUnion_
    , combineNames
    , NamingResult
    , transformNames
    , transformPropertyNames
    , simpleNamer
    , noForbidNamer
    , forbidNamer
    , unionNameIntercalated
    , unionIsNotSimpleNullable
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Array as A
import Data.Foldable (for_, any, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, maybe, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.String.Util (times) as String
import Data.Tuple (Tuple(..), fst, snd)
import Utils (sortByKeyM)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type NamingResult = { name :: String, forbid :: Array String }
type Namer a = a -> Maybe String -> NamingResult

type Transforms =
    { nameForClass :: Namer IRClassData
    , nextName :: String -> String
    , forbiddenNames :: Array String
    , topLevelName :: Namer String
    , unions :: Maybe
        { predicate :: IRUnionRep -> Boolean
        , properName :: Namer (Named (Set String))
        , nameFromTypes :: Namer (Array String)
        }
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map IRUnionRep String
    , topLevelNames :: Map String String
    , unions :: Array IRUnionRep -- FIXME: we do we even keep this?
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph@(IRGraph { toplevels }) =
    let topLevelTuples = map (\n -> Tuple n n) $ M.keys toplevels
        forbiddenFromStart = S.fromFoldable t.forbiddenNames
        { names: topLevelNames, forbidden: forbiddenAfterTopLevels } = transformNames t.topLevelName t.nextName forbiddenFromStart topLevelTuples
        classes = classesInGraph graph
        { names: classNames, forbidden: forbiddenAfterClasses } = transformNames t.nameForClass t.nextName forbiddenAfterTopLevels classes
        { unions, unionNames } = doUnions classNames forbiddenAfterClasses
    in
        evalRWS w { graph, classNames, unionNames, topLevelNames, unions } { indent: 0 } # snd
    where
        doUnions :: Map Int String -> Set String -> { unions :: Array IRUnionRep, unionNames :: Map IRUnionRep String }
        doUnions classNames forbidden = case t.unions of
            Nothing -> { unions: [], unionNames: M.empty }
            Just { predicate, properName, nameFromTypes } ->
                let unions = A.fromFoldable $ filterTypes (unionPredicate predicate) graph
                    unionNames = (transformNames (unionNamer nameFromTypes properName classNames) t.nextName forbidden $ L.fromFoldable $ map (\s -> Tuple s s) unions).names
                in
                    { unions, unionNames }

        unionPredicate :: (IRUnionRep -> Boolean) -> IRType -> Maybe IRUnionRep
        unionPredicate p (IRUnion ur) = if p ur then Just ur else Nothing
        unionPredicate _ _ = Nothing

        unionNamer :: Namer (Array String) -> Namer (Named (Set String)) -> Map Int String -> Namer IRUnionRep
        unionNamer nameFromTypes properName classNames union@(IRUnionRep { names }) =
            if namedValue names == S.empty then
                let typeStrings = map (typeNameForUnion graph classNames) $ A.sort $ A.fromFoldable $ unionToSet union
                in
                    nameFromTypes typeStrings
            else
                properName names

transformNames :: forall a b. Ord a => Ord b => Namer b -> (String -> String) -> Set String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
transformNames legalize otherize illegalNames names =
    process S.empty illegalNames M.empty names
    where
        makeName :: b -> NamingResult -> Set String -> Set String -> NamingResult
        makeName name result@{ name: tryName, forbid } forbiddenInScope forbiddenForAll =
            if S.member tryName forbiddenInScope || any (\x -> S.member x forbiddenForAll) forbid then
                makeName name (legalize name (Just $ otherize tryName)) forbiddenInScope forbiddenForAll
            else
                result
        process :: Set String -> Set String -> Map a String -> List (Tuple a b) -> { names :: Map a String, forbidden :: Set String }
        process forbiddenInScope forbiddenForAll mapSoFar l =
            case l of
            L.Nil -> { names: mapSoFar, forbidden: forbiddenForAll }
            (Tuple identifier inputs) : rest ->
                let { name, forbid } = makeName inputs (legalize inputs Nothing) forbiddenInScope forbiddenForAll
                    newForbiddenInScope = S.insert name forbiddenInScope
                    newForbiddenForAll = S.union (S.fromFoldable forbid) forbiddenForAll
                    newMap = M.insert identifier name mapSoFar
                in
                    process newForbiddenInScope newForbiddenForAll newMap rest

transformPropertyNames :: Namer String -> (String -> String) -> Array String -> Map String IRType -> Map String String
transformPropertyNames legalize otherize illegalNamesArray properties =
    let illegalNames = S.fromFoldable illegalNamesArray
    in
        _.names $ transformNames legalize otherize illegalNames $ map (\n -> Tuple n n) $ M.keys properties

forbidNamer :: forall a. Ord a => (a -> String) -> (String -> Array String) -> Namer a
forbidNamer namer forbidder _ (Just name) = { name, forbid: forbidder name }
forbidNamer namer forbidder x Nothing =
    let name = namer x
    in { name, forbid: forbidder name }

simpleNamer :: forall a. Ord a => (a -> String) -> Namer a
simpleNamer namer = forbidNamer namer A.singleton

noForbidNamer :: forall a. Ord a => (a -> String) -> Namer a
noForbidNamer namer = forbidNamer namer (const [])

typeNameForUnion :: IRGraph -> Map Int String -> IRType -> String
typeNameForUnion graph classNames = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph classNames a <> "_array"
    IRClass i -> lookupName i classNames
    IRMap t -> typeNameForUnion graph classNames t <> "_map"
    IRUnion _ -> "union"

unionNameIntercalated :: (String -> String) -> String -> Array String -> String
unionNameIntercalated nameStyle orString names =
    names
    <#> nameStyle
    # intercalate orString

unionIsNotSimpleNullable :: IRUnionRep -> Boolean
unionIsNotSimpleNullable ur = isNothing $ nullableFromSet $ unionToSet ur

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  classNames <- getClassNames
  pure $ typeNameForUnion g classNames typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevels :: Doc (Map String IRType)
getTopLevels = do
    IRGraph { toplevels } <- getGraph
    pure toplevels

getSingleTopLevel :: Doc (Maybe (Tuple String IRType))
getSingleTopLevel = do
    topLevels <- getTopLevels
    case M.toUnfoldable topLevels :: List _ of
        t : L.Nil -> pure $ Just t
        _ -> pure Nothing

getModuleName :: (String -> String) -> Doc String
getModuleName nameStyler = do
    single <- getSingleTopLevel
    pure $ maybe "QuickType" (fst >>> nameStyler) single

getForSingleOrMultipleTopLevels :: forall a. a -> a -> Doc a
getForSingleOrMultipleTopLevels forSingle forMultiple = do
    single <- getSingleTopLevel
    pure $ maybe forMultiple (const forSingle) single

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List IRUnionRep)
getUnions = do
    unsorted <- M.keys <$> getUnionNames
    sortByKeyM lookupUnionName unsorted

getUnionNames :: Doc (Map IRUnionRep String)
getUnionNames = Doc (asks _.unionNames)

getTopLevelNames :: Doc (Map String String)
getTopLevelNames = Doc (asks _.topLevelNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = do
    unsorted <- classesInGraph <$> getGraph
    sortByKeyM (\t -> lookupClassName (fst t)) unsorted

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: IRUnionRep -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

lookupTopLevelName :: String -> Doc String
lookupTopLevelName n = do
    topLevelNames <- getTopLevelNames
    pure $ lookupName n topLevelNames

forEachTopLevel_ :: (String -> IRType -> Doc Unit) -> Doc Unit
forEachTopLevel_ f = do
    topLevels <- getTopLevels
    for_ (M.toUnfoldable topLevels :: List _) \(Tuple topLevelNameGiven topLevelType) -> do
        topLevelName <- lookupTopLevelName topLevelNameGiven
        f topLevelName topLevelType

forEachClass_ :: (String -> Map String IRType -> Doc Unit) -> Doc Unit
forEachClass_ f = do
    classes <- getClasses
    for_ classes \(Tuple i (IRClassData { properties })) -> do
        className <- lookupClassName i
        f className properties

forEachUnion_ :: (String -> Set IRType -> Doc Unit) -> Doc Unit
forEachUnion_ f = do
    unions <- getUnions
    for_ unions \ur -> do
        let allTypes = unionToSet ur
        unionName <- lookupUnionName ur
        f unionName allTypes

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = String.times "    " indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a

combineNames :: Named (Set String) -> String
combineNames names =
    let s = namedValue names
    in case L.fromFoldable s of
    L.Nil -> "NONAME"
    name : L.Nil -> name
    firstName : rest ->
        let a = String.toCharArray firstName
            { p, s } = L.foldl prefixSuffixFolder { p: a, s: A.reverse a } rest
            prefix = if A.length p > 2 then p else []
            suffix = if A.length s > 2 then A.reverse s else []
            name = String.fromCharArray $ A.concat [prefix, suffix]
        in
            if String.length name > 2 then
                name
            else
                firstName

commonPrefix :: Array Char -> Array Char -> Array Char
commonPrefix a b =
    let l = A.length $ A.takeWhile id $ A.zipWith eq a b
    in A.take l a

prefixSuffixFolder :: { p :: Array Char, s :: Array Char } -> String -> { p :: Array Char, s :: Array Char }
prefixSuffixFolder { p, s } x =
    let a = String.toCharArray x
        newP = commonPrefix p a
        newS = commonPrefix s (A.reverse a)
    in { p: newP, s: newS }