implemented a Functor instance for

implemented a Functor instance for

module AST where

import Prelude
import Control.Monad.State (State, evalState, runState, get, put)
import Data.Bifunctor (bimap, rmap)
import Data.Foldable (intercalate)
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
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

derive instance eqOp :: Eq Op

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

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

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

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

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

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

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

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 TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

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'

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

-- TODO: May I join `Type` and `AD`?
data Type
    = TypVar TVar -- Typ Variables x.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError
    | UnknownType

data AD
    = TList Type
    | TTuple (List Type)
    | TTypeCons String (List Type)

-- 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 (DataCons Type))

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)

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

data Associativity
  = LEFTASSOC
  | RIGHTASSOC
  | ASSOC

derive instance eqAssociativity :: Eq Associativity

data DataCons param
  = PrefixCons String Int (List param)
  | InfixCons String Associativity Int param param

instance functorDataCons :: Functor DataCons where
  map f (PrefixCons s i ps) = PrefixCons s i (map f ps)
  map f (InfixCons s a i p1 p2) = InfixCons s a i (f p1) (f p2)

instance showDataCons :: (Show param) => Show (DataCons param) where
  show (PrefixCons n _ ts)
    = n <> " " <> intercalate " " (map show ts)
  show (InfixCons o ASSOC _ l r)
    = show l <> " " <> o <> " " <> show r
  show (InfixCons o RIGHTASSOC _ l r)
    = show l <> " " <> o <> " (" <> show r <> ")"
  show (InfixCons o LEFTASSOC _ l r)
    = "(" <> show l <> ") " <> o <> " " <> show r

derive instance eqDataCons :: (Eq params) => Eq (DataCons params)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable 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))

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)

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

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

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

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

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

instance 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 (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"
  show (TTypeCons name ps) = "(TTypeCons " <> show name <> " " <> intercalate " " (map show ps) <> ")"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (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

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

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 (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts
prettyPrintType (AD (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 (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)
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
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

derive instance eqOp :: Eq Op

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

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

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

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

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

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

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

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 TypeTree = Tree Atom (Binding MType) (Tuple Op MType) MType

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'

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

-- TODO: May I join `Type` and `AD`?
data Type
    = TypVar TVar -- Typ Variables x.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError
    | UnknownType

data AD
    = TList Type
    | TTuple (List Type)
    | TTypeCons String (List Type)

-- 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 (DataCons Type))

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)

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

data Associativity
  = LEFTASSOC
  | RIGHTASSOC
  | ASSOC

derive instance eqAssociativity :: Eq Associativity

data DataCons param
  = PrefixCons String Int (List param)
  | InfixCons String Associativity Int param param

instance showDataCons :: (Show param) => Show (DataCons param) where
  show (PrefixCons n _ ts)
    = n <> " " <> intercalate " " (map show ts)
  show (InfixCons o ASSOC _ l r)
    = show l <> " " <> o <> " " <> show r
  show (InfixCons o RIGHTASSOC _ l r)
    = show l <> " " <> o <> " (" <> show r <> ")"
  show (InfixCons o LEFTASSOC _ l r)
    = "(" <> show l <> ") " <> o <> " " <> show r

derive instance eqDataCons :: (Eq params) => Eq (DataCons params)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable 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))

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)

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

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

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

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

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

