Move Milliseconds to Number from Int to prevent overflow.

module Data.Time where

import Prelude
  ( (*)
  , (+)
  , (++)
  , (-)
  , (/)
  , (/=)
  , (==)
  , DivisionRing
  , Eq
  , ModuloSemiring
  , Num
  , Ord
  , Ring
  , Semiring
  , Show
  , compare
  , show )

-- | An hour component from a time value. Should fall between 0 and 23
-- | inclusive.
newtype HourOfDay = HourOfDay Int

instance eqHourOfDay :: Eq HourOfDay where
  eq (HourOfDay x) (HourOfDay y) = x == y

instance ordHourOfDay :: Ord HourOfDay where
  compare (HourOfDay x) (HourOfDay y) = compare x y

-- | A quantity of hours (not necessarily a value between 0 and 23).
newtype Hours = Hours Number

instance eqHours :: Eq Hours where
  eq (Hours x) (Hours y) = x == y

instance ordHours :: Ord Hours where
  compare (Hours x) (Hours y) = compare x y

instance semiringHours :: Semiring Hours where
  add (Hours x) (Hours y) = Hours (x + y)
  mul (Hours x) (Hours y) = Hours (x * y)
  zero = Hours 0.0
  one = Hours 1.0

instance ringHours :: Ring Hours where
  sub (Hours x) (Hours y) = Hours (x - y)

instance moduloSemiringHours :: ModuloSemiring Hours where
  div (Hours x) (Hours y) = Hours (x / y)
  mod _ _ = Hours 0.0

instance divisionRingHours :: DivisionRing Hours

instance numHours :: Num Hours

instance showHours :: Show Hours where
  show (Hours n) = "(Hours " ++ show n ++ ")"

-- | A minute component from a time value. Should fall between 0 and 59
-- | inclusive.
newtype MinuteOfHour = MinuteOfHour Int

instance eqMinuteOfHour :: Eq MinuteOfHour where
  eq (MinuteOfHour x) (MinuteOfHour y) = x == y

instance ordMinuteOfHour :: Ord MinuteOfHour where
  compare (MinuteOfHour x) (MinuteOfHour y) = compare x y

-- | A quantity of minutes (not necessarily a value between 0 and 60).
newtype Minutes = Minutes Number

instance eqMinutes :: Eq Minutes where
  eq (Minutes x) (Minutes y) = x == y

instance ordMinutes :: Ord Minutes where
  compare (Minutes x) (Minutes y) = compare x y

instance semiringMinutes :: Semiring Minutes where
  add (Minutes x) (Minutes y) = Minutes (x + y)
  mul (Minutes x) (Minutes y) = Minutes (x * y)
  zero = Minutes 0.0
  one = Minutes 1.0

instance ringMinutes :: Ring Minutes where
  sub (Minutes x) (Minutes y) = Minutes (x - y)

instance moduloSemiringMinutes :: ModuloSemiring Minutes where
  div (Minutes x) (Minutes y) = Minutes (x / y)
  mod _ _ = Minutes 0.0

instance divisionRingMinutes :: DivisionRing Minutes

instance numMinutes :: Num Minutes

instance showMinutes :: Show Minutes where
  show (Minutes n) = "(Minutes " ++ show n ++ ")"

-- | A second component from a time value. Should fall between 0 and 59
-- | inclusive.
newtype SecondOfMinute = SecondOfMinute Int

instance eqSecondOfMinute :: Eq SecondOfMinute where
  eq (SecondOfMinute x) (SecondOfMinute y) = x == y

instance ordSecondOfMinute :: Ord SecondOfMinute where
  compare (SecondOfMinute x) (SecondOfMinute y) = compare x y

-- | A quantity of seconds (not necessarily a value between 0 and 60).
newtype Seconds = Seconds Number

instance eqSeconds :: Eq Seconds where
  eq (Seconds x) (Seconds y) = x == y

instance ordSeconds :: Ord Seconds where
  compare (Seconds x) (Seconds y) = compare x y

instance semiringSeconds :: Semiring Seconds where
  add (Seconds x) (Seconds y) = Seconds (x + y)
  mul (Seconds x) (Seconds y) = Seconds (x * y)
  zero = Seconds 0.0
  one = Seconds 1.0

instance ringSeconds :: Ring Seconds where
  sub (Seconds x) (Seconds y) = Seconds (x - y)

instance moduloSemiringSeconds :: ModuloSemiring Seconds where
  div (Seconds x) (Seconds y) = Seconds (x / y)
  mod _ _ = Seconds 0.0

instance divisionRingSeconds :: DivisionRing Seconds

instance numSeconds :: Num Seconds

instance showSeconds :: Show Seconds where
  show (Seconds n) = "(Seconds " ++ show n ++ ")"

-- | A millisecond component from a time value. Should fall between 0 and 999
-- | inclusive.
newtype MillisecondOfSecond = MillisecondOfSecond Int

instance eqMillisecondOfSecond :: Eq MillisecondOfSecond where
  eq (MillisecondOfSecond x) (MillisecondOfSecond y) = x == y