instance 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 (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"
  show (TTypeCons name ps) = "(TTypeCons " <> show name <> " " <> intercalate " " (map show ps) <> ")"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (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

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

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 (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts
prettyPrintType (AD (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 (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


Export resume

Export resume

module Run
  ( Run(..)
  , run
  , runBase
  , runBaseWithCont
  , runWithBase
  , runWithEffect
  , interpretWithBase
  , interpretWithEffect
  , foldWithEffect
  , liftEffect
  , liftBase
  , peel
  , resume
  , send
  , expand
  , BaseEff
  , BaseAff
  , module Data.Functor.Variant
  , module Exports
  ) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Free (Free, liftF, runFree, foldFree, resume')
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Data.Either (Either(..))
import Data.Functor.Variant (VariantF, FProxy(..), inj, on, case_, default)
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (SProxy(..)) as Exports
import Data.Symbol (SProxy(..), class IsSymbol)
import Data.Tuple (Tuple, uncurry)
import Partial.Unsafe (unsafeCrashWith)
import Type.Equality (class TypeEquals)
import Unsafe.Coerce (unsafeCoerce)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad. The `Run` Monad is an alternative to Monad Transformers.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , base ∷ BaseEff (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBase
-- |     # void
-- | ````
newtype Run (r ∷ # Type) a = Run (Free (VariantF r) a)

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `SProxy` slot.
liftEffect
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (FProxy f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ SProxy sym
  → f a
  → Run r2 a
liftEffect p = Run <<< liftF <<< inj p

-- | Lifts a base effect into the `Run` Monad (eg. `Eff`, `Aff`, or `IO`).
liftBase
  ∷ ∀ r f a
  . Functor f
  ⇒ f a
  → Run (base ∷ FProxy f | r) a
liftBase = Run <<< liftF <<< inj (SProxy ∷ SProxy "base")

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (VariantF r (Run r a)) a
peel = resume Left Right

-- | Eliminator for the `Run` data type.
resume
  ∷ ∀ a b r
  . (VariantF r (Run r a) → b)
  → (a → b)
  → Run r a
  → b
resume k1 k2 = resume' (\x f → k1 (Run <<< f <$> x)) k2 <<< unwrap

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . VariantF r a
  → Run r a
send = Run <<< liftF

-- | Casts some set of effects to a wider set of effects via a left-biased
-- | union. For example, you could take a closed effect and unify it with
-- | a superset of effects because we know the additional effects never
-- | occur.
expand
  ∷ ∀ r1 r2 rx a
  . Union r1 rx r2
  ⇒ Run r1 a
  → Run r2 a
expand = unsafeCoerce

-- | Extracts the value from a fully interpreted program.
run ∷ ∀ a. Run () a → a
run = unwrap >>> runFree \_ → unsafeCrashWith "Control.Monad.Run: the impossible happened"

unBase ∷ ∀ f. VariantF (base ∷ FProxy f) ~> f
unBase = case_ # on (SProxy ∷ SProxy "base") id

-- | Extracts the value from a program with only base effects. This assumes
-- | stack safety under Monadic recursion.
runBase
  ∷ ∀ f a
  . Monad f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBase = loop
  where
  loop ∷ Run (base ∷ FProxy f) a → f a
  loop = resume (\b → loop =<< unBase b) pure

-- | Extracts the value from a program with only base effects using `MonadRec`
-- | to preserve stack safety.
runBaseRec
  ∷ ∀ f a
  . MonadRec f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBaseRec = foldFree unBase <<< unwrap

-- | Interprets the base effect into some Monad `m` via continuation passing.
runBaseWithCont
  ∷ ∀ f m a b
  . Monad m
  ⇒ (f (m b) → m b)
  → (a → m b)
  → Run (base ∷ FProxy f) a
  → m b
runBaseWithCont k1 k2 = loop
  where
  loop ∷ Run (base ∷ FProxy f) a → m b
  loop = resume (\b -> k1 (unBase (loop <$> b))) k2

-- | Interprets an effect functor into the base effect via a natural
-- | transformation, eliminating the label.
interpretWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f ~> m)
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
interpretWithBase = runWithBase

-- | The same as `interpretWithBase`, but with a less restrictive type for the
-- | interpreter.
runWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f (Run r1 a) → m (Run r1 a))
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
runWithBase p k = runWithEffect p (liftBase <<< k)

-- | Interprets an effect functor in terms of other `Run` effects, eliminating
-- | the label.
interpretWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f ~> Run r2)
  → Run r1 a
  → Run r2 a
interpretWithEffect = runWithEffect

-- | The same as `interpretWithEffect` but with a less restrictive type for the
-- | interpreter.
runWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f (Run r1 a) → Run r2 (Run r1 a))
  → Run r1 a
  → Run r2 a
runWithEffect p k = loop
  where
  handle ∷ VariantF r1 (Run r1 a) → Run r2 (Run r1 a)
  handle = on p k send

  loop ∷ Run r1 a → Run r2 a
  loop = resume (\b → handle b >>= loop) pure

-- | Interprets an effect in terms of other `Run` effects with an internal
-- | accumulator.
foldWithEffect
  ∷ ∀ sym f r1 r2 s a b
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (s → f (Run r1 a) → Run r2 (Tuple s (Run r1 a)))
  → Run r2 s
  → Run r1 a
  → Run r2 a
foldWithEffect p k init r = init >>= flip loop r
  where
  handle ∷ s → VariantF r1 (Run r1 a) → Run r2 a
  handle acc =
    on p
      (k acc >=> uncurry loop)
      (send >=> loop acc)

  loop ∷ s → Run r1 a → Run r2 a
  loop acc = resume (handle acc) pure

data R (r ∷ # Type)

-- Type synonym for using `Eff` as a base effect.
type BaseEff eff = FProxy (Eff eff)

-- Type synonym for using `Aff` as a base effect.
type BaseAff eff = FProxy (Aff eff)

instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

instance monadEffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadEff eff m) ⇒ MonadEff eff (Run rs) where
  liftEff = coerceR <<< liftBase <<< liftEff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce

instance monadAffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadAff eff m) ⇒ MonadAff eff (Run rs) where
  liftAff = coerceR <<< liftBase <<< liftAff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce

module Run
  ( Run(..)
  , run
  , runBase
  , runBaseWithCont
  , runWithBase
  , runWithEffect
  , interpretWithBase
  , interpretWithEffect
  , foldWithEffect
  , liftEffect
  , liftBase
  , peel
  , send
  , expand
  , BaseEff
  , BaseAff
  , module Data.Functor.Variant
  , module Exports
  ) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Free (Free, liftF, runFree, foldFree, resume')
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Data.Either (Either(..))
import Data.Functor.Variant (VariantF, FProxy(..), inj, on, case_, default)
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (SProxy(..)) as Exports
import Data.Symbol (SProxy(..), class IsSymbol)
import Data.Tuple (Tuple, uncurry)
import Partial.Unsafe (unsafeCrashWith)
import Type.Equality (class TypeEquals)
import Unsafe.Coerce (unsafeCoerce)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad. The `Run` Monad is an alternative to Monad Transformers.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , base ∷ BaseEff (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBase
-- |     # void
-- | ````
newtype Run (r ∷ # Type) a = Run (Free (VariantF r) a)

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `SProxy` slot.
liftEffect
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (FProxy f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ SProxy sym
  → f a
  → Run r2 a
liftEffect p = Run <<< liftF <<< inj p

-- | Lifts a base effect into the `Run` Monad (eg. `Eff`, `Aff`, or `IO`).
liftBase
  ∷ ∀ r f a
  . Functor f
  ⇒ f a
  → Run (base ∷ FProxy f | r) a
liftBase = Run <<< liftF <<< inj (SProxy ∷ SProxy "base")

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (VariantF r (Run r a)) a
peel = resume Left Right

resume
  ∷ ∀ a b r
  . (VariantF r (Run r a) → b)
  → (a → b)
  → Run r a
  → b
resume k1 k2 = resume' (\x f → k1 (Run <<< f <$> x)) k2 <<< unwrap

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . VariantF r a
  → Run r a
send = Run <<< liftF

-- | Casts some set of effects to a wider set of effects via a left-biased
-- | union. For example, you could take a closed effect and unify it with
-- | a superset of effects because we know the additional effects never
-- | occur.
expand
  ∷ ∀ r1 r2 rx a
  . Union r1 rx r2
  ⇒ Run r1 a
  → Run r2 a
expand = unsafeCoerce

-- | Extracts the value from a fully interpreted program.
run ∷ ∀ a. Run () a → a
run = unwrap >>> runFree \_ → unsafeCrashWith "Control.Monad.Run: the impossible happened"

unBase ∷ ∀ f. VariantF (base ∷ FProxy f) ~> f
unBase = case_ # on (SProxy ∷ SProxy "base") id

-- | Extracts the value from a program with only base effects. This assumes
-- | stack safety under Monadic recursion.
runBase
  ∷ ∀ f a
  . Monad f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBase = loop
  where
  loop ∷ Run (base ∷ FProxy f) a → f a
  loop = resume (\b → loop =<< unBase b) pure

-- | Extracts the value from a program with only base effects using `MonadRec`
-- | to preserve stack safety.
runBaseRec
  ∷ ∀ f a
  . MonadRec f
  ⇒ Run (base ∷ FProxy f) a
  → f a
runBaseRec = foldFree unBase <<< unwrap

-- | Interprets the base effect into some Monad `m` via continuation passing.
runBaseWithCont
  ∷ ∀ f m a b
  . Monad m
  ⇒ (f (m b) → m b)
  → (a → m b)
  → Run (base ∷ FProxy f) a
  → m b
runBaseWithCont k1 k2 = loop
  where
  loop ∷ Run (base ∷ FProxy f) a → m b
  loop = resume (\b -> k1 (unBase (loop <$> b))) k2

-- | Interprets an effect functor into the base effect via a natural
-- | transformation, eliminating the label.
interpretWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f ~> m)
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
interpretWithBase = runWithBase

-- | The same as `interpretWithBase`, but with a less restrictive type for the
-- | interpreter.
runWithBase
  ∷ ∀ sym f m r1 r2 a
  . RowCons sym (FProxy f) (base ∷ FProxy m | r2) r1
  ⇒ IsSymbol sym
  ⇒ Functor m
  ⇒ SProxy sym
  → (f (Run r1 a) → m (Run r1 a))
  → Run r1 a
  → Run (base ∷ FProxy m | r2) a
runWithBase p k = runWithEffect p (liftBase <<< k)

-- | Interprets an effect functor in terms of other `Run` effects, eliminating
-- | the label.
interpretWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f ~> Run r2)
  → Run r1 a
  → Run r2 a
interpretWithEffect = runWithEffect

-- | The same as `interpretWithEffect` but with a less restrictive type for the
-- | interpreter.
runWithEffect
  ∷ ∀ sym f r1 r2 a
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (f (Run r1 a) → Run r2 (Run r1 a))
  → Run r1 a
  → Run r2 a
runWithEffect p k = loop
  where
  handle ∷ VariantF r1 (Run r1 a) → Run r2 (Run r1 a)
  handle = on p k send

  loop ∷ Run r1 a → Run r2 a
  loop = resume (\b → handle b >>= loop) pure

-- | Interprets an effect in terms of other `Run` effects with an internal
-- | accumulator.
foldWithEffect
  ∷ ∀ sym f r1 r2 s a b
  . RowCons sym (FProxy f) r2 r1
  ⇒ IsSymbol sym
  ⇒ SProxy sym
  → (s → f (Run r1 a) → Run r2 (Tuple s (Run r1 a)))
  → Run r2 s
  → Run r1 a
  → Run r2 a
foldWithEffect p k init r = init >>= flip loop r
  where
  handle ∷ s → VariantF r1 (Run r1 a) → Run r2 a
  handle acc =
    on p
      (k acc >=> uncurry loop)
      (send >=> loop acc)

  loop ∷ s → Run r1 a → Run r2 a
  loop acc = resume (handle acc) pure

data R (r ∷ # Type)

-- Type synonym for using `Eff` as a base effect.
type BaseEff eff = FProxy (Eff eff)

-- Type synonym for using `Aff` as a base effect.
type BaseAff eff = FProxy (Aff eff)

instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

instance monadEffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadEff eff m) ⇒ MonadEff eff (Run rs) where
  liftEff = coerceR <<< liftBase <<< liftEff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce

instance monadAffRun ∷ (TypeEquals (R rs) (R (base ∷ FProxy m | r)), MonadAff eff m) ⇒ MonadAff eff (Run rs) where
  liftAff = coerceR <<< liftBase <<< liftAff
    where
    coerceR ∷ Run (base ∷ FProxy m | r) ~> Run rs
    coerceR = unsafeCoerce


Fixed palette colors

Fixed palette colors

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Function
import Data.Int
import Data.List as L
import Data.Int.Bits
import Data.Foldable
import Data.Functor
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import MemSection as M
import Debug

foreign import setCanvasPixelColor :: forall e. Int -> Palette -> Int -> Int
                              -> Eff (canvas :: Canvas | e) Unit

foreign import setScreen :: forall e. Context2D
                         -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

--NOTE: could be redundant after scrBuf is gone
resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = return unit

cleanGpu :: Gpu
cleanGpu =
  { mTimer : modeDuration VBlank - 16
  , dispOn : true
  , bgOn : true
  , bgMap1 : false
  , bgSet1 : true
  , vblFinish : true
  , currLine : pixHeight + 10 - 1
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , vblIntrr : false
  , palette : M.getNew 16 0
  , mode : VBlank
  , tiles : Tiles $ M.getNew (384*64) 0
  , regs : M.getNew 0x40 0
  , vram : M.getNew 8192 0
  , oam : M.getNew 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas, ma :: MemAccess | e) Gpu
gpuStep _ gpu@{dispOn = false} = return gpu

gpuStep opTime gpu@{mTimer,mode,currLine,currPos,vblFinish} =
  map hblCurrLineEarlyReset eGpu'
 where
  mTimer' = mTimer + opTime

  eGpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      HBlank ->
        let doOnLastLine gp = if currLine /= pixHeight - 1 then return gp
              else do
                {--traceA "draw!"--}
                setScreen =<< getCanvas

                return $ gp { mode = VBlank
                            , vblIntrr = true
                            }
         in doOnLastLine $ gpu { mTimer = mTimer' - modeDuration HBlank
                             , currLine = currLine + 1
                             , currPos = currPos + bytesWidth
                             , mode = OamScan
                             }

      VBlank -> do
        let setOnLastLine =
              if vblFinish
                -- 10 increments after last line of 143
                then _ { vblFinish = false
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = mTimer' - modeDuration VBlank , currLine = currLine + 1 }
      OamScan -> return gpu { mTimer = mTimer' - modeDuration OamScan, mode = VramScan }
      VramScan ->
        let renderOrNot = if gpu.dispOn && gpu.bgOn then renderLine else return
        in renderOrNot gpu { mTimer = mTimer' - modeDuration VramScan, mode = HBlank }

hblCurrLineEarlyReset :: Gpu -> Gpu
hblCurrLineEarlyReset gpu@{mTimer = mTimer', currLine, mode} =
  if mode == VBlank && mTimer' >= 4 && currLine == pixHeight + 10 - 1
    then gpu { currLine = 0, vblFinish = true }
    else gpu

--Change condition of renderOrNot once object rendering is added
--And perhaps rename the current renderLine to renderBG and have renderLine
--be what calls renderBG and renderFG
{--renderLine :: Gpu -> forall e. Eff (canvas :: Canvas | e) Gpu--}
renderLine :: forall e. Gpu -> Eff (ma :: MemAccess, canvas :: Canvas | e) Gpu
renderLine gpu = do
  tileIx <- getTileIx gpu tileIxAddr
  foldRes <- L.foldM updateCanvas
                     { tho:tileHorizOff
                     , mho:memHorizOff, tix:tileIx }
                     (0 L... (pixWidth-1))
  return gpu
 where
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  setCanvasPixelColor' = mkFn4 setCanvasPixelColor

  updateCanvas {tho,mho,tix} i = do
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    let tho' = if lastTileRowPixel
          then 0
          else tho + 1
        mho' = if lastTileRowPixel
          then 31 .&. (1 + mho)
          else mho
    tix' <- if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else return tix

    --NOTE trace error, if invalid color ix
    colorIx <- getTilePixel tho tileVertOff tix gpu.tiles

    runFn4 setCanvasPixelColor' colorIx pal (i*4) gpu.currLine
    return $ {tho:tho',mho:mho',tix:tix'}
   where
    lastTileRowPixel = tho == 7
    pal = gpu.palette

getTileIx :: forall e. Gpu -> I16 -> Eff (ma :: MemAccess | e) I8
getTileIx { vram, bgSet1 } addr = do
  tix <- vram M.!! addr
  return $ if (not bgSet1) then tix + 256 else tix

gpuRd8 :: forall e. I16 -> Gpu -> Eff (ma :: MemAccess | e) I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> return $ getCtrlFlags gpu
  0xFF42 -> return gpu.yScroll
  0xFF43 -> return gpu.xScroll
  0xFF44 -> return gpu.currLine
  0xFF47 -> return $ -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs M.!! (addr - 0xFF40)

gpuWr8 :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Gpu
gpuWr8 i8 addr gpu = do
  setRegs
  case addr of
    0xFF40 -> return $ setCtrlFlags i8 gpu
    0xFF42 -> return gpu { yScroll = i8 }
    0xFF43 -> return gpu { xScroll = i8 }
    0xFF44 -> return gpu { currLine = i8 }
    0xFF47 -> setPalette
    otherwise -> return gpu
 where
  setRegs = M.replace i8 (addr - 0xFF40) gpu.regs
  setPalette = gpu <$ traverse_ stPl (0 A... 3)
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> setColor {a:255,r:255,g:255,b:255} i gpu.palette
    1 -> setColor {a:255,r:192,g:192,b:192} i gpu.palette
    2 -> setColor {a:255,r:96 ,g:96 ,b:96} i gpu.palette
    3 -> setColor {a:255,r:0  ,g:0  ,b:0} i gpu.palette
    otherwise -> return unit -- NOTE log this

{--getColor :: forall e. Int -> Palette--}
         {---> Eff (ma :: MemAccess | e) {a :: Int, r :: Int, g :: Int, b :: Int}--}
{--getColor cIx pal = do--}
  {--a <- M.zubi pal i--}
  {--r <- M.zubi pal (i + 1)--}
  {--g <- M.zubi pal (i + 2)--}
  {--b <- M.zubi pal (i + 3)--}
  {--return {a,r,g,b}--}
 {--where i = cIx*4--}

setColor :: forall e. {a :: Int, r :: Int, g :: Int, b :: Int} -> Int -> Palette
         -> Eff (ma :: MemAccess | e) Unit
setColor {a,r,g,b} cIx pal = do
  M.replace a i pal
  M.replace r (i + 1) pal
  M.replace g (i + 2) pal
  M.replace b (i + 3) pal
  return unit
 where i = cIx*4

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

setCtrlFlags :: I8 -> Gpu -> Gpu
setCtrlFlags ctrlFlags gpu = enableDisableOrNot gpu.dispOn dispOn'
  gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = dispOn'
    }
 where
  isFlagSet flag = (flag .&. ctrlFlags) /= 0
  dispOn' = isFlagSet 0x80

  enableDisableOrNot true false = disableGpu
  enableDisableOrNot false true = enableGpu
  enableDisableOrNot _ _ = id

disableGpu :: Gpu -> Gpu
disableGpu gpu = gpu
  { mTimer = 0
  , currLine = 0
  , mode = HBlank
  , vblFinish = false
  , dispOn = false
  }

enableGpu :: Gpu -> Gpu
enableGpu gpu = gpu
  { mTimer = 0
  , mode = OamScan
  , dispOn = true
  }

wrVRam :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Unit
wrVRam i8 addr gpu@{vram,tiles} = do
  vram' <- M.replace i8 addr' vram
  if (addr >= 0x8000 && addr < 0x9800)
    then vramWriteToTiles addr' vram' tiles
    else return unit
 where
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF
--2 tile maps from 0x9800 to 0x9FFF

vramWriteToTiles :: forall e. I16 -> MemSection -> Tiles -> Eff (ma :: MemAccess | e) Unit
vramWriteToTiles addr vram tiles =
  traverse_ updateColor (0 A... 7)
 where
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: forall e. Int -> Eff (ma :: MemAccess | e) Unit
  updateColor x = do
    highColors <- vram M.!! addr + 1
    lowColors <- vram M.!! addr
    let c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
         .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)
    setTilePixel c x y tileIx tiles
   where
    shiftMask = 1 `shl` (7-x)

--NOTE Add a check that tile index is valid (0<=i<384)

getTilePixel :: forall e. Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Int
getTilePixel x y tileIx (Tiles ms) = ms M.!! (tileIx*64) + (y*8) + x

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: forall e. Int -> Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Unit
setTilePixel c x y tileIx (Tiles ms) = void
  $ M.replace c ((tileIx*64) + (y*8) + x) ms

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Function
import Data.Int
import Data.List as L
import Data.Int.Bits
import Data.Foldable
import Data.Functor
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import MemSection as M
import Debug

foreign import setCanvasPixelColor :: forall e. Int -> Palette -> Int -> Int
                              -> Eff (canvas :: Canvas | e) Unit

foreign import setScreen :: forall e. Context2D
                         -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

--NOTE: could be redundant after scrBuf is gone
resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = return unit

cleanGpu :: Gpu
cleanGpu =
  { mTimer : modeDuration VBlank - 16
  , dispOn : true
  , bgOn : true
  , bgMap1 : false
  , bgSet1 : true
  , vblFinish : true
  , currLine : pixHeight + 10 - 1
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , vblIntrr : false
  , palette : M.getNew 16 0
  , mode : VBlank
  , tiles : Tiles $ M.getNew (384*64) 0
  , regs : M.getNew 0x40 0
  , vram : M.getNew 8192 0
  , oam : M.getNew 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas, ma :: MemAccess | e) Gpu
gpuStep _ gpu@{dispOn = false} = return gpu

gpuStep opTime gpu@{mTimer,mode,currLine,currPos,vblFinish} =
  map hblCurrLineEarlyReset eGpu'
 where
  mTimer' = mTimer + opTime

  eGpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      HBlank ->
        let doOnLastLine gp = if currLine /= pixHeight - 1 then return gp
              else do
                {--traceA "draw!"--}
                setScreen =<< getCanvas

                return $ gp { mode = VBlank
                            , vblIntrr = true
                            }
         in doOnLastLine $ gpu { mTimer = mTimer' - modeDuration HBlank
                             , currLine = currLine + 1
                             , currPos = currPos + bytesWidth
                             , mode = OamScan
                             }

      VBlank -> do
        let setOnLastLine =
              if vblFinish
                -- 10 increments after last line of 143
                then _ { vblFinish = false
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = mTimer' - modeDuration VBlank , currLine = currLine + 1 }
      OamScan -> return gpu { mTimer = mTimer' - modeDuration OamScan, mode = VramScan }
      VramScan ->
        let renderOrNot = if gpu.dispOn && gpu.bgOn then renderLine else return
        in renderOrNot gpu { mTimer = mTimer' - modeDuration VramScan, mode = HBlank }

hblCurrLineEarlyReset :: Gpu -> Gpu
hblCurrLineEarlyReset gpu@{mTimer = mTimer', currLine, mode} =
  if mode == VBlank && mTimer' >= 4 && currLine == pixHeight + 10 - 1
    then gpu { currLine = 0, vblFinish = true }
    else gpu

--Change condition of renderOrNot once object rendering is added
--And perhaps rename the current renderLine to renderBG and have renderLine
--be what calls renderBG and renderFG
{--renderLine :: Gpu -> forall e. Eff (canvas :: Canvas | e) Gpu--}
renderLine :: forall e. Gpu -> Eff (ma :: MemAccess, canvas :: Canvas | e) Gpu
renderLine gpu = do
  tileIx <- getTileIx gpu tileIxAddr
  foldRes <- L.foldM updateCanvas
                     { tho:tileHorizOff
                     , mho:memHorizOff, tix:tileIx }
                     (0 L... (pixWidth-1))
  return gpu
 where
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  setCanvasPixelColor' = mkFn4 setCanvasPixelColor

  updateCanvas {tho,mho,tix} i = do
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    let tho' = if lastTileRowPixel
          then 0
          else tho + 1
        mho' = if lastTileRowPixel
          then 31 .&. (1 + mho)
          else mho
    tix' <- if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else return tix

    --NOTE trace error, if invalid color ix
    colorIx <- getTilePixel tho tileVertOff tix gpu.tiles

    runFn4 setCanvasPixelColor' colorIx pal (i*4) gpu.currLine
    return $ {tho:tho',mho:mho',tix:tix'}
   where
    lastTileRowPixel = tho == 7
    pal = gpu.palette

getTileIx :: forall e. Gpu -> I16 -> Eff (ma :: MemAccess | e) I8
getTileIx { vram, bgSet1 } addr = do
  tix <- vram M.!! addr
  return $ if (not bgSet1) then tix + 256 else tix

gpuRd8 :: forall e. I16 -> Gpu -> Eff (ma :: MemAccess | e) I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> return $ getCtrlFlags gpu
  0xFF42 -> return gpu.yScroll
  0xFF43 -> return gpu.xScroll
  0xFF44 -> return gpu.currLine
  0xFF47 -> return $ -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs M.!! (addr - 0xFF40)

gpuWr8 :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Gpu
gpuWr8 i8 addr gpu = do
  setRegs
  case addr of
    0xFF40 -> return $ setCtrlFlags i8 gpu
    0xFF42 -> return gpu { yScroll = i8 }
    0xFF43 -> return gpu { xScroll = i8 }
    0xFF44 -> return gpu { currLine = i8 }
    0xFF47 -> setPalette
    otherwise -> return gpu
 where
  setRegs = M.replace i8 (addr - 0xFF40) gpu.regs
  setPalette = gpu <$ traverse_ stPl (0 A... 3)
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> setColor {a:255,r:255,g:255,b:255} i gpu.palette
    1 -> setColor {a:192,r:192,g:192,b:255} i gpu.palette
    2 -> setColor {a:96 ,r:96 ,g:96 ,b:255} i gpu.palette
    3 -> setColor {a:0  ,r:0  ,g:0  ,b:255} i gpu.palette
    otherwise -> return unit -- NOTE log this

{--getColor :: forall e. Int -> Palette--}
         {---> Eff (ma :: MemAccess | e) {a :: Int, r :: Int, g :: Int, b :: Int}--}
{--getColor cIx pal = do--}
  {--a <- M.zubi pal i--}
  {--r <- M.zubi pal (i + 1)--}
  {--g <- M.zubi pal (i + 2)--}
  {--b <- M.zubi pal (i + 3)--}
  {--return {a,r,g,b}--}
 {--where i = cIx*4--}

setColor :: forall e. {a :: Int, r :: Int, g :: Int, b :: Int} -> Int -> Palette
         -> Eff (ma :: MemAccess | e) Unit
setColor {a,r,g,b} cIx pal = do
  M.replace a i pal
  M.replace r (i + 1) pal
  M.replace g (i + 2) pal
  M.replace b (i + 3) pal
  return unit
 where i = cIx*4

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

setCtrlFlags :: I8 -> Gpu -> Gpu
setCtrlFlags ctrlFlags gpu = enableDisableOrNot gpu.dispOn dispOn'
  gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = dispOn'
    }
 where
  isFlagSet flag = (flag .&. ctrlFlags) /= 0
  dispOn' = isFlagSet 0x80

  enableDisableOrNot true false = disableGpu
  enableDisableOrNot false true = enableGpu
  enableDisableOrNot _ _ = id

disableGpu :: Gpu -> Gpu
disableGpu gpu = gpu
  { mTimer = 0
  , currLine = 0
  , mode = HBlank
  , vblFinish = false
  , dispOn = false
  }

enableGpu :: Gpu -> Gpu
enableGpu gpu = gpu
  { mTimer = 0
  , mode = OamScan
  , dispOn = true
  }

wrVRam :: forall e. I8 -> I16 -> Gpu -> Eff (ma :: MemAccess | e) Unit
wrVRam i8 addr gpu@{vram,tiles} = do
  vram' <- M.replace i8 addr' vram
  if (addr >= 0x8000 && addr < 0x9800)
    then vramWriteToTiles addr' vram' tiles
    else return unit
 where
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF
--2 tile maps from 0x9800 to 0x9FFF

vramWriteToTiles :: forall e. I16 -> MemSection -> Tiles -> Eff (ma :: MemAccess | e) Unit
vramWriteToTiles addr vram tiles =
  traverse_ updateColor (0 A... 7)
 where
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: forall e. Int -> Eff (ma :: MemAccess | e) Unit
  updateColor x = do
    highColors <- vram M.!! addr + 1
    lowColors <- vram M.!! addr
    let c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
         .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)
    setTilePixel c x y tileIx tiles
   where
    shiftMask = 1 `shl` (7-x)

--NOTE Add a check that tile index is valid (0<=i<384)

getTilePixel :: forall e. Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Int
getTilePixel x y tileIx (Tiles ms) = ms M.!! (tileIx*64) + (y*8) + x

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: forall e. Int -> Int -> Int -> Int -> Tiles
             -> Eff (ma :: MemAccess | e) Unit
setTilePixel c x y tileIx (Tiles ms) = void
  $ M.replace c ((tileIx*64) + (y*8) + x) ms

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144