instance ordMillisecondOfSecond :: Ord MillisecondOfSecond where
  compare (MillisecondOfSecond x) (MillisecondOfSecond y) = compare x y

-- | A quantity of milliseconds (not necessarily a value between 0 and 1000).
newtype Milliseconds = Milliseconds Number

instance eqMilliseconds :: Eq Milliseconds where
  eq (Milliseconds x) (Milliseconds y) = x == y

instance ordMilliseconds :: Ord Milliseconds where
  compare (Milliseconds x) (Milliseconds y) = compare x y

instance semiringMilliseconds :: Semiring Milliseconds where
  add (Milliseconds x) (Milliseconds y) = Milliseconds (x + y)
  mul (Milliseconds x) (Milliseconds y) = Milliseconds (x * y)
  zero = Milliseconds 0.0
  one = Milliseconds 1.0

instance ringMilliseconds :: Ring Milliseconds where
  sub (Milliseconds x) (Milliseconds y) = Milliseconds (x - y)

instance moduloSemiringMilliseconds :: ModuloSemiring Milliseconds where
  div (Milliseconds x) (Milliseconds y) = Milliseconds (x / y)
  mod _ _ = Milliseconds 0.0

instance divisionRingMilliseconds :: DivisionRing Milliseconds

instance numMilliseconds :: Num Milliseconds

instance showMilliseconds :: Show Milliseconds where
  show (Milliseconds n) = "(Milliseconds " ++ show n ++ ")"

class TimeValue a where
  toHours :: a -> Hours
  toMinutes :: a -> Minutes
  toSeconds :: a -> Seconds
  toMilliseconds :: a -> Milliseconds
  fromHours :: Hours -> a
  fromMinutes :: Minutes -> a
  fromSeconds :: Seconds -> a
  fromMilliseconds :: Milliseconds -> a

instance timeValueHours :: TimeValue Hours where
  toHours n = n
  toMinutes (Hours n) = Minutes (n * 60.0)
  toSeconds (Hours n) = Seconds (n * 3600.0)
  toMilliseconds (Hours n) = Milliseconds (n * 3600000.0)
  fromHours n = n
  fromMinutes (Minutes n) = Hours (n / 60.0)
  fromSeconds (Seconds n) = Hours (n / 3600.0)
  fromMilliseconds (Milliseconds n) = Hours (n / 3600000.0)

instance timeValueMinutes :: TimeValue Minutes where
  toHours (Minutes n) = Hours (n / 60.0)
  toMinutes n = n
  toSeconds (Minutes n) = Seconds (n * 60.0)
  toMilliseconds (Minutes n) = Milliseconds (n * 60000.0)
  fromHours (Hours n) = Minutes (n * 60.0)
  fromMinutes n = n
  fromSeconds (Seconds n) = Minutes (n / 60.0)
  fromMilliseconds (Milliseconds n) = Minutes (n / 60000.0)

instance timeValueSeconds :: TimeValue Seconds where
  toHours (Seconds n) = Hours (n / 3600.0)
  toMinutes (Seconds n) = Minutes (n / 60.0)
  toSeconds n = n
  toMilliseconds (Seconds n) = Milliseconds (n * 1000.0)
  fromHours (Hours n) = Seconds (n * 3600.0)
  fromMinutes (Minutes n) = Seconds (n * 60.0)
  fromSeconds n = n
  fromMilliseconds (Milliseconds n) = Seconds (n / 1000.0)

instance timeValueMilliseconds :: TimeValue Milliseconds where
  toHours (Milliseconds n) = Hours (n / 3600000.0)
  toMinutes (Milliseconds n) = Minutes (n / 60000.0)
  toSeconds (Milliseconds n) = Seconds (n / 1000.0)
  toMilliseconds n = n
  fromHours (Hours n) = Milliseconds (n * 3600000.0)
  fromMinutes (Minutes n) = Milliseconds (n * 60000.0)
  fromSeconds (Seconds n) = Milliseconds (n * 1000.0)
  fromMilliseconds n = n

module Data.Time where

import Prelude
  ( (*)
  , (+)
  , (++)
  , (-)
  , (/)
  , (/=)
  , (==)
  , DivisionRing
  , Eq
  , ModuloSemiring
  , Num
  , Ord
  , Ring
  , Semiring
  , Show
  , compare
  , show )

-- | An hour component from a time value. Should fall between 0 and 23
-- | inclusive.
newtype HourOfDay = HourOfDay Int

instance eqHourOfDay :: Eq HourOfDay where
  eq (HourOfDay x) (HourOfDay y) = x == y

instance ordHourOfDay :: Ord HourOfDay where
  compare (HourOfDay x) (HourOfDay y) = compare x y

-- | A quantity of hours (not necessarily a value between 0 and 23).
newtype Hours = Hours Int

instance eqHours :: Eq Hours where
  eq (Hours x) (Hours y) = x == y

instance ordHours :: Ord Hours where
  compare (Hours x) (Hours y) = compare x y

instance semiringHours :: Semiring Hours where
  add (Hours x) (Hours y) = Hours (x + y)
  mul (Hours x) (Hours y) = Hours (x * y)
  zero = Hours 0
  one = Hours 1

instance ringHours :: Ring Hours where
  sub (Hours x) (Hours y) = Hours (x - y)

instance moduloSemiringHours :: ModuloSemiring Hours where
  div (Hours x) (Hours y) = Hours (x / y)
  mod _ _ = Hours 0

instance divisionRingHours :: DivisionRing Hours

instance numHours :: Num Hours

instance showHours :: Show Hours where
  show (Hours n) = "(Hours " ++ show n ++ ")"

-- | A minute component from a time value. Should fall between 0 and 59
-- | inclusive.
newtype MinuteOfHour = MinuteOfHour Int

instance eqMinuteOfHour :: Eq MinuteOfHour where
  eq (MinuteOfHour x) (MinuteOfHour y) = x == y

instance ordMinuteOfHour :: Ord MinuteOfHour where
  compare (MinuteOfHour x) (MinuteOfHour y) = compare x y

-- | A quantity of minutes (not necessarily a value between 0 and 60).
newtype Minutes = Minutes Int

instance eqMinutes :: Eq Minutes where
  eq (Minutes x) (Minutes y) = x == y

instance ordMinutes :: Ord Minutes where
  compare (Minutes x) (Minutes y) = compare x y

instance semiringMinutes :: Semiring Minutes where
  add (Minutes x) (Minutes y) = Minutes (x + y)
  mul (Minutes x) (Minutes y) = Minutes (x * y)
  zero = Minutes 0
  one = Minutes 1

instance ringMinutes :: Ring Minutes where
  sub (Minutes x) (Minutes y) = Minutes (x - y)

instance moduloSemiringMinutes :: ModuloSemiring Minutes where
  div (Minutes x) (Minutes y) = Minutes (x / y)
  mod _ _ = Minutes 0

instance divisionRingMinutes :: DivisionRing Minutes

instance numMinutes :: Num Minutes

instance showMinutes :: Show Minutes where
  show (Minutes n) = "(Minutes " ++ show n ++ ")"

-- | A second component from a time value. Should fall between 0 and 59
-- | inclusive.
newtype SecondOfMinute = SecondOfMinute Int

instance eqSecondOfMinute :: Eq SecondOfMinute where
  eq (SecondOfMinute x) (SecondOfMinute y) = x == y

instance ordSecondOfMinute :: Ord SecondOfMinute where
  compare (SecondOfMinute x) (SecondOfMinute y) = compare x y

-- | A quantity of seconds (not necessarily a value between 0 and 60).
newtype Seconds = Seconds Int

instance eqSeconds :: Eq Seconds where
  eq (Seconds x) (Seconds y) = x == y

instance ordSeconds :: Ord Seconds where
  compare (Seconds x) (Seconds y) = compare x y

instance semiringSeconds :: Semiring Seconds where
  add (Seconds x) (Seconds y) = Seconds (x + y)
  mul (Seconds x) (Seconds y) = Seconds (x * y)
  zero = Seconds 0
  one = Seconds 1

instance ringSeconds :: Ring Seconds where
  sub (Seconds x) (Seconds y) = Seconds (x - y)

instance moduloSemiringSeconds :: ModuloSemiring Seconds where
  div (Seconds x) (Seconds y) = Seconds (x / y)
  mod _ _ = Seconds 0

instance divisionRingSeconds :: DivisionRing Seconds

instance numSeconds :: Num Seconds

instance showSeconds :: Show Seconds where
  show (Seconds n) = "(Seconds " ++ show n ++ ")"

-- | A millisecond component from a time value. Should fall between 0 and 999
-- | inclusive.
newtype MillisecondOfSecond = MillisecondOfSecond Int

instance eqMillisecondOfSecond :: Eq MillisecondOfSecond where
  eq (MillisecondOfSecond x) (MillisecondOfSecond y) = x == y

instance ordMillisecondOfSecond :: Ord MillisecondOfSecond where
  compare (MillisecondOfSecond x) (MillisecondOfSecond y) = compare x y

-- | A quantity of milliseconds (not necessarily a value between 0 and 1000).
newtype Milliseconds = Milliseconds Int

instance eqMilliseconds :: Eq Milliseconds where
  eq (Milliseconds x) (Milliseconds y) = x == y

instance ordMilliseconds :: Ord Milliseconds where
  compare (Milliseconds x) (Milliseconds y) = compare x y

instance semiringMilliseconds :: Semiring Milliseconds where
  add (Milliseconds x) (Milliseconds y) = Milliseconds (x + y)
  mul (Milliseconds x) (Milliseconds y) = Milliseconds (x * y)
  zero = Milliseconds 0
  one = Milliseconds 1

instance ringMilliseconds :: Ring Milliseconds where
  sub (Milliseconds x) (Milliseconds y) = Milliseconds (x - y)

instance moduloSemiringMilliseconds :: ModuloSemiring Milliseconds where
  div (Milliseconds x) (Milliseconds y) = Milliseconds (x / y)
  mod _ _ = Milliseconds 0

instance divisionRingMilliseconds :: DivisionRing Milliseconds

instance numMilliseconds :: Num Milliseconds

instance showMilliseconds :: Show Milliseconds where
  show (Milliseconds n) = "(Milliseconds " ++ show n ++ ")"

class TimeValue a where
  toHours :: a -> Hours
  toMinutes :: a -> Minutes
  toSeconds :: a -> Seconds
  toMilliseconds :: a -> Milliseconds
  fromHours :: Hours -> a
  fromMinutes :: Minutes -> a
  fromSeconds :: Seconds -> a
  fromMilliseconds :: Milliseconds -> a

instance timeValueHours :: TimeValue Hours where
  toHours n = n
  toMinutes (Hours n) = Minutes (n * 60)
  toSeconds (Hours n) = Seconds (n * 3600)
  toMilliseconds (Hours n) = Milliseconds (n * 3600000)
  fromHours n = n
  fromMinutes (Minutes n) = Hours (n / 60)
  fromSeconds (Seconds n) = Hours (n / 3600)
  fromMilliseconds (Milliseconds n) = Hours (n / 3600000)

instance timeValueMinutes :: TimeValue Minutes where
  toHours (Minutes n) = Hours (n / 60)
  toMinutes n = n
  toSeconds (Minutes n) = Seconds (n * 60)
  toMilliseconds (Minutes n) = Milliseconds (n * 60000)
  fromHours (Hours n) = Minutes (n * 60)
  fromMinutes n = n
  fromSeconds (Seconds n) = Minutes (n / 60)
  fromMilliseconds (Milliseconds n) = Minutes (n / 60000)

instance timeValueSeconds :: TimeValue Seconds where
  toHours (Seconds n) = Hours (n / 3600)
  toMinutes (Seconds n) = Minutes (n / 60)
  toSeconds n = n
  toMilliseconds (Seconds n) = Milliseconds (n * 1000)
  fromHours (Hours n) = Seconds (n * 3600)
  fromMinutes (Minutes n) = Seconds (n * 60)
  fromSeconds n = n
  fromMilliseconds (Milliseconds n) = Seconds (n / 1000)

instance timeValueMilliseconds :: TimeValue Milliseconds where
  toHours (Milliseconds n) = Hours (n / 3600000)
  toMinutes (Milliseconds n) = Minutes (n / 60000)
  toSeconds (Milliseconds n) = Seconds (n / 1000)
  toMilliseconds n = n
  fromHours (Hours n) = Milliseconds (n * 3600000)
  fromMinutes (Minutes n) = Milliseconds (n * 60000)
  fromSeconds (Seconds n) = Milliseconds (n * 1000)
  fromMilliseconds n = n


removed 'removeIndices' for it was never used

module AST where

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

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

derive instance eqOp :: Eq Op

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

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

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

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

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

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

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

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

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

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

-- TODO: Find better name.
data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

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

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

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

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

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

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

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

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

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

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

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

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

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

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

emptyMeta :: Meta
emptyMeta = Meta emptyMeta'

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

type TVar = String

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

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

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

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

derive instance eqADTDef :: Eq ADTDef

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

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

data Associativity
  = LEFTASSOC
  | RIGHTASSOC
  | ASSOC

derive instance eqAssociativity :: Eq Associativity

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

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

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

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

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

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

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

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

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

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

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

type TypedBinding = Binding Meta

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

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

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

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

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

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

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

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

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

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

derive instance eqType :: Eq Type

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

derive instance eqTypeError :: Eq TypeError

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

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

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

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

module AST where

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

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

derive instance eqOp :: Eq Op

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

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

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

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

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

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

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

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

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

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

-- TODO: Find better name.
data QualTree b t m = Gen m b t
                    | Let m b t
                    | Guard m t

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

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

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

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

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

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

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

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

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

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

type Expr = Tree Atom (Binding Unit) Op Unit

type MType = Maybe Type

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

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

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

emptyMeta :: Meta
emptyMeta = Meta emptyMeta'

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

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

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

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

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

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

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

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

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

-- TODO: Is this at all necessary?
removeIndices :: TypeTree -> TypeTree
removeIndices = id

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

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

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

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

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

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

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

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

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

type TVar = String

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

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

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

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

derive instance eqADTDef :: Eq ADTDef

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

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

data Associativity
  = LEFTASSOC
  | RIGHTASSOC
  | ASSOC

derive instance eqAssociativity :: Eq Associativity

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

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

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

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

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

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

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

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

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

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

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

type TypedBinding = Binding Meta

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

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

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

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

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

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

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

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

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

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

derive instance eqType :: Eq Type

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

derive instance eqTypeError :: Eq TypeError

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

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

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

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


remove unnecessary liftEff

remove unnecessary liftEff

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, effCanceler, makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
          domContentLoaded = EventType "DOMContentLoaded"
      addEventListener domContentLoaded listener false et
      pure $ effCanceler (removeEventListener domContentLoaded listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, effCanceler, makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
          domContentLoaded = EventType "DOMContentLoaded"
      addEventListener domContentLoaded listener false et
      pure $ effCanceler (removeEventListener domContentLoaded listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))


Stop propagation of events in the HTML

Stop propagation of events in the HTML

module Web
  ( exprToJQuery
  , Handler ()
  ) where

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

import Data.Traversable (for)
import Data.Maybe

import AST
import Evaluator

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

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\je _ -> J.stopImmediatePropagation je *> evaluate p expr handler) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

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

type Class = String

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

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

evaluate :: forall eff. Path -> Expr -> Handler -> Eff (dom :: DOM | eff) Unit
evaluate p expr handler = case evalPath1 Data.StrMap.empty p expr of
  Nothing    -> return unit
  Just expr' -> handler expr'

module Web
  ( exprToJQuery
  , Handler ()
  ) where

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

import Data.Traversable (for)
import Data.Maybe

import AST
import Evaluator

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

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\_ _ -> evaluate p expr handler) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

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

type Class = String

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

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

evaluate :: forall eff. Path -> Expr -> Handler -> Eff (dom :: DOM | eff) Unit
evaluate p expr handler = case evalPath1 Data.StrMap.empty p expr of
  Nothing    -> return unit
  Just expr' -> handler expr'


fixes #1439

fixes #1439

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Notification.Component
  ( State
  , Query(..)
  , NotificationItem
  , RenderMode(..)
  , Expanded
  , DetailsPresented
  , Message(..)
  , component
  , initialState
  , renderModeFromAccessType
  , module N
  ) where

import SlamData.Prelude

import Control.Monad.Aff (later', forkAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar, putVar)

import Data.Array as Array
import Data.HeytingAlgebra (tt, ff, implies)
import Data.Int as Int
import Data.Time.Duration (Milliseconds(..))

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import SlamData.Monad (Slam)
import SlamData.Notification as N
import SlamData.Wiring as Wiring
import SlamData.Workspace.AccessType (AccessType(Editable, ReadOnly))

import Utils (lowercaseFirstChar, removeLastCharIfPeriod, parenthesize)

data Expanded = Expanded | Shrunk

data DetailsPresented = DetailsPresented | DetailsHidden

detailsPresentedToBoolean ∷ DetailsPresented → Boolean
detailsPresentedToBoolean =
  case _ of
    DetailsPresented → true
    DetailsHidden → false

booleanToDetailsPresented ∷ Boolean → DetailsPresented
booleanToDetailsPresented =
  case _ of
    true → DetailsPresented
    false → DetailsHidden

instance heytingAlgebraDetailsPresented :: HeytingAlgebra DetailsPresented where
  ff =
    booleanToDetailsPresented ff
  tt =
    booleanToDetailsPresented tt
  implies a b =
    booleanToDetailsPresented
      $ (detailsPresentedToBoolean a) `implies` (detailsPresentedToBoolean b)
  conj a =
    booleanToDetailsPresented
      ∘ (conj $ detailsPresentedToBoolean a)
      ∘ detailsPresentedToBoolean
  disj a =
    booleanToDetailsPresented
      ∘ (disj $ detailsPresentedToBoolean a)
      ∘ detailsPresentedToBoolean
  not =
    booleanToDetailsPresented
      ∘ not
      ∘ detailsPresentedToBoolean

data RenderMode = Notifications | ExpandableList Expanded

type State =
  { tick ∷ Int
  , queue ∷ Array NotificationItem
  , current ∷ Maybe NotificationItem
  , dismissed ∷ Maybe NotificationItem
  , renderMode ∷ RenderMode
  }

type NotificationItem =
  { id ∷ Int
  , dismiss ∷ AVar Unit
  , options ∷ N.NotificationOptions
  , detailsPresented ∷ DetailsPresented
  }

renderModeFromAccessType ∷ AccessType → RenderMode
renderModeFromAccessType =
  case _ of
    Editable → Notifications
    ReadOnly → ExpandableList Shrunk

initialState ∷ RenderMode → State
initialState renderMode =
  { tick: 0
  , queue: [ ]
  , current: Nothing
  , dismissed: Nothing
  , renderMode
  }

data Query a
  = Init a
  | Push N.NotificationOptions (H.SubscribeStatus -> a)
  | ToggleDetail a
  | Action N.Action a
  | Dismiss a
  | ExpandList a
  | UpdateRenderMode RenderMode a

data Status
  = Current
  | Dismissed

type Message = N.Action

type NotifyHTML = H.ComponentHTML Query

type NotifyDSL = H.ComponentDSL State Query Message Slam

component ∷ RenderMode → H.Component HH.HTML Query Unit Message Slam
component renderMode =
  H.lifecycleComponent
    { initialState: const (initialState renderMode)
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → NotifyHTML
render st =
  case st.renderMode of
    Notifications →
      HH.div
        [ HP.class_ (HH.ClassName "sd-notifications") ]
        [ renderNotification Dismissed st.dismissed
        , renderNotification Current st.current
        ]
    ExpandableList Shrunk →
      HH.div
        [ HP.class_ $ HH.ClassName "sd-notifications-list" ]
        if (Array.length all > 0)
          then
            [ HH.button
                [ HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
                , HP.type_ HP.ButtonButton
                , HE.onClick $ HE.input_ ExpandList
                ]
                [ HH.text "More details" ]
            ]
          else
            []
    ExpandableList Expanded →
      HH.div
        [ HP.class_ (HH.ClassName "sd-notifications-list") ]
        [ HH.ul_ $ renderListItem <$> all ]

  where
  all =
    maybe [] pure st.current <> st.queue

  renderNotification status = maybe (HH.text "") \n →
    HH.div
      [ HP.class_ (HH.ClassName "sd-notification-spacer") ]
      [ HH.div
          [ HP.classes (notificationClasses status n.options.notification) ]
          [ HH.div
              [ HP.class_ (HH.ClassName "sd-notification-text") ]
              [ HH.text (notificationText n.options.notification)
              , renderAction n
              , renderDetail n
              ]
          , HH.div
              [ HP.class_ (HH.ClassName "sd-notification-buttons") ]
              [ HH.button
                  [ HP.class_ (HH.ClassName "sd-notification-dismiss")
                  , HP.type_ HP.ButtonButton
                  , HE.onClick (HE.input_ Dismiss)
                  ]
                  [ HH.text "×" ]
              ]
          ]
      ]

  renderListItem n =
    HH.li_
      [ HH.text
          $ removeLastCharIfPeriod (notificationText n.options.notification)
          <> maybe
               ""
               (\(N.Details s) →
                  " " <> (parenthesize $ lowercaseFirstChar $ removeLastCharIfPeriod $ s))
               n.options.detail
          <> "."
      ]

  renderDetail n =
    n.options.detail
      # maybe
        (HH.text "")
        (\(N.Details d) → HH.div
          [ HP.class_ (HH.ClassName "sd-notification-detail") ]
          [ HH.button
              [ HP.classes [ HH.ClassName "btn", HH.ClassName "btn-default", HH.ClassName "btn-sm" ]
              , HP.type_ HP.ButtonButton
              , HE.onClick (HE.input_ ToggleDetail)
              ]
              [ HH.text
                  case n.detailsPresented of
                    DetailsPresented → "Hide detail"
                    DetailsHidden → "Show detail"
              ]
          , n.options.actionOptions
             # maybe
               (HH.text "")
               (\(N.ActionOptions a) →
                  HH.button
                    [ HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary", HH.ClassName "btn-sm" ]
                    , HP.type_ HP.ButtonButton
                    , HE.onClick (HE.input_ $ Action a.action)
                    ]
                    [ HH.text a.actionMessage ])
          , case n.detailsPresented of
              DetailsPresented →
                HH.div
                  [ HP.class_ (HH.ClassName "sd-notification-detail") ]
                  [ HH.p_ [ HH.text d ] ]
              DetailsHidden → HH.text ""
          ])

  renderAction n =
    n.options.actionOptions
      # maybe
        (HH.text "")
        (\(N.ActionOptions a) →
          HH.div
            [ HP.class_ (HH.ClassName "sd-notification-detail") ]
            [ HH.p_ [ HH.text a.message ] ])

  notificationClasses status n =
    [ HH.ClassName "sd-notification"
    , HH.ClassName case n of
        N.Info _    → "info"
        N.Warning _ → "warning"
        N.Error _   → "error"
    , HH.ClassName case status of
        Current   → "current"
        Dismissed → "dismissed"
    ]

  notificationText = case _ of
    N.Info s → s
    N.Warning s → s
    N.Error s → s

eval ∷ Query ~> NotifyDSL
eval = case _ of
  Init next → do
    { bus } ← Wiring.expose
    H.subscribe $ busEventSource (H.request <<< Push) bus.notify
    pure next
  Push options reply → do
    st ← H.get
    dismiss ← H.liftAff makeVar
    when
      (not (options `optionsEqItem` st.current ∨ options `optionsEqItem` Array.last st.queue))
      do
        let item =
              { id: st.tick
              , dismiss
              , options
              , detailsPresented: DetailsHidden
              }
        H.modify _
          { tick = st.tick + 1
          , queue = Array.snoc st.queue item
          }
        when (isNothing st.current) drainQueue
    pure $ reply H.Listening
  Dismiss next → do
    dismissNotification
    pure next
  Action act next → do
    dismissNotification
    H.raise act
    pure next
  ToggleDetail next → do
    current ← H.gets _.current
    for_ current \curr →
      H.modify _ { current = Just curr { detailsPresented = not curr.detailsPresented } }
    pure next
  ExpandList next →
    H.modify _ { renderMode = ExpandableList Expanded } $> next
  UpdateRenderMode renderMode next →
    H.modify _ { renderMode = renderMode } $> next
  where
  optionsEqItem ∷ N.NotificationOptions → Maybe NotificationItem → Boolean
  optionsEqItem options =
    maybe false (N.optionsWithoutActionEq options) ∘ map _.options

dismissNotification ∷ NotifyDSL Unit
dismissNotification = do
  current ← H.gets _.current
  for_ current \{ dismiss } →
    H.liftAff $ putVar dismiss unit

drainQueue ∷ NotifyDSL Unit
drainQueue = do
  st ← H.get
  case Array.uncons st.queue of
    Nothing → do
      H.modify _
        { current = Nothing
        , dismissed = st.current
        }
    Just { head, tail } → do
      H.modify _
        { queue = tail
        , current = Just head
        , dismissed = st.current
        }

      -- TODO: Make notifications with timeouts not disapear in ExpandableList
      -- render mode
      for_ head.options.timeout \(Milliseconds ms) →
        H.liftAff $ forkAff $ later' (Int.floor ms) (putVar head.dismiss unit)

      H.liftAff $ takeVar head.dismiss
      drainQueue

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Notification.Component
  ( State
  , Query(..)
  , NotificationItem
  , RenderMode(..)
  , Expanded
  , DetailsPresented
  , Message(..)
  , component
  , initialState
  , renderModeFromAccessType
  , module N
  ) where

import SlamData.Prelude

import Control.Monad.Aff (later', forkAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar, putVar)

import Data.Array as Array
import Data.HeytingAlgebra (tt, ff, implies)
import Data.Int as Int
import Data.Time.Duration (Milliseconds(..))

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import SlamData.Monad (Slam)
import SlamData.Notification as N
import SlamData.Wiring as Wiring
import SlamData.Workspace.AccessType (AccessType(Editable, ReadOnly))

import Utils (lowercaseFirstChar, removeLastCharIfPeriod, parenthesize)

data Expanded = Expanded | Shrunk

data DetailsPresented = DetailsPresented | DetailsHidden

detailsPresentedToBoolean ∷ DetailsPresented → Boolean
detailsPresentedToBoolean =
  case _ of
    DetailsPresented → true
    DetailsHidden → false

booleanToDetailsPresented ∷ Boolean → DetailsPresented
booleanToDetailsPresented =
  case _ of
    true → DetailsPresented
    false → DetailsHidden

instance heytingAlgebraDetailsPresented :: HeytingAlgebra DetailsPresented where
  ff =
    booleanToDetailsPresented ff
  tt =
    booleanToDetailsPresented tt
  implies a b =
    booleanToDetailsPresented
      $ (detailsPresentedToBoolean a) `implies` (detailsPresentedToBoolean b)
  conj a =
    booleanToDetailsPresented
      ∘ (conj $ detailsPresentedToBoolean a)
      ∘ detailsPresentedToBoolean
  disj a =
    booleanToDetailsPresented
      ∘ (disj $ detailsPresentedToBoolean a)
      ∘ detailsPresentedToBoolean
  not =
    booleanToDetailsPresented
      ∘ not
      ∘ detailsPresentedToBoolean

data RenderMode = Notifications | ExpandableList Expanded

type State =
  { tick ∷ Int
  , queue ∷ Array NotificationItem
  , current ∷ Maybe NotificationItem
  , dismissed ∷ Maybe NotificationItem
  , renderMode ∷ RenderMode
  }

type NotificationItem =
  { id ∷ Int
  , dismiss ∷ AVar Unit
  , options ∷ N.NotificationOptions
  , detailsPresented ∷ DetailsPresented
  }

renderModeFromAccessType ∷ AccessType → RenderMode
renderModeFromAccessType =
  case _ of
    Editable → Notifications
    ReadOnly → ExpandableList Shrunk

initialState ∷ RenderMode → State
initialState renderMode =
  { tick: 0
  , queue: [ ]
  , current: Nothing
  , dismissed: Nothing
  , renderMode
  }

data Query a
  = Init a
  | Push N.NotificationOptions (H.SubscribeStatus -> a)
  | ToggleDetail a
  | Action N.Action a
  | Dismiss a
  | ExpandList a
  | UpdateRenderMode RenderMode a

data Status
  = Current
  | Dismissed

type Message = N.Action

type NotifyHTML = H.ComponentHTML Query

type NotifyDSL = H.ComponentDSL State Query Message Slam

component ∷ RenderMode → H.Component HH.HTML Query Unit Message Slam
component renderMode =
  H.lifecycleComponent
    { initialState: const (initialState renderMode)
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → NotifyHTML
render st =
  case st.renderMode of
    Notifications →
      HH.div
        [ HP.class_ (HH.ClassName "sd-notifications") ]
        [ renderNotification Dismissed st.dismissed
        , renderNotification Current st.current
        ]
    ExpandableList Shrunk →
      HH.div
        [ HP.class_ $ HH.ClassName "sd-notifications-list" ]
        if (Array.length all > 0)
          then
            [ HH.button
                [ HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
                , HP.type_ HP.ButtonButton
                , HE.onClick $ HE.input_ ExpandList
                ]
                [ HH.text "More details" ]
            ]
          else
            []
    ExpandableList Expanded →
      HH.div
        [ HP.class_ (HH.ClassName "sd-notifications-list") ]
        [ HH.ul_ $ renderListItem <$> all ]

  where
  all =
    maybe [] pure st.current <> st.queue

  renderNotification status = maybe (HH.text "") \n →
    HH.div
      [ HP.class_ (HH.ClassName "sd-notification-spacer") ]
      [ HH.div
          [ HP.classes (notificationClasses status n.options.notification) ]
          [ HH.div
              [ HP.class_ (HH.ClassName "sd-notification-text") ]
              [ HH.text (notificationText n.options.notification)
              , renderAction n
              , renderDetail n
              ]
          , HH.div
              [ HP.class_ (HH.ClassName "sd-notification-buttons") ]
              [ HH.button
                  [ HP.class_ (HH.ClassName "sd-notification-dismiss")
                  , HP.type_ HP.ButtonButton
                  , HE.onClick (HE.input_ Dismiss)
                  ]
                  [ HH.text "×" ]
              ]
          ]
      ]

  renderListItem n =
    HH.li_
      [ HH.text
          $ removeLastCharIfPeriod (notificationText n.options.notification)
          <> maybe
               ""
               (\(N.Details s) →
                  " " <> (parenthesize $ lowercaseFirstChar $ removeLastCharIfPeriod $ s))
               n.options.detail
          <> "."
      ]

  renderDetail n =
    n.options.detail
      # maybe
        (HH.text "")
        (\(N.Details d) → HH.div
          [ HP.class_ (HH.ClassName "sd-notification-detail") ]
          [ HH.button
              [ HP.classes [ HH.ClassName "btn", HH.ClassName "btn-default", HH.ClassName "btn-sm" ]
              , HP.type_ HP.ButtonButton
              , HE.onClick (HE.input_ ToggleDetail)
              ]
              [ HH.text
                  case n.detailsPresented of
                    DetailsPresented → "Hide detail"
                    DetailsHidden → "Show detail"
              ]
          , n.options.actionOptions
             # maybe
               (HH.text "")
               (\(N.ActionOptions a) →
                  HH.button
                    [ HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary", HH.ClassName "btn-sm" ]
                    , HP.type_ HP.ButtonButton
                    , HE.onClick (HE.input_ $ Action a.action)
                    ]
                    [ HH.text a.actionMessage ])
          , case n.detailsPresented of
              DetailsPresented →
                HH.div
                  [ HP.class_ (HH.ClassName "sd-notification-detail") ]
                  [ HH.p_ [ HH.text d ] ]
              DetailsHidden → HH.text ""
          ])

  renderAction n =
    n.options.actionOptions
      # maybe
        (HH.text "")
        (\(N.ActionOptions a) →
          HH.div
            [ HP.class_ (HH.ClassName "sd-notification-detail") ]
            [ HH.p_ [ HH.text a.message ] ])

  notificationClasses status n =
    [ HH.ClassName "sd-notification"
    , HH.ClassName case n of
        N.Info _    → "info"
        N.Warning _ → "warning"
        N.Error _   → "error"
    , HH.ClassName case status of
        Current   → "current"
        Dismissed → "dismissed"
    ]

  notificationText = case _ of
    N.Info s → s
    N.Warning s → s
    N.Error s → s

eval ∷ Query ~> NotifyDSL
eval = case _ of
  Init next → do
    { bus } ← Wiring.expose
    H.subscribe $ busEventSource (H.request <<< Push) bus.notify
    pure next
  Push options reply → do
    st ← H.get
    dismiss ← H.liftAff makeVar
    when
      (not (options `optionsEqItem` st.current ∨ options `optionsEqItem` Array.last st.queue))
      do
        let item =
              { id: st.tick
              , dismiss
              , options
              , detailsPresented: DetailsHidden
              }
        H.modify _
          { tick = st.tick + 1
          , queue = Array.snoc st.queue item
          }
        when (isNothing st.current) drainQueue
    pure $ reply H.Listening
  Dismiss next → dismissNotification $> next
  Action N.ExpandGlobalMenu next → do
    H.raise N.ExpandGlobalMenu
    pure next
  Action act next → do
    dismissNotification
    H.raise act
    pure next
  ToggleDetail next → do
    current ← H.gets _.current
    for_ current \curr →
      H.modify _ { current = Just curr { detailsPresented = not curr.detailsPresented } }
    pure next
  ExpandList next →
    H.modify _ { renderMode = ExpandableList Expanded } $> next
  UpdateRenderMode renderMode next →
    H.modify _ { renderMode = renderMode } $> next
  where
  optionsEqItem ∷ N.NotificationOptions → Maybe NotificationItem → Boolean
  optionsEqItem options =
    maybe false (N.optionsWithoutActionEq options) ∘ map _.options

dismissNotification ∷ NotifyDSL Unit
dismissNotification = do
  current ← H.gets _.current
  for_ current \{ dismiss } →
    H.liftAff $ putVar dismiss unit

drainQueue ∷ NotifyDSL Unit
drainQueue = do
  st ← H.get
  case Array.uncons st.queue of
    Nothing → do
      H.modify _
        { current = Nothing
        , dismissed = st.current
        }
    Just { head, tail } → do
      H.modify _
        { queue = tail
        , current = Just head
        , dismissed = st.current
        }

      -- TODO: Make notifications with timeouts not disapear in ExpandableList
      -- render mode
      for_ head.options.timeout \(Milliseconds ms) →
        H.liftAff $ forkAff $ later' (Int.floor ms) (putVar head.dismiss unit)

      H.liftAff $ takeVar head.dismiss
      drainQueue