refactored src/Evaluator.purs

refactored src/Evaluator.purs

module Evaluator where

import Prelude hiding (apply)
import Data.List (List(Nil, Cons), null, singleton, concatMap, intersect, zipWith, zipWithA, length, (:), drop, concat)
import Data.List.Lazy (replicate)
import Data.StrMap (StrMap, delete)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (toChar)
import Data.String (singleton) as String
import Data.Char (fromCharCode)
import Data.Enum (fromEnum)
import Control.Comonad (extract)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Trans (StateT, get, modify, runStateT, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

-- import JSHelpers (unsafeUndef)

import AST (TypeTree, Tree(..), Atom(..), Binding(..), Definition(Def), Op(..), QualTree(..), TypeQual, MType, DataConstr (..), Meta (..))
import AST as AST

data EvalError =
    IndexError Int Int
  | DivByZero
  | EvalError TypeTree
  | BinaryOpError Op TypeTree TypeTree
  | UnaryOpError Op TypeTree
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | BindingError MatchingError
  | CannotEvaluate TypeTree
  | NoError
  | MoreErrors EvalError EvalError

instance semigroupEvalError :: Semigroup EvalError where
  append e1 e2 = MoreErrors e1 e2

instance monoidEvalError :: Monoid EvalError where
  mempty = NoError

instance showEvalError :: Show EvalError where
  show (IndexError i l)           = "IndexError " <> show i <> " " <> show l
  show DivByZero                  = "DivByZero"
  show (EvalError e)              = "EvalError " <> show e
  show (BinaryOpError o e1 e2)    = "BinaryOpError " <> show o <> " (" <> show e1 <> ") (" <> show e2 <> ")"
  show (UnaryOpError o e)         = "UnaryOpError " <> show o <> " " <> show e
  show (NameCaptureError ns)      = "NameCaptureError " <> show ns
  show (UnknownFunction n)        = "UnknownFunction " <> show n
  show (NoMatchingFunction n mes) = "NoMatchingFunction " <> show n <> " " <> show mes
  show (BindingError me)          = "BindingError " <> show me
  show (CannotEvaluate e)         = "CannotEvaluate " <> show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " <> show e1 <> " " <> show e2 <> ")"

data MatchingError =
    MatchingError (Binding Meta) TypeTree
  | StrictnessError (Binding Meta) TypeTree
  | TooFewArguments (List (Binding Meta)) (List TypeTree)

instance showMatchingError :: Show MatchingError where
  show (MatchingError b e)     = "MatchingError " <> show b <> " " <> show e
  show (StrictnessError b e)   = "StrictnessError " <> show b <> " " <> show e
  show (TooFewArguments bs es) = "TooFewArguments " <> show bs <> " " <> show es

type Evaluator = ExceptT EvalError Identity

runEvalM :: forall a. Evaluator a -> Either EvalError a
runEvalM = extract <<< runExceptT

type Matcher = ExceptT MatchingError Identity

runMatcherM :: forall a. Matcher a -> Either MatchingError a
runMatcherM = extract <<< runExceptT

type Env = StrMap (List (Tuple (List (Binding Meta)) TypeTree))

defsToEnv :: (List Definition) -> Env
defsToEnv = foldl insertDef Map.empty

envToDefs :: Env -> (List Definition)
envToDefs env = concat $ map tupleToDef $ Map.toList env
  where
    tupleToDef (Tuple name defs) = map
                                    (\(Tuple bin expr) -> Def name bin expr)
                                    defs

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case Map.lookup name env of
  Nothing   -> Map.insert name (singleton $ Tuple bindings body) env
  Just defs -> Map.insert name (defs <> (singleton $ Tuple bindings body)) env

-- | Evaluates an expression by one step in a given environment.
eval1 :: Env -> TypeTree -> Evaluator TypeTree
eval1 env expr = case expr of
  (Binary _ op e1 e2)                  -> binary env op e1 e2
  (Unary _ op e)                       -> unary env op e
  (Atom _ (Name name))                 -> apply env name Nil
  (IfExpr _ (Atom _ (Bool true)) te _)   -> pure te
  (IfExpr _ (Atom _ (Bool false)) _ ee)  -> pure ee
  (ArithmSeq _ start step end)         -> evalArithmSeq start step end
  -- (List _ (Cons e es))                      -> pure $ Binary Nothing Colon e (List Nothing es)
  (App _ (Binary _ (Tuple Composition _) f g) (Cons e Nil)) -> pure $ App AST.emptyMeta f (singleton $ App AST.emptyMeta g (Cons e Nil))
  (App _ (Lambda _ binds body) args)     -> tryAll env (singleton $ Tuple binds body) args "lambda" Nil
  (App _ (SectL _ e1 op) (Cons e2 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary AST.emptyMeta op e1 e2)
  (App _ (SectR _ op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary AST.emptyMeta op e1 e2)
  (App _ (PrefixOp _ op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary AST.emptyMeta op e1 e2)
  (App _ (Atom _ (Name name)) args)      -> apply env name args
  (App _ (App _ func es) es')            -> pure $ App AST.emptyMeta func (es <> es')
--  (App _ (Atom _ (Constr _)) _)      -> pure expr
  (ListComp _ e qs)                    -> evalListComp env e qs
  (LetExpr _ binds exp)                -> evalLetTypeTree binds exp
--  (Atom _ (Constr x))                -> pure expr
  _                                  -> throwError $ CannotEvaluate expr

eval :: Env -> TypeTree -> TypeTree
eval env expr = evalToBinding env expr (Lit AST.emptyMeta (Name "_|_"))

-- | Evaluates an expression until it matches a given binding in a given environment.
evalToBinding :: Env -> TypeTree -> Binding Meta -> TypeTree
evalToBinding env expr bind = case bind of
  (Lit _ (Name "_|_")) -> recurse env expr bind
  (Lit _ (Name _))     -> expr
  (Lit _ _)            -> case expr of
    (Atom _ _) -> expr
    _          -> recurse env expr bind

  (ConsLit _ b bs)     -> case expr of
    (Binary _ (Tuple Colon _) e es) -> Binary AST.emptyMeta (Tuple Colon AST.emptyMeta) (evalToBinding env e b) (evalToBinding env es bs)
    (List _ (Cons e es))  -> evalToBinding env (Binary AST.emptyMeta (Tuple Colon AST.emptyMeta) e (List AST.emptyMeta es)) bind
    _                     -> recurse env expr bind

  (ListLit _ bs)       -> case expr of
    (List _ es) -> if (length es == length bs) then List AST.emptyMeta (zipWith (evalToBinding env) es bs) else expr
    _           -> recurse env expr bind

  (NTupleLit _ bs)     -> case expr of
    (NTuple _ es)  -> NTuple AST.emptyMeta (zipWith (evalToBinding env) es bs)
    _              -> recurse env expr bind
-- TODO
  (ConstrLit _ (PrefixDataConstr n _ ps)) ->
    case expr of
      (App _ (Atom _ (Constr n')) ps') ->
        case n == n' && length ps == length ps' of
          true -> App AST.emptyMeta (Atom AST.emptyMeta (Constr n')) (zipWith (evalToBinding env) ps' ps)
          false -> expr
      _ -> recurse env expr bind
  (ConstrLit _ (InfixDataConstr n _ _ l r)) ->
    case expr of
      (App _ (PrefixOp _ (Tuple (InfixConstr n') meta)) (Cons l' (Cons r' Nil))) ->
        case n == n' && meta == AST.emptyMeta of
             true -> App
              AST.emptyMeta
              (PrefixOp AST.emptyMeta (Tuple (InfixConstr n') AST.emptyMeta))
              (Cons (evalToBinding env l' l) (Cons (evalToBinding env r' r) Nil))
             false -> expr
      (Binary _ (Tuple (InfixConstr n') _) l' r') ->
        case n == n' of
             true -> Binary AST.emptyMeta (Tuple (InfixConstr n') AST.emptyMeta) (evalToBinding env l' l) (evalToBinding env r' r)
             false -> expr
      _ -> recurse env expr bind

recurse :: Env -> TypeTree -> Binding Meta -> TypeTree
recurse env expr bind = if expr == eval1d then expr else evalToBinding env eval1d bind
  where
    eval1d :: TypeTree
    eval1d = either (const expr') id $ runEvalM $ eval1 env expr'
    expr' :: TypeTree
    expr' = case expr of
      (Binary _ op e1 e2)  ->
        Binary AST.emptyMeta op (evalToBinding env e1 bind) (evalToBinding env e2 bind)
      (Unary _ op e)       ->
        Unary AST.emptyMeta op (evalToBinding env e bind)
      (List _ es)          ->
        List AST.emptyMeta ((\e -> evalToBinding env e bind) <$> es)
      (NTuple _ es)        ->
        NTuple AST.emptyMeta ((\e -> evalToBinding env e bind) <$> es)
      (IfExpr _ c t e)     ->
        IfExpr AST.emptyMeta (evalToBinding env c bind) t e
      (App _ c@(Atom _ (Constr _)) args) ->
        App AST.emptyMeta c ((\e -> evalToBinding env e bind) <$> args)
      (App _ f args)       -> do
        App AST.emptyMeta (evalToBinding env f bind) args
      (ArithmSeq _ c t e)     ->
        ArithmSeq AST.emptyMeta (evalToBinding env c bind) ((\x -> evalToBinding env x bind) <$> t) ((\x -> evalToBinding env x bind) <$> e)
      (ListComp _ e qs)    -> do
        ListComp AST.emptyMeta (evalToBinding env e bind) ((\x -> evalToBindingQual env x bind) <$> qs)
      _                  ->
        expr

    evalToBindingQual :: Env -> TypeQual -> Binding Meta ->TypeQual
    evalToBindingQual environment qual binding = case qual of
      Let _ b e -> Let AST.emptyMeta b (evalToBinding environment e bind)
      Gen _ b e -> Gen AST.emptyMeta b (evalToBinding environment e bind)
      Guard _ e -> Guard AST.emptyMeta (evalToBinding environment e bind)

wrapLambda :: (List (Binding Meta)) -> (List TypeTree) -> TypeTree -> Evaluator TypeTree
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> pure body
    GT -> pure $ Lambda AST.emptyMeta (drop (length args) binds) body
    LT -> pure $ App AST.emptyMeta body (drop (length binds) args)

------------------------------------------------------------------------------------------
-- Arithmetic Sequences
------------------------------------------------------------------------------------------

--  packs the evaluation result for arithmetic sequences (AS)

--  example:
--  Quat (Just x) (Just y) (Just z) (Just a) will be displayed as x : [y, z .. a]

data Quat a = Quat a a a a

instance functorQuat :: Functor Quat where
  map f (Quat a b c d) = Quat (f a) (f b) (f c) (f d)

intFromStepTo :: Int -> Maybe Int -> Maybe Int -> Quat (Maybe Int)
intFromStepTo start Nothing Nothing     = Quat (Just start) (clampSucc start) Nothing Nothing

intFromStepTo start (Just step) Nothing = case clampStep start step of
  Just nstep -> Quat (Just start) (Just step) (Just nstep) Nothing
  Nothing    -> Quat (Just start) (Just step) Nothing (Just step)

intFromStepTo start Nothing (Just end) = case start > end of
  true  -> Quat Nothing Nothing Nothing Nothing
  false -> case start == end of
    true  -> Quat (Just end) Nothing Nothing Nothing
    false -> case clampSucc start of
      Just nstart -> Quat (Just start) (Just nstart) Nothing (Just end)
      Nothing     -> Quat (Just start) Nothing Nothing Nothing

intFromStepTo start (Just step) (Just end) = case (start <= step && start > end) || (start > step && start < end) of
  true  -> Quat Nothing Nothing Nothing Nothing
  false -> if start == end || (abs step) > (abs end)
    then Quat (Just start) Nothing Nothing Nothing
    else case clampStep start step of
      Nothing    -> Quat (Just start) (Just step) Nothing (Just step)
      Just nstep -> Quat (Just start) (Just step) (Just nstep) (Just end)

abs :: Int -> Int
abs x = if x < 0 then -x else x

clampSucc :: Int -> Maybe Int
clampSucc i = if i < top then Just (i + 1) else Nothing

clampStep :: Int -> Int -> Maybe Int
clampStep istart istep = if istep >= istart
  then if (top - istep)    >= (istep - istart) then Just (istep + (istep - istart)) else Nothing
  else if (bottom - istep) <= (istep - istart) then Just (istep + (istep - istart)) else Nothing

exprFromStepTo :: TypeTree -> Maybe TypeTree -> Maybe TypeTree -> Quat (Maybe TypeTree)
exprFromStepTo start step end = case start of
  Atom _ (AInt i) -> (\x -> (Atom AST.emptyMeta <<< AInt) <$> x) <$> intQuat
  Atom _ (Bool b) -> (\x -> (Atom AST.emptyMeta <<< Bool) <$> x) <$> (intToABool intQuat)
  Atom _ (Char c) -> (\x -> (Atom AST.emptyMeta <<< Char <<< String.singleton) <$> x) <$> (intToAChar intQuat)
  _             -> Quat Nothing Nothing Nothing Nothing
    where
      intQuat = intFromStepTo (unsafeTypeTreeToInt start) (unsafeTypeTreeToInt <$> step) (unsafeTypeTreeToInt <$> end)

--detects whether 'top' or 'bottom' for Boolean was reached
intToABool :: Quat (Maybe Int) -> Quat (Maybe Boolean)
intToABool quat = case temp of
  Quat (Just x) (Just y) z a -> if x == y then Quat (Just x) Nothing Nothing Nothing else temp
  _ -> temp
  where
    temp :: Quat (Maybe Boolean)
    temp = (\x -> intToBool' <$> x) <$> quat

    intToBool' :: Int -> Boolean
    intToBool' i = if i <= 0 then false else true

--detects whether 'top' or 'bottom' for Char was reached
intToAChar :: Quat (Maybe Int) -> Quat (Maybe Char)
intToAChar quat = case temp of
  Quat (Just x) (Just y) z a -> if x == y then Quat (Just x) Nothing Nothing Nothing else temp
  _ -> temp
  where
    temp :: Quat (Maybe Char)
    temp = (\x -> intToChar' <$> x) <$> quat

    intToChar' :: Int -> Char
    intToChar' i = if c >= (top :: Char) then top else if c <= (bottom :: Char) then bottom else c
      where c = fromCharCode i

unsafeTypeTreeToInt :: TypeTree -> Int
unsafeTypeTreeToInt (Atom _ (AInt i))   = i
unsafeTypeTreeToInt (Atom _ (Bool b))   = fromEnum b
unsafeTypeTreeToInt (Atom _ (Char str)) = fromEnum $ fromMaybe 'E' (toChar str)
unsafeTypeTreeToInt _ = top

evalArithmSeq :: TypeTree -> Maybe TypeTree -> Maybe TypeTree -> Evaluator TypeTree
evalArithmSeq start step end = case foldr (&&) true (isValid <$> [Just start, step, end]) of
  false -> throwError $ CannotEvaluate $ ArithmSeq AST.emptyMeta start step end
  true  -> evalArithmSeq'
  where
    isValid :: Maybe TypeTree -> Boolean
    isValid Nothing = true
    isValid (Just (Atom _ (Name _))) = false
    isValid (Just (Atom _ _)) = true
    isValid _ = false

    evalArithmSeq' :: Evaluator TypeTree
    evalArithmSeq' = case (exprFromStepTo start step end) of
      Quat Nothing _ _ _          -> pure $ List AST.emptyMeta Nil
      Quat (Just a) Nothing _ _   -> pure $ AST.binary Colon a (List AST.emptyMeta Nil)
      Quat (Just a) (Just na) b c -> pure $ AST.binary Colon a (ArithmSeq AST.emptyMeta na b c)

------------------------------------------------------------------------------------------
-- List Comprehensions
------------------------------------------------------------------------------------------

evalListComp :: Env -> TypeTree -> List TypeQual -> Evaluator TypeTree
evalListComp _   expr Nil         = pure $ List AST.emptyMeta $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard _ (Atom _ (Bool false)) -> pure $ List AST.emptyMeta Nil
  Guard _ (Atom _ (Bool true))  -> if null qs then pure (List AST.emptyMeta (singleton expr)) else pure (ListComp AST.emptyMeta expr qs)
  Gen _ _ (List _ Nil)          -> pure $ List AST.emptyMeta Nil
  -- Gen _ b (List (Cons e Nil)) -> evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
  Gen _ b (List _ (Cons e es))  -> do
    listcomp1 <- evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
    listcomp2 <- pure $ ListComp AST.emptyMeta expr (Cons (Gen AST.emptyMeta b (List AST.emptyMeta es)) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ Binary AST.emptyMeta (Tuple Colon AST.emptyMeta) x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  -- Gen _ b (Binary Colon e (List Nil)) -> evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
  Gen _ b (Binary _ (Tuple Colon _) e es)  -> do
    listcomp1 <- evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
    listcomp2 <- pure $ ListComp AST.emptyMeta expr (Cons (Gen AST.emptyMeta b es) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ AST.binary Colon x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  Gen _ b e -> pure $ ListComp AST.emptyMeta expr
    (Cons (Gen AST.emptyMeta b (evalToBinding env e (ConsLit AST.emptyMeta b (Lit AST.emptyMeta (Name "_"))))) qs)
  Let _ b e -> case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
    Right r -> do
      Tuple qs' r' <- runStateT (replaceQualifiers qs) r
      expr'        <- replace' r' expr
      case qs' of
          Nil -> pure $ List AST.emptyMeta $ singleton expr'
          _   -> pure $ ListComp AST.emptyMeta expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp AST.emptyMeta expr (Cons q qs))

-- replaces expressions in List-Comprehension-Qualifiers and considers overlapping bindings
replaceQualifiers :: List TypeQual -> StateT (StrMap TypeTree) Evaluator (List TypeQual)
replaceQualifiers = traverse replaceQual
  where
    replaceQual :: TypeQual -> StateT (StrMap TypeTree) Evaluator TypeQual
    replaceQual qual = case qual of
      Gen _ b e -> scope b e >>= \e' -> pure $ Gen AST.emptyMeta b e'
      Let _ b e -> scope b e >>= \e' -> pure $ Let AST.emptyMeta b e'
      Guard _ e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard AST.emptyMeta e'

scope :: Binding Meta -> TypeTree -> StateT (StrMap TypeTree) Evaluator TypeTree
scope b e = do
  sub <- get
  e'  <- lift $ replace' sub e
  modify (removeOverlapping b)
  pure e'

------------------------------------------------------------------------------------------
-- Let TypeTreeessions
------------------------------------------------------------------------------------------

type Bindings = List (Tuple (Binding Meta) TypeTree)

evalLetTypeTree :: Bindings -> TypeTree -> Evaluator TypeTree
evalLetTypeTree Nil e = pure e
evalLetTypeTree (Cons (Tuple b e) rest) expr = case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
  Left l  -> throwError $ BindingError $ MatchingError b e
  Right r -> do
    case rest of
      Nil -> replace' r expr
      _   -> do
        Tuple rest' r' <- runStateT (replaceBindings rest) r
        expr' <- replace' r' expr
        pure $ LetExpr AST.emptyMeta rest' expr'

replaceBindings :: Bindings -> StateT (StrMap TypeTree) Evaluator Bindings
replaceBindings = traverse $ \(Tuple bin expr) -> do
  expr' <- scope bin expr
  pure $ Tuple bin expr'

------------------------------------------------------------------------------------------

binary :: Env -> (Tuple Op Meta) -> TypeTree -> TypeTree -> Evaluator TypeTree
binary env (Tuple operator meta) = case operator of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List _ ls) -> pure $ List AST.emptyMeta $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List _ ls1) (List _ ls2)) -> pure $ List AST.emptyMeta $ ls1 <> ls2
    _                                 -> throwError $ BinaryOpError Append es1 es2
  Equ    -> ord Equ (==) (==) (==)
  Neq    -> ord Neq (/=) (/=) (/=)
  Leq    -> ord Leq (<=) (<=) (<=)
  Lt     -> ord Lt  (<)  (<)  (<)
  Geq    -> ord Geq (>=) (>=) (>=)
  Gt     -> ord Gt  (>)  (>)  (>)
  And    -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool false)) _                  )   -> pure $ Atom AST.emptyMeta $ Bool false
    (Tuple _                     (Atom _ (Bool false))) -> pure $ Atom AST.emptyMeta $ Bool false
    (Tuple (Atom _ (Bool true))  (Atom _ (Bool true)))  -> pure $ Atom AST.emptyMeta $ Bool true
    (Tuple _                   _                     )  -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool true))  _                   )  -> pure $ Atom AST.emptyMeta $ Bool true
    (Tuple _                     (Atom _ (Bool true)))  -> pure $ Atom AST.emptyMeta $ Bool true
    (Tuple (Atom _ (Bool false)) (Atom _ (Bool false))) -> pure $ Atom AST.emptyMeta $ Bool false
    (Tuple _                     _                   )  -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ App AST.emptyMeta f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  InfixFunc name -> \e1 e2 -> apply env name (e1 : e2 : Nil)
  InfixConstr name -> \e1 e2 -> pure $ Binary AST.emptyMeta (Tuple operator meta) e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> TypeTree -> TypeTree -> Evaluator TypeTree
    aint _   f (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom AST.emptyMeta $ AInt $ f i j
    aint op  _ e1                e2                = throwError $ BinaryOpError op e1 e2

    ord :: Op -> (Int -> Int -> Boolean) -> (String -> String -> Boolean) -> (Boolean -> Boolean -> Boolean)-> TypeTree -> TypeTree -> Evaluator TypeTree
    ord _  fi _  _  (Atom _ (AInt i))  (Atom _ (AInt j))  = pure $ Atom AST.emptyMeta $ Bool $ fi i j
    ord _  _  fs _  (Atom _ (Char s1)) (Atom _ (Char s2)) = pure $ Atom AST.emptyMeta $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom _ (Bool b1)) (Atom _ (Bool b2)) = pure $ Atom AST.emptyMeta $ Bool $ fb b1 b2
    ord op _  _  _  e1               e2               = throwError $ BinaryOpError op e1 e2

unary :: Env -> Tuple Op Meta -> TypeTree -> Evaluator TypeTree
unary env (Tuple Sub _) (Atom _ (AInt i)) = pure $ Atom AST.emptyMeta $ AInt (-i)
unary env (Tuple op _) e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List TypeTree) -> Evaluator TypeTree
apply env "div" (Cons e1 (Cons e2 _)) = division e1 e2
apply env "mod" (Cons e1 (Cons e2 _)) = modulo e1 e2
apply env name args = case Map.lookup name env of
  Nothing    -> throwError $ UnknownFunction name
  Just cases -> tryAll env cases args name Nil

-- built-in div
division :: TypeTree -> TypeTree -> Evaluator TypeTree
division (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
division (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom AST.emptyMeta $ AInt $ div i j
division e1 e2 = throwError $ BinaryOpError (InfixFunc "div") e1 e2

-- built-in mod
modulo :: TypeTree -> TypeTree -> Evaluator TypeTree
modulo (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
modulo (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom AST.emptyMeta $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List (Binding Meta)) TypeTree)) -> (List TypeTree) -> String -> (List MatchingError) -> Evaluator TypeTree
tryAll _   Nil                        _    name errs = throwError $ NoMatchingFunction name errs
tryAll env (Cons (Tuple binds body) cases) args name errs | (length args) < (length binds) = tryAll env cases args name (errs <> (singleton $ TooFewArguments binds args))
tryAll env (Cons (Tuple binds body) cases) args name errs = case runMatcherM $ matchls' env binds args of
  Right replMap                 -> replace' replMap body >>= wrapLambda binds args
  Left se@(StrictnessError _ _) -> throwError $ NoMatchingFunction name (errs <> singleton se)
  Left err                      -> tryAll env cases args name (errs <> singleton err)

whnf :: TypeTree -> Boolean
whnf (Atom _ (Name _)) = false
whnf (Atom _ _)        = true
whnf (List _ _)        = true
whnf (NTuple _ _)      = true
whnf (Binary _ (Tuple (InfixConstr _) _) _ _) = true
whnf (App _ (Atom _ (Constr _)) _) = true
whnf _                 = false

checkStrictness :: Binding Meta -> TypeTree -> MatchingError
checkStrictness bs es | whnf es   = MatchingError bs es
                      | otherwise = StrictnessError bs es

matchls' :: Env -> (List (Binding Meta)) -> (List TypeTree) -> Matcher (StrMap TypeTree)
matchls' env bs es = execStateT (zipWithA (\b e -> match' b (evalToBinding env e b)) bs es) Map.empty

match' :: Binding Meta -> TypeTree -> StateT (StrMap TypeTree) Matcher Unit
match' (Lit _ (Name name)) e                   = modify (Map.insert name e)
match' (Lit _ ba)          (Atom _ ea)         = case ba == ea of
                                                 true  -> pure unit
                                                 false -> throwError $ MatchingError (Lit AST.emptyMeta ba) (Atom AST.emptyMeta ea)
match' (Lit _ b)           e                   = throwError $ checkStrictness (Lit AST.emptyMeta b) e

match' (ConsLit _ b bs)    (Binary _ (Tuple Colon _) e es) = match' b e *> match' bs es
match' (ConsLit _ b bs)    (List _ (Cons e es))  = match' (ConsLit AST.emptyMeta b bs) (AST.binary Colon e (List AST.emptyMeta es))
match' (ConsLit _ b bs)    (List _ Nil)          = throwError $ MatchingError (ConsLit AST.emptyMeta b bs) (List AST.emptyMeta Nil)
match' (ConsLit _ b bs)    e                     = throwError $ checkStrictness (ConsLit AST.emptyMeta b bs) e

match' (ListLit _ (Cons b bs)) (Binary _ (Tuple Colon _) e es) = match' b e *> match' (ListLit AST.emptyMeta bs) es
match' (ListLit _ bs)      (List _ es)               = case length bs == length es of
                                                       true  -> void $ zipWithA match' bs es
                                                       false -> throwError $ MatchingError (ListLit AST.emptyMeta bs) (List AST.emptyMeta es)
match' (ListLit _ bs)      e                         = throwError $ checkStrictness (ListLit AST.emptyMeta bs) e

match' (NTupleLit _ bs)    (NTuple _ es) = case length bs == length es of
                                           true  -> void $ zipWithA match' bs es
                                           false -> throwError $ MatchingError (NTupleLit AST.emptyMeta bs) (NTuple AST.emptyMeta es)
match' (NTupleLit _ bs)    e             = throwError $ checkStrictness (NTupleLit AST.emptyMeta bs) e
-- TODO
match' b@(ConstrLit _ (PrefixDataConstr n a ps)) e@(App _ (Atom _ (Constr n')) ps')
  = case  n == n' && length ps == length ps' of
         true -> void $ zipWithA match' ps ps'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(Binary _ (Tuple (InfixConstr n') _) l' r')
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(App _ (PrefixOp _ (Tuple (InfixConstr n') _)) (Cons l' (Cons r' Nil)))
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e
match' b@(ConstrLit _ _) e = throwError $ checkStrictness b e

--TODO: replace with purescript mapM
mapM' :: forall a b m. (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
mapM' f Nothing  = pure Nothing
mapM' f (Just x) = Just <$> (f x)

mapM :: forall a b m. (Monad m) => (a -> m b) -> List a -> m (List b)
mapM f Nil = pure Nil
mapM f (Cons x xs) = do
  y  <- f x
  ys <- mapM f xs
  pure $ Cons y ys

-- removes every entry in StrMap that is inside the binding
removeOverlapping :: Binding Meta -> StrMap TypeTree -> StrMap TypeTree
removeOverlapping bind = removeOverlapping' (boundNames bind)
  where
    removeOverlapping' :: List String -> StrMap TypeTree -> StrMap TypeTree
    removeOverlapping' Nil         = id
    removeOverlapping' (Cons s ss) = removeOverlapping' ss <<< delete s

replace' :: StrMap TypeTree -> TypeTree -> Evaluator TypeTree
replace' subs = go
  where
  go tt = case tt of
    a@(Atom _ (Name name)) -> case Map.lookup name subs of
      Just subTypeTree -> pure subTypeTree
      Nothing      -> pure a
    (List _ exprs)         -> List AST.emptyMeta <$> (traverse go exprs)
    (NTuple _ exprs)       -> NTuple AST.emptyMeta <$> (traverse go exprs)
    (Binary _ op e1 e2)    -> Binary AST.emptyMeta <$> pure op <*> go e1 <*> go e2
    (Unary _ op e)         -> Unary AST.emptyMeta <$> pure op <*> go e
    (SectL _ e op)         -> SectL AST.emptyMeta <$> go e <*> pure op
    (SectR _ op e)         -> SectR AST.emptyMeta <$> pure op <*> go e
    (IfExpr _ ce te ee)    -> IfExpr AST.emptyMeta <$> go ce <*> go te <*> go ee
    (ArithmSeq _ ce te ee) -> ArithmSeq AST.emptyMeta <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda _ binds body)  -> (avoidCapture subs binds)
      *> (Lambda AST.emptyMeta <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App _ func exprs)     -> App AST.emptyMeta <$> go func <*> traverse go exprs
    (ListComp _ expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      pure $ ListComp AST.emptyMeta expr' quals'
    (LetExpr _ binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr AST.emptyMeta binds' expr'
    e                     -> pure e

avoidCapture :: StrMap TypeTree -> (List (Binding Meta)) -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ Map.values subs) (boundNames' binds) of
  Nil      -> pure unit
  captures -> throwError $ NameCaptureError captures

freeVariables :: TypeTree -> (List String)
freeVariables _ = Nil
-- freeVariables = nub <<< foldTypeTree
--   (\a -> case a of
--     Name name -> singleton $ name
--     _         -> Nil)
--   concat
--   concat
--   (\_ f1 f2 -> f1 <> f2)
--   (\_ f -> f)
--   (\f _ -> f)
--   (\_ f -> f)
--   (\_ -> Nil)
--   (\f1 f2 f3 -> f1 <> f2 <> f3)
--   (\bs f -> nub f \\ boundNames' bs)
--   (\f fs -> f <> concat fs)

boundNames' :: (List (Binding Meta)) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding Meta -> (List String)
boundNames = go
  where
  go (Lit _  (Name name)) = singleton name
  go (ConsLit _ b1 b2)   = go b1 <> go b2
  go (ListLit _ bs)      = foldMap go bs
  go (NTupleLit _ bs)    = foldMap go bs
  go _                 = Nil

module Evaluator where

import Prelude hiding (apply)
import Data.List (List(Nil, Cons), null, singleton, concatMap, intersect, zipWith, zipWithA, length, (:), drop, concat)
import Data.List.Lazy (replicate)
import Data.StrMap (StrMap, delete)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (toChar)
import Data.String (singleton) as String
import Data.Char (fromCharCode)
import Data.Enum (fromEnum)
import Control.Comonad (extract)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Trans (StateT, get, modify, runStateT, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

-- import JSHelpers (unsafeUndef)

import AST (TypeTree, Tree(..), Atom(..), Binding(..), Definition(Def), Op(..), QualTree(..), TypeQual, MType, DataConstr (..), Meta (..))
import AST as AST

data EvalError =
    IndexError Int Int
  | DivByZero
  | EvalError TypeTree
  | BinaryOpError Op TypeTree TypeTree
  | UnaryOpError Op TypeTree
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | BindingError MatchingError
  | CannotEvaluate TypeTree
  | NoError
  | MoreErrors EvalError EvalError

instance semigroupEvalError :: Semigroup EvalError where
  append e1 e2 = MoreErrors e1 e2

instance monoidEvalError :: Monoid EvalError where
  mempty = NoError

instance showEvalError :: Show EvalError where
  show (IndexError i l)           = "IndexError " <> show i <> " " <> show l
  show DivByZero                  = "DivByZero"
  show (EvalError e)              = "EvalError " <> show e
  show (BinaryOpError o e1 e2)    = "BinaryOpError " <> show o <> " (" <> show e1 <> ") (" <> show e2 <> ")"
  show (UnaryOpError o e)         = "UnaryOpError " <> show o <> " " <> show e
  show (NameCaptureError ns)      = "NameCaptureError " <> show ns
  show (UnknownFunction n)        = "UnknownFunction " <> show n
  show (NoMatchingFunction n mes) = "NoMatchingFunction " <> show n <> " " <> show mes
  show (BindingError me)          = "BindingError " <> show me
  show (CannotEvaluate e)         = "CannotEvaluate " <> show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " <> show e1 <> " " <> show e2 <> ")"

data MatchingError =
    MatchingError (Binding Meta) TypeTree
  | StrictnessError (Binding Meta) TypeTree
  | TooFewArguments (List (Binding Meta)) (List TypeTree)

instance showMatchingError :: Show MatchingError where
  show (MatchingError b e)     = "MatchingError " <> show b <> " " <> show e
  show (StrictnessError b e)   = "StrictnessError " <> show b <> " " <> show e
  show (TooFewArguments bs es) = "TooFewArguments " <> show bs <> " " <> show es

type Evaluator = ExceptT EvalError Identity

runEvalM :: forall a. Evaluator a -> Either EvalError a
runEvalM = extract <<< runExceptT

type Matcher = ExceptT MatchingError Identity

runMatcherM :: forall a. Matcher a -> Either MatchingError a
runMatcherM = extract <<< runExceptT

type Env = StrMap (List (Tuple (List (Binding Meta)) TypeTree))

defsToEnv :: (List Definition) -> Env
defsToEnv = foldl insertDef Map.empty

envToDefs :: Env -> (List Definition)
envToDefs env = concat $ map tupleToDef $ Map.toList env
  where
    tupleToDef (Tuple name defs) = map
                                    (\(Tuple bin expr) -> Def name bin expr)
                                    defs

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case Map.lookup name env of
  Nothing   -> Map.insert name (singleton $ Tuple bindings body) env
  Just defs -> Map.insert name (defs <> (singleton $ Tuple bindings body)) env

-- | Evaluates an expression by one step in a given environment.
eval1 :: Env -> TypeTree -> Evaluator TypeTree
eval1 env expr = case expr of
  (Binary _ op e1 e2)                  -> binary env op e1 e2
  (Unary _ op e)                       -> unary env op e
  (Atom _ (Name name))                 -> apply env name Nil
  (IfExpr _ (Atom _ (Bool true)) te _)   -> pure te
  (IfExpr _ (Atom _ (Bool false)) _ ee)  -> pure ee
  (ArithmSeq _ start step end)         -> evalArithmSeq start step end
  -- (List _ (Cons e es))                      -> pure $ Binary Nothing Colon e (List Nothing es)
  (App _ (Binary _ (Tuple Composition _) f g) (Cons e Nil)) -> pure $ App AST.emptyMeta f (singleton $ App AST.emptyMeta g (Cons e Nil))
  (App _ (Lambda _ binds body) args)     -> tryAll env (singleton $ Tuple binds body) args "lambda" Nil
  (App _ (SectL _ e1 op) (Cons e2 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary AST.emptyMeta op e1 e2)
  (App _ (SectR _ op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary AST.emptyMeta op e1 e2)
  (App _ (PrefixOp _ op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary AST.emptyMeta op e1 e2)
  (App _ (Atom _ (Name name)) args)      -> apply env name args
  (App _ (App _ func es) es')            -> pure $ App AST.emptyMeta func (es <> es')
--  (App _ (Atom _ (Constr _)) _)      -> pure expr
  (ListComp _ e qs)                    -> evalListComp env e qs
  (LetExpr _ binds exp)                -> evalLetTypeTree binds exp
--  (Atom _ (Constr x))                -> pure expr
  _                                  -> throwError $ CannotEvaluate expr

eval :: Env -> TypeTree -> TypeTree
eval env expr = evalToBinding env expr (Lit AST.emptyMeta (Name "_|_"))

-- | Evaluates an expression until it matches a given binding in a given environment.
evalToBinding :: Env -> TypeTree -> Binding Meta -> TypeTree
evalToBinding env expr bind = case bind of
  (Lit _ (Name "_|_")) -> recurse env expr bind
  (Lit _ (Name _))     -> expr
  (Lit _ _)            -> case expr of
    (Atom _ _) -> expr
    _          -> recurse env expr bind

  (ConsLit _ b bs)     -> case expr of
    (Binary _ (Tuple Colon _) e es) -> Binary AST.emptyMeta (Tuple Colon Nothing) (evalToBinding env e b) (evalToBinding env es bs)
    (List _ (Cons e es))  -> evalToBinding env (Binary AST.emptyMeta (Tuple Colon Nothing) e (List AST.emptyMeta es)) bind
    _                     -> recurse env expr bind

  (ListLit _ bs)       -> case expr of
    (List _ es) -> if (length es == length bs) then List AST.emptyMeta (zipWith (evalToBinding env) es bs) else expr
    _           -> recurse env expr bind

  (NTupleLit _ bs)     -> case expr of
    (NTuple _ es)  -> NTuple AST.emptyMeta (zipWith (evalToBinding env) es bs)
    _              -> recurse env expr bind
-- TODO
  (ConstrLit _ (PrefixDataConstr n _ ps)) ->
    case expr of
      (App _ (Atom _ (Constr n')) ps') ->
        case n == n' && length ps == length ps' of
          true -> App AST.emptyMeta (Atom AST.emptyMeta (Constr n')) (zipWith (evalToBinding env) ps' ps)
          false -> expr
      _ -> recurse env expr bind
  (ConstrLit _ (InfixDataConstr n _ _ l r)) ->
    case expr of
      (App _ (PrefixOp _ (Tuple (InfixConstr n') Nothing)) (Cons l' (Cons r' Nil))) ->
        case n == n' of
             true -> App
              AST.emptyMeta
              (PrefixOp AST.emptyMeta (Tuple (InfixConstr n') Nothing))
              (Cons (evalToBinding env l' l) (Cons (evalToBinding env r' r) Nil))
             false -> expr
      (Binary _ (Tuple (InfixConstr n') _) l' r') ->
        case n == n' of
             true -> Binary AST.emptyMeta (Tuple (InfixConstr n') Nothing) (evalToBinding env l' l) (evalToBinding env r' r)
             false -> expr
      _ -> recurse env expr bind

recurse :: Env -> TypeTree -> Binding Meta -> TypeTree
recurse env expr bind = if expr == eval1d then expr else evalToBinding env eval1d bind
  where
    eval1d :: TypeTree
    eval1d = either (const expr') id $ runEvalM $ eval1 env expr'
    expr' :: TypeTree
    expr' = case expr of
      (Binary _ op e1 e2)  ->
        Binary AST.emptyMeta op (evalToBinding env e1 bind) (evalToBinding env e2 bind)
      (Unary _ op e)       ->
        Unary AST.emptyMeta op (evalToBinding env e bind)
      (List _ es)          ->
        List AST.emptyMeta ((\e -> evalToBinding env e bind) <$> es)
      (NTuple _ es)        ->
        NTuple AST.emptyMeta ((\e -> evalToBinding env e bind) <$> es)
      (IfExpr _ c t e)     ->
        IfExpr AST.emptyMeta (evalToBinding env c bind) t e
      (App _ c@(Atom _ (Constr _)) args) ->
        App AST.emptyMeta c ((\e -> evalToBinding env e bind) <$> args)
      (App _ f args)       -> do
        App AST.emptyMeta (evalToBinding env f bind) args
      (ArithmSeq _ c t e)     ->
        ArithmSeq AST.emptyMeta (evalToBinding env c bind) ((\x -> evalToBinding env x bind) <$> t) ((\x -> evalToBinding env x bind) <$> e)
      (ListComp _ e qs)    -> do
        ListComp AST.emptyMeta (evalToBinding env e bind) ((\x -> evalToBindingQual env x bind) <$> qs)
      _                  ->
        expr

    evalToBindingQual :: Env -> TypeQual -> Binding Meta ->TypeQual
    evalToBindingQual environment qual binding = case qual of
      Let _ b e -> Let AST.emptyMeta b (evalToBinding environment e bind)
      Gen _ b e -> Gen AST.emptyMeta b (evalToBinding environment e bind)
      Guard _ e -> Guard AST.emptyMeta (evalToBinding environment e bind)

wrapLambda :: (List (Binding Meta)) -> (List TypeTree) -> TypeTree -> Evaluator TypeTree
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> pure body
    GT -> pure $ Lambda AST.emptyMeta (drop (length args) binds) body
    LT -> pure $ App AST.emptyMeta body (drop (length binds) args)

------------------------------------------------------------------------------------------
-- Arithmetic Sequences
------------------------------------------------------------------------------------------

--  packs the evaluation result for arithmetic sequences (AS)

--  example:
--  Quat (Just x) (Just y) (Just z) (Just a) will be displayed as x : [y, z .. a]

data Quat a = Quat a a a a

instance functorQuat :: Functor Quat where
  map f (Quat a b c d) = Quat (f a) (f b) (f c) (f d)

intFromStepTo :: Int -> Maybe Int -> Maybe Int -> Quat (Maybe Int)
intFromStepTo start Nothing Nothing     = Quat (Just start) (clampSucc start) Nothing Nothing

intFromStepTo start (Just step) Nothing = case clampStep start step of
  Just nstep -> Quat (Just start) (Just step) (Just nstep) Nothing
  Nothing    -> Quat (Just start) (Just step) Nothing (Just step)

intFromStepTo start Nothing (Just end) = case start > end of
  true  -> Quat Nothing Nothing Nothing Nothing
  false -> case start == end of
    true  -> Quat (Just end) Nothing Nothing Nothing
    false -> case clampSucc start of
      Just nstart -> Quat (Just start) (Just nstart) Nothing (Just end)
      Nothing     -> Quat (Just start) Nothing Nothing Nothing

intFromStepTo start (Just step) (Just end) = case (start <= step && start > end) || (start > step && start < end) of
  true  -> Quat Nothing Nothing Nothing Nothing
  false -> if start == end || (abs step) > (abs end)
    then Quat (Just start) Nothing Nothing Nothing
    else case clampStep start step of
      Nothing    -> Quat (Just start) (Just step) Nothing (Just step)
      Just nstep -> Quat (Just start) (Just step) (Just nstep) (Just end)

abs :: Int -> Int
abs x = if x < 0 then -x else x

clampSucc :: Int -> Maybe Int
clampSucc i = if i < top then Just (i + 1) else Nothing

clampStep :: Int -> Int -> Maybe Int
clampStep istart istep = if istep >= istart
  then if (top - istep)    >= (istep - istart) then Just (istep + (istep - istart)) else Nothing
  else if (bottom - istep) <= (istep - istart) then Just (istep + (istep - istart)) else Nothing

exprFromStepTo :: TypeTree -> Maybe TypeTree -> Maybe TypeTree -> Quat (Maybe TypeTree)
exprFromStepTo start step end = case start of
  Atom _ (AInt i) -> (\x -> (Atom AST.emptyMeta <<< AInt) <$> x) <$> intQuat
  Atom _ (Bool b) -> (\x -> (Atom AST.emptyMeta <<< Bool) <$> x) <$> (intToABool intQuat)
  Atom _ (Char c) -> (\x -> (Atom AST.emptyMeta <<< Char <<< String.singleton) <$> x) <$> (intToAChar intQuat)
  _             -> Quat Nothing Nothing Nothing Nothing
    where
      intQuat = intFromStepTo (unsafeTypeTreeToInt start) (unsafeTypeTreeToInt <$> step) (unsafeTypeTreeToInt <$> end)

--detects whether 'top' or 'bottom' for Boolean was reached
intToABool :: Quat (Maybe Int) -> Quat (Maybe Boolean)
intToABool quat = case temp of
  Quat (Just x) (Just y) z a -> if x == y then Quat (Just x) Nothing Nothing Nothing else temp
  _ -> temp
  where
    temp :: Quat (Maybe Boolean)
    temp = (\x -> intToBool' <$> x) <$> quat

    intToBool' :: Int -> Boolean
    intToBool' i = if i <= 0 then false else true

--detects whether 'top' or 'bottom' for Char was reached
intToAChar :: Quat (Maybe Int) -> Quat (Maybe Char)
intToAChar quat = case temp of
  Quat (Just x) (Just y) z a -> if x == y then Quat (Just x) Nothing Nothing Nothing else temp
  _ -> temp
  where
    temp :: Quat (Maybe Char)
    temp = (\x -> intToChar' <$> x) <$> quat

    intToChar' :: Int -> Char
    intToChar' i = if c >= (top :: Char) then top else if c <= (bottom :: Char) then bottom else c
      where c = fromCharCode i

unsafeTypeTreeToInt :: TypeTree -> Int
unsafeTypeTreeToInt (Atom _ (AInt i))   = i
unsafeTypeTreeToInt (Atom _ (Bool b))   = fromEnum b
unsafeTypeTreeToInt (Atom _ (Char str)) = fromEnum $ fromMaybe 'E' (toChar str)
unsafeTypeTreeToInt _ = top

evalArithmSeq :: TypeTree -> Maybe TypeTree -> Maybe TypeTree -> Evaluator TypeTree
evalArithmSeq start step end = case foldr (&&) true (isValid <$> [Just start, step, end]) of
  false -> throwError $ CannotEvaluate $ ArithmSeq AST.emptyMeta start step end
  true  -> evalArithmSeq'
  where
    isValid :: Maybe TypeTree -> Boolean
    isValid Nothing = true
    isValid (Just (Atom _ (Name _))) = false
    isValid (Just (Atom _ _)) = true
    isValid _ = false

    evalArithmSeq' :: Evaluator TypeTree
    evalArithmSeq' = case (exprFromStepTo start step end) of
      Quat Nothing _ _ _          -> pure $ List AST.emptyMeta Nil
      Quat (Just a) Nothing _ _   -> pure $ AST.binary Colon a (List AST.emptyMeta Nil)
      Quat (Just a) (Just na) b c -> pure $ AST.binary Colon a (ArithmSeq AST.emptyMeta na b c)

------------------------------------------------------------------------------------------
-- List Comprehensions
------------------------------------------------------------------------------------------

evalListComp :: Env -> TypeTree -> List TypeQual -> Evaluator TypeTree
evalListComp _   expr Nil         = pure $ List AST.emptyMeta $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard _ (Atom _ (Bool false)) -> pure $ List AST.emptyMeta Nil
  Guard _ (Atom _ (Bool true))  -> if null qs then pure (List AST.emptyMeta (singleton expr)) else pure (ListComp AST.emptyMeta expr qs)
  Gen _ _ (List _ Nil)          -> pure $ List AST.emptyMeta Nil
  -- Gen _ b (List (Cons e Nil)) -> evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
  Gen _ b (List _ (Cons e es))  -> do
    listcomp1 <- evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
    listcomp2 <- pure $ ListComp AST.emptyMeta expr (Cons (Gen AST.emptyMeta b (List AST.emptyMeta es)) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ Binary AST.emptyMeta (Tuple Colon Nothing) x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  -- Gen _ b (Binary Colon e (List Nil)) -> evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
  Gen _ b (Binary _ (Tuple Colon _) e es)  -> do
    listcomp1 <- evalListComp env expr (Cons (Let AST.emptyMeta b e) qs)
    listcomp2 <- pure $ ListComp AST.emptyMeta expr (Cons (Gen AST.emptyMeta b es) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ AST.binary Colon x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  Gen _ b e -> pure $ ListComp AST.emptyMeta expr
    (Cons (Gen AST.emptyMeta b (evalToBinding env e (ConsLit AST.emptyMeta b (Lit AST.emptyMeta (Name "_"))))) qs)
  Let _ b e -> case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
    Right r -> do
      Tuple qs' r' <- runStateT (replaceQualifiers qs) r
      expr'        <- replace' r' expr
      case qs' of
          Nil -> pure $ List AST.emptyMeta $ singleton expr'
          _   -> pure $ ListComp AST.emptyMeta expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp AST.emptyMeta expr (Cons q qs))

-- replaces expressions in List-Comprehension-Qualifiers and considers overlapping bindings
replaceQualifiers :: List TypeQual -> StateT (StrMap TypeTree) Evaluator (List TypeQual)
replaceQualifiers = traverse replaceQual
  where
    replaceQual :: TypeQual -> StateT (StrMap TypeTree) Evaluator TypeQual
    replaceQual qual = case qual of
      Gen _ b e -> scope b e >>= \e' -> pure $ Gen AST.emptyMeta b e'
      Let _ b e -> scope b e >>= \e' -> pure $ Let AST.emptyMeta b e'
      Guard _ e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard AST.emptyMeta e'

scope :: Binding Meta -> TypeTree -> StateT (StrMap TypeTree) Evaluator TypeTree
scope b e = do
  sub <- get
  e'  <- lift $ replace' sub e
  modify (removeOverlapping b)
  pure e'

------------------------------------------------------------------------------------------
-- Let TypeTreeessions
------------------------------------------------------------------------------------------

type Bindings = List (Tuple (Binding Meta) TypeTree)

evalLetTypeTree :: Bindings -> TypeTree -> Evaluator TypeTree
evalLetTypeTree Nil e = pure e
evalLetTypeTree (Cons (Tuple b e) rest) expr = case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
  Left l  -> throwError $ BindingError $ MatchingError b e
  Right r -> do
    case rest of
      Nil -> replace' r expr
      _   -> do
        Tuple rest' r' <- runStateT (replaceBindings rest) r
        expr' <- replace' r' expr
        pure $ LetExpr AST.emptyMeta rest' expr'

replaceBindings :: Bindings -> StateT (StrMap TypeTree) Evaluator Bindings
replaceBindings = traverse $ \(Tuple bin expr) -> do
  expr' <- scope bin expr
  pure $ Tuple bin expr'

------------------------------------------------------------------------------------------

binary :: Env -> (Tuple Op MType) -> TypeTree -> TypeTree -> Evaluator TypeTree
binary env (Tuple operator mtype) = case operator of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List _ ls) -> pure $ List AST.emptyMeta $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List _ ls1) (List _ ls2)) -> pure $ List AST.emptyMeta $ ls1 <> ls2
    _                                 -> throwError $ BinaryOpError Append es1 es2
  Equ    -> ord Equ (==) (==) (==)
  Neq    -> ord Neq (/=) (/=) (/=)
  Leq    -> ord Leq (<=) (<=) (<=)
  Lt     -> ord Lt  (<)  (<)  (<)
  Geq    -> ord Geq (>=) (>=) (>=)
  Gt     -> ord Gt  (>)  (>)  (>)
  And    -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool false)) _                  )   -> pure $ Atom AST.emptyMeta $ Bool false
    (Tuple _                     (Atom _ (Bool false))) -> pure $ Atom AST.emptyMeta $ Bool false
    (Tuple (Atom _ (Bool true))  (Atom _ (Bool true)))  -> pure $ Atom AST.emptyMeta $ Bool true
    (Tuple _                   _                     )  -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool true))  _                   )  -> pure $ Atom AST.emptyMeta $ Bool true
    (Tuple _                     (Atom _ (Bool true)))  -> pure $ Atom AST.emptyMeta $ Bool true
    (Tuple (Atom _ (Bool false)) (Atom _ (Bool false))) -> pure $ Atom AST.emptyMeta $ Bool false
    (Tuple _                     _                   )  -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ App AST.emptyMeta f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  InfixFunc name -> \e1 e2 -> apply env name (e1 : e2 : Nil)
  InfixConstr name -> \e1 e2 -> pure $ Binary AST.emptyMeta (Tuple operator mtype) e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> TypeTree -> TypeTree -> Evaluator TypeTree
    aint _   f (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom AST.emptyMeta $ AInt $ f i j
    aint op  _ e1                e2                = throwError $ BinaryOpError op e1 e2

    ord :: Op -> (Int -> Int -> Boolean) -> (String -> String -> Boolean) -> (Boolean -> Boolean -> Boolean)-> TypeTree -> TypeTree -> Evaluator TypeTree
    ord _  fi _  _  (Atom _ (AInt i))  (Atom _ (AInt j))  = pure $ Atom AST.emptyMeta $ Bool $ fi i j
    ord _  _  fs _  (Atom _ (Char s1)) (Atom _ (Char s2)) = pure $ Atom AST.emptyMeta $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom _ (Bool b1)) (Atom _ (Bool b2)) = pure $ Atom AST.emptyMeta $ Bool $ fb b1 b2
    ord op _  _  _  e1               e2               = throwError $ BinaryOpError op e1 e2

unary :: Env -> Tuple Op MType -> TypeTree -> Evaluator TypeTree
unary env (Tuple Sub _) (Atom _ (AInt i)) = pure $ Atom AST.emptyMeta $ AInt (-i)
unary env (Tuple op _) e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List TypeTree) -> Evaluator TypeTree
apply env "div" (Cons e1 (Cons e2 _)) = division e1 e2
apply env "mod" (Cons e1 (Cons e2 _)) = modulo e1 e2
apply env name args = case Map.lookup name env of
  Nothing    -> throwError $ UnknownFunction name
  Just cases -> tryAll env cases args name Nil

-- built-in div
division :: TypeTree -> TypeTree -> Evaluator TypeTree
division (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
division (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom AST.emptyMeta $ AInt $ div i j
division e1 e2 = throwError $ BinaryOpError (InfixFunc "div") e1 e2

-- built-in mod
modulo :: TypeTree -> TypeTree -> Evaluator TypeTree
modulo (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
modulo (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom AST.emptyMeta $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List (Binding Meta)) TypeTree)) -> (List TypeTree) -> String -> (List MatchingError) -> Evaluator TypeTree
tryAll _   Nil                        _    name errs = throwError $ NoMatchingFunction name errs
tryAll env (Cons (Tuple binds body) cases) args name errs | (length args) < (length binds) = tryAll env cases args name (errs <> (singleton $ TooFewArguments binds args))
tryAll env (Cons (Tuple binds body) cases) args name errs = case runMatcherM $ matchls' env binds args of
  Right replMap                 -> replace' replMap body >>= wrapLambda binds args
  Left se@(StrictnessError _ _) -> throwError $ NoMatchingFunction name (errs <> singleton se)
  Left err                      -> tryAll env cases args name (errs <> singleton err)

whnf :: TypeTree -> Boolean
whnf (Atom _ (Name _)) = false
whnf (Atom _ _)        = true
whnf (List _ _)        = true
whnf (NTuple _ _)      = true
whnf (Binary _ (Tuple (InfixConstr _) _) _ _) = true
whnf (App _ (Atom _ (Constr _)) _) = true
whnf _                 = false

checkStrictness :: Binding Meta -> TypeTree -> MatchingError
checkStrictness bs es | whnf es   = MatchingError bs es
                      | otherwise = StrictnessError bs es

matchls' :: Env -> (List (Binding Meta)) -> (List TypeTree) -> Matcher (StrMap TypeTree)
matchls' env bs es = execStateT (zipWithA (\b e -> match' b (evalToBinding env e b)) bs es) Map.empty

match' :: Binding Meta -> TypeTree -> StateT (StrMap TypeTree) Matcher Unit
match' (Lit _ (Name name)) e                   = modify (Map.insert name e)
match' (Lit _ ba)          (Atom _ ea)         = case ba == ea of
                                                 true  -> pure unit
                                                 false -> throwError $ MatchingError (Lit AST.emptyMeta ba) (Atom AST.emptyMeta ea)
match' (Lit _ b)           e                   = throwError $ checkStrictness (Lit AST.emptyMeta b) e

match' (ConsLit _ b bs)    (Binary _ (Tuple Colon _) e es) = match' b e *> match' bs es
match' (ConsLit _ b bs)    (List _ (Cons e es))  = match' (ConsLit AST.emptyMeta b bs) (AST.binary Colon e (List AST.emptyMeta es))
match' (ConsLit _ b bs)    (List _ Nil)          = throwError $ MatchingError (ConsLit AST.emptyMeta b bs) (List AST.emptyMeta Nil)
match' (ConsLit _ b bs)    e                     = throwError $ checkStrictness (ConsLit AST.emptyMeta b bs) e

match' (ListLit _ (Cons b bs)) (Binary _ (Tuple Colon _) e es) = match' b e *> match' (ListLit AST.emptyMeta bs) es
match' (ListLit _ bs)      (List _ es)               = case length bs == length es of
                                                       true  -> void $ zipWithA match' bs es
                                                       false -> throwError $ MatchingError (ListLit AST.emptyMeta bs) (List AST.emptyMeta es)
match' (ListLit _ bs)      e                         = throwError $ checkStrictness (ListLit AST.emptyMeta bs) e

match' (NTupleLit _ bs)    (NTuple _ es) = case length bs == length es of
                                           true  -> void $ zipWithA match' bs es
                                           false -> throwError $ MatchingError (NTupleLit AST.emptyMeta bs) (NTuple AST.emptyMeta es)
match' (NTupleLit _ bs)    e             = throwError $ checkStrictness (NTupleLit AST.emptyMeta bs) e
-- TODO
match' b@(ConstrLit _ (PrefixDataConstr n a ps)) e@(App _ (Atom _ (Constr n')) ps')
  = case  n == n' && length ps == length ps' of
         true -> void $ zipWithA match' ps ps'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(Binary _ (Tuple (InfixConstr n') _) l' r')
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(App _ (PrefixOp _ (Tuple (InfixConstr n') _)) (Cons l' (Cons r' Nil)))
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e
match' b@(ConstrLit _ _) e = throwError $ checkStrictness b e

--TODO: replace with purescript mapM
mapM' :: forall a b m. (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
mapM' f Nothing  = pure Nothing
mapM' f (Just x) = Just <$> (f x)

mapM :: forall a b m. (Monad m) => (a -> m b) -> List a -> m (List b)
mapM f Nil = pure Nil
mapM f (Cons x xs) = do
  y  <- f x
  ys <- mapM f xs
  pure $ Cons y ys

-- removes every entry in StrMap that is inside the binding
removeOverlapping :: Binding Meta -> StrMap TypeTree -> StrMap TypeTree
removeOverlapping bind = removeOverlapping' (boundNames bind)
  where
    removeOverlapping' :: List String -> StrMap TypeTree -> StrMap TypeTree
    removeOverlapping' Nil         = id
    removeOverlapping' (Cons s ss) = removeOverlapping' ss <<< delete s

replace' :: StrMap TypeTree -> TypeTree -> Evaluator TypeTree
replace' subs = go
  where
  go tt = case tt of
    a@(Atom _ (Name name)) -> case Map.lookup name subs of
      Just subTypeTree -> pure subTypeTree
      Nothing      -> pure a
    (List _ exprs)         -> List AST.emptyMeta <$> (traverse go exprs)
    (NTuple _ exprs)       -> NTuple AST.emptyMeta <$> (traverse go exprs)
    (Binary _ op e1 e2)    -> Binary AST.emptyMeta <$> pure op <*> go e1 <*> go e2
    (Unary _ op e)         -> Unary AST.emptyMeta <$> pure op <*> go e
    (SectL _ e op)         -> SectL AST.emptyMeta <$> go e <*> pure op
    (SectR _ op e)         -> SectR AST.emptyMeta <$> pure op <*> go e
    (IfExpr _ ce te ee)    -> IfExpr AST.emptyMeta <$> go ce <*> go te <*> go ee
    (ArithmSeq _ ce te ee) -> ArithmSeq AST.emptyMeta <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda _ binds body)  -> (avoidCapture subs binds)
      *> (Lambda AST.emptyMeta <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App _ func exprs)     -> App AST.emptyMeta <$> go func <*> traverse go exprs
    (ListComp _ expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      pure $ ListComp AST.emptyMeta expr' quals'
    (LetExpr _ binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr AST.emptyMeta binds' expr'
    e                     -> pure e

avoidCapture :: StrMap TypeTree -> (List (Binding Meta)) -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ Map.values subs) (boundNames' binds) of
  Nil      -> pure unit
  captures -> throwError $ NameCaptureError captures

freeVariables :: TypeTree -> (List String)
freeVariables _ = Nil
-- freeVariables = nub <<< foldTypeTree
--   (\a -> case a of
--     Name name -> singleton $ name
--     _         -> Nil)
--   concat
--   concat
--   (\_ f1 f2 -> f1 <> f2)
--   (\_ f -> f)
--   (\f _ -> f)
--   (\_ f -> f)
--   (\_ -> Nil)
--   (\f1 f2 f3 -> f1 <> f2 <> f3)
--   (\bs f -> nub f \\ boundNames' bs)
--   (\f fs -> f <> concat fs)

boundNames' :: (List (Binding Meta)) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding Meta -> (List String)
boundNames = go
  where
  go (Lit _  (Name name)) = singleton name
  go (ConsLit _ b1 b2)   = go b1 <> go b2
  go (ListLit _ bs)      = foldMap go bs
  go (NTupleLit _ bs)    = foldMap go bs
  go _                 = Nil


Drop redundant MonadAff constraints on forking

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Halogen.Data.Slot (Slot)
import Halogen.Data.Slot as Slot
import Halogen.Query.ChildQuery as CQ
import Halogen.Query.EventSource as ES
import Halogen.Query.Input (RefLabel)
import Prim.Row as Row
import Web.DOM (Element)

-- | The Halogen component eval algebra.
data HalogenF s act ps o m a
  = State (s -> Tuple a s)
  | Subscribe (SubscriptionId -> ES.EventSource m act) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | ChildQuery (CQ.ChildQueryBox ps a)
  | Raise o a
  | Par (HalogenAp s act ps o m a)
  | Fork (HalogenM' s act ps o m Unit) (ForkId -> a)
  | Kill ForkId a
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s act ps o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes k -> Subscribe fes (f <<< k)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    ChildQuery cq -> ChildQuery (map f cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork hmu k -> Fork hmu (f <<< k)
    Kill fid a -> Kill fid (f a)
    GetRef p k -> GetRef p (f <<< k)

-- | The Halogen component eval effect monad.
newtype HalogenM' s act ps o m a = HalogenM (Free (HalogenF s act ps o m) a)

-- | The Halogen component eval effect monad, for components constructed with
-- | the `component` smart constructor. This is more constrained than
-- | `HalogenM'` as it only allows for query algebra actions (kind
-- | `Type -> Type` rather than `Type`).
type HalogenM s act = HalogenM' s (act Unit)

derive newtype instance functorHalogenM :: Functor (HalogenM' s act ps o m)
derive newtype instance applyHalogenM :: Apply (HalogenM' s act ps o m)
derive newtype instance applicativeHalogenM :: Applicative (HalogenM' s act ps o m)
derive newtype instance bindHalogenM :: Bind (HalogenM' s act ps o m)
derive newtype instance monadHalogenM :: Monad (HalogenM' s act ps o m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM' s act ps o m) where
  liftEffect = HalogenM <<< liftF <<< Lift <<< liftEffect

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM' s act ps o m) where
  liftAff = HalogenM <<< liftF <<< Lift <<< liftAff

instance parallelHalogenM :: Parallel (HalogenAp s act ps o m) (HalogenM' s act ps o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM' s act ps o) where
  lift = HalogenM <<< liftF <<< Lift

instance monadRecHalogenM :: MonadRec (HalogenM' s act ps o m) where
  tailRecM k a = k a >>= case _ of
    Loop x -> tailRecM k x
    Done y -> pure y

instance monadStateHalogenM :: MonadState s (HalogenM' s act ps o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM' s act ps o m) where
  ask = HalogenM $ liftF $ Lift ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM' s act ps o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

instance monadThrowHalogenM :: MonadThrow e m => MonadThrow e (HalogenM' s act ps o m) where
  throwError = HalogenM <<< liftF <<< Lift <<< throwError

-- | An applicative-only version of `HalogenM` to allow for parallel evaluation.
newtype HalogenAp s act ps o m a = HalogenAp (FreeAp (HalogenM' s act ps o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f ps o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f ps o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f ps o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f ps o m)

-- | The ID value associated with a subscription. Allows the subscription to be
-- | stopped at a later time.
newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

-- | Subscribes a component to an `EventSource`.
subscribe :: forall s act ps o m. ES.EventSource m act -> HalogenM' s act ps o m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
subscribe' :: forall s act ps o m. (SubscriptionId -> ES.EventSource m act) -> HalogenM' s act ps o m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

-- | Unsubscribes a component from an `EventSource`. If the subscription
-- | associated with the ID has already ended this will have no effect.
unsubscribe :: forall s act ps o m. SubscriptionId -> HalogenM' s act ps o m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> f a
  -> HalogenM' s act ps o m (Maybe a)
query sym p q = HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
  CQ.ChildQuery (\k -> traverse k <<< Slot.lookup sym p) q identity

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> f a
  -> HalogenM' s act ps o m (Map p a)
queryAll sym q = HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
  CQ.ChildQuery (\k -> traverse k <<< Slot.slots sym) q identity

getRef :: forall s act ps o m. RefLabel -> HalogenM' s act ps o m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

-- | Raises an output message for the component.
raise :: forall s act ps o m. o -> HalogenM' s act ps o m Unit
raise o = HalogenM $ liftF $ Raise o unit

newtype ForkId = ForkId Int

derive newtype instance eqForkId :: Eq ForkId
derive newtype instance ordForkId :: Ord ForkId

fork :: forall s act ps o m. HalogenM' s act ps o m Unit -> HalogenM' s act ps o m ForkId
fork hmu = HalogenM $ liftF $ Fork hmu identity

kill :: forall s act ps o m. ForkId -> HalogenM' s act ps o m Unit
kill fid = HalogenM $ liftF $ Kill fid unit

imapState
  :: forall s s' act ps o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM' s act ps o m
  ~> HalogenM' s' act ps o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s' act ps o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork hmu k -> Fork (imapState f f' hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapAction
  :: forall s act act' ps o m
   . Functor m
  => (act -> act')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act' ps o m
mapAction f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act' ps o m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe (map f <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapAction f)) p)
    Fork hmu k -> Fork (mapAction f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapOutput
  :: forall s act ps o o' m
   . (o -> o')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o' m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork hmu k -> Fork (mapOutput f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

hoist
  :: forall s act ps o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o m'
  go = case _ of
    State f -> State f
    Subscribe fes k -> Subscribe (ES.hoist nat <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork hmu k -> Fork (hoist nat hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Halogen.Data.Slot (Slot)
import Halogen.Data.Slot as Slot
import Halogen.Query.ChildQuery as CQ
import Halogen.Query.EventSource as ES
import Halogen.Query.Input (RefLabel)
import Prim.Row as Row
import Web.DOM (Element)

-- | The Halogen component eval algebra.
data HalogenF s act ps o m a
  = State (s -> Tuple a s)
  | Subscribe (SubscriptionId -> ES.EventSource m act) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | ChildQuery (CQ.ChildQueryBox ps a)
  | Raise o a
  | Par (HalogenAp s act ps o m a)
  | Fork (HalogenM' s act ps o m Unit) (ForkId -> a)
  | Kill ForkId a
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s act ps o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes k -> Subscribe fes (f <<< k)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    ChildQuery cq -> ChildQuery (map f cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork hmu k -> Fork hmu (f <<< k)
    Kill fid a -> Kill fid (f a)
    GetRef p k -> GetRef p (f <<< k)

-- | The Halogen component eval effect monad.
newtype HalogenM' s act ps o m a = HalogenM (Free (HalogenF s act ps o m) a)

-- | The Halogen component eval effect monad, for components constructed with
-- | the `component` smart constructor. This is more constrained than
-- | `HalogenM'` as it only allows for query algebra actions (kind
-- | `Type -> Type` rather than `Type`).
type HalogenM s act = HalogenM' s (act Unit)

derive newtype instance functorHalogenM :: Functor (HalogenM' s act ps o m)
derive newtype instance applyHalogenM :: Apply (HalogenM' s act ps o m)
derive newtype instance applicativeHalogenM :: Applicative (HalogenM' s act ps o m)
derive newtype instance bindHalogenM :: Bind (HalogenM' s act ps o m)
derive newtype instance monadHalogenM :: Monad (HalogenM' s act ps o m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM' s act ps o m) where
  liftEffect = HalogenM <<< liftF <<< Lift <<< liftEffect

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM' s act ps o m) where
  liftAff = HalogenM <<< liftF <<< Lift <<< liftAff

instance parallelHalogenM :: Parallel (HalogenAp s act ps o m) (HalogenM' s act ps o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM' s act ps o) where
  lift = HalogenM <<< liftF <<< Lift

instance monadRecHalogenM :: MonadRec (HalogenM' s act ps o m) where
  tailRecM k a = k a >>= case _ of
    Loop x -> tailRecM k x
    Done y -> pure y

instance monadStateHalogenM :: MonadState s (HalogenM' s act ps o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM' s act ps o m) where
  ask = HalogenM $ liftF $ Lift ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM' s act ps o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

instance monadThrowHalogenM :: MonadThrow e m => MonadThrow e (HalogenM' s act ps o m) where
  throwError = HalogenM <<< liftF <<< Lift <<< throwError

-- | An applicative-only version of `HalogenM` to allow for parallel evaluation.
newtype HalogenAp s act ps o m a = HalogenAp (FreeAp (HalogenM' s act ps o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f ps o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f ps o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f ps o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f ps o m)

-- | The ID value associated with a subscription. Allows the subscription to be
-- | stopped at a later time.
newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

-- | Subscribes a component to an `EventSource`.
subscribe :: forall s act ps o m. ES.EventSource m act -> HalogenM' s act ps o m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
subscribe' :: forall s act ps o m. (SubscriptionId -> ES.EventSource m act) -> HalogenM' s act ps o m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

-- | Unsubscribes a component from an `EventSource`. If the subscription
-- | associated with the ID has already ended this will have no effect.
unsubscribe :: forall s act ps o m. SubscriptionId -> HalogenM' s act ps o m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> f a
  -> HalogenM' s act ps o m (Maybe a)
query sym p q = HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
  CQ.ChildQuery (\k -> traverse k <<< Slot.lookup sym p) q identity

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> f a
  -> HalogenM' s act ps o m (Map p a)
queryAll sym q = HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
  CQ.ChildQuery (\k -> traverse k <<< Slot.slots sym) q identity

getRef :: forall s act ps o m. RefLabel -> HalogenM' s act ps o m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

-- | Raises an output message for the component.
raise :: forall s act ps o m. o -> HalogenM' s act ps o m Unit
raise o = HalogenM $ liftF $ Raise o unit

newtype ForkId = ForkId Int

derive newtype instance eqForkId :: Eq ForkId
derive newtype instance ordForkId :: Ord ForkId

fork :: forall s act ps o m. MonadAff m => HalogenM' s act ps o m Unit -> HalogenM' s act ps o m ForkId
fork hmu = HalogenM $ liftF $ Fork hmu identity

kill :: forall s act ps o m. MonadAff m => ForkId -> HalogenM' s act ps o m Unit
kill fid = HalogenM $ liftF $ Kill fid unit

imapState
  :: forall s s' act ps o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM' s act ps o m
  ~> HalogenM' s' act ps o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s' act ps o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork hmu k -> Fork (imapState f f' hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapAction
  :: forall s act act' ps o m
   . Functor m
  => (act -> act')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act' ps o m
mapAction f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act' ps o m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe (map f <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapAction f)) p)
    Fork hmu k -> Fork (mapAction f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapOutput
  :: forall s act ps o o' m
   . (o -> o')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o' m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork hmu k -> Fork (mapOutput f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

hoist
  :: forall s act ps o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o m'
  go = case _ of
    State f -> State f
    Subscribe fes k -> Subscribe (ES.hoist nat <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork hmu k -> Fork (hoist nat hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k


Make ExceptT's apply/applicative consistent with bind

-- | This module defines the _exception monad transformer_ `ExceptT`.

module Control.Monad.Except.Trans
  ( ExceptT(..), runExceptT, withExceptT, mapExceptT, except
  , module Control.Monad.Trans.Class
  , module Control.Monad.Error.Class
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Cont.Class (class MonadCont, callCC)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.Reader.Class (class MonadAsk, class MonadReader, ask, local)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState, state)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.Monad.Writer.Class (class MonadWriter, class MonadTell, pass, listen, tell)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)

import Data.Either (Either(..), either)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..))

-- | A monad transformer which adds exceptions to other monads, in the same way
-- | as `Except`. As before, `e` is the type of exceptions, and `a` is the type
-- | of successful results. The new type parameter `m` is the inner monad that
-- | computations run in.
newtype ExceptT e m a = ExceptT (m (Either e a))

-- | The inverse of `ExceptT`. Run a computation in the `ExceptT` monad.
runExceptT :: forall e m a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT x) = x

-- | Transform any exceptions thrown by an `ExceptT` computation using the given function.
withExceptT :: forall e e' m a. Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f (ExceptT t) = ExceptT $ map (mapLeft f) t
  where
  mapLeft _ (Right x) = Right x
  mapLeft f (Left x) = Left (f x)

-- | Transform the unwrapped computation using the given function.
mapExceptT :: forall e e' m n a b. (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f (ExceptT m) = ExceptT (f m)

-- | Construct a computation in the `ExceptT` transformer from an `Either` value.
except :: forall e m a. Applicative m => Either e a -> ExceptT e m a
except = ExceptT <<< pure

derive instance newtypeExceptT :: Newtype (ExceptT e m a) _

instance functorExceptT :: Functor m => Functor (ExceptT e m) where
  map f = mapExceptT (map (map f))

instance applyExceptT :: Monad m => Apply (ExceptT e m) where
  apply = ap

instance applicativeExceptT :: Monad m => Applicative (ExceptT e m) where
  pure = ExceptT <<< pure <<< Right

instance bindExceptT :: Monad m => Bind (ExceptT e m) where
  bind (ExceptT m) k =
    ExceptT (m >>= either (pure <<< Left) (\a -> case k a of ExceptT b -> b))

instance monadExceptT :: Monad m => Monad (ExceptT e m)

instance monadRecExceptT :: MonadRec m => MonadRec (ExceptT e m) where
  tailRecM f = ExceptT <<< tailRecM \a ->
    case f a of ExceptT m ->
      m >>= \m' ->
        pure case m' of
          Left e -> Done (Left e)
          Right (Loop a1) -> Loop a1
          Right (Done b) -> Done (Right b)

instance altExceptT :: (Semigroup e, Monad m) => Alt (ExceptT e m) where
  alt (ExceptT m) (ExceptT n) = ExceptT do
    rm <- m
    case rm of
      Right x -> pure (Right x)
      Left err -> do
        rn <- n
        case rn of
          Right x -> pure (Right x)
          Left err' -> pure (Left (err <> err'))

instance plusExceptT :: (Monoid e, Monad m) => Plus (ExceptT e m) where
  empty = throwError (mempty :: e)

instance alternativeExceptT :: (Monoid e, Monad m) => Alternative (ExceptT e m)

instance monadPlusExceptT :: (Monoid e, Monad m) => MonadPlus (ExceptT e m)

instance monadZeroExceptT :: (Monoid e, Monad m) => MonadZero (ExceptT e m)

instance monadTransExceptT :: MonadTrans (ExceptT e) where
  lift m = ExceptT do
    a <- m
    pure $ Right a

instance monadEffExceptT :: MonadEff eff m => MonadEff eff (ExceptT e m) where
  liftEff = lift <<< liftEff

instance monadContExceptT :: MonadCont m => MonadCont (ExceptT e m) where
  callCC f = ExceptT $ callCC \c ->
    case f (\a -> ExceptT $ c (Right a)) of ExceptT b -> b

instance monadErrorExceptT :: Monad m => MonadError e (ExceptT e m) where
  throwError = ExceptT <<< pure <<< Left
  catchError (ExceptT m) k =
    ExceptT (m >>= either (\a -> case k a of ExceptT b -> b) (pure <<< Right))

instance monadAskExceptT :: MonadAsk r m => MonadAsk r (ExceptT e m) where
  ask = lift ask

instance monadReaderExceptT :: MonadReader r m => MonadReader r (ExceptT e m) where
  local f = mapExceptT (local f)

instance monadStateExceptT :: MonadState s m => MonadState s (ExceptT e m) where
  state f = lift (state f)

instance monadTellExceptT :: MonadTell w m => MonadTell w (ExceptT e m) where
  tell = lift <<< tell

instance monadWriterExceptT :: MonadWriter w m => MonadWriter w (ExceptT e m) where
  listen = mapExceptT \m -> do
    Tuple a w <- listen m
    pure $ (\r -> Tuple r w) <$> a
  pass = mapExceptT \m -> pass do
    a <- m
    pure case a of
      Left e -> Tuple (Left e) id
      Right (Tuple r f) -> Tuple (Right r) f

-- | This module defines the _exception monad transformer_ `ExceptT`.

module Control.Monad.Except.Trans
  ( ExceptT(..), runExceptT, withExceptT, mapExceptT, except
  , module Control.Monad.Trans.Class
  , module Control.Monad.Error.Class
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Cont.Class (class MonadCont, callCC)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Error.Class (class MonadError, throwError, catchError)
import Control.Monad.Reader.Class (class MonadAsk, class MonadReader, ask, local)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState, state)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.Monad.Writer.Class (class MonadWriter, class MonadTell, pass, listen, tell)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)

import Data.Either (Either(..), either)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..))

-- | A monad transformer which adds exceptions to other monads, in the same way
-- | as `Except`. As before, `e` is the type of exceptions, and `a` is the type
-- | of successful results. The new type parameter `m` is the inner monad that
-- | computations run in.
newtype ExceptT e m a = ExceptT (m (Either e a))

-- | The inverse of `ExceptT`. Run a computation in the `ExceptT` monad.
runExceptT :: forall e m a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT x) = x

-- | Transform any exceptions thrown by an `ExceptT` computation using the given function.
withExceptT :: forall e e' m a. Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f (ExceptT t) = ExceptT $ map (mapLeft f) t
  where
  mapLeft _ (Right x) = Right x
  mapLeft f (Left x) = Left (f x)

-- | Transform the unwrapped computation using the given function.
mapExceptT :: forall e e' m n a b. (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f (ExceptT m) = ExceptT (f m)

-- | Construct a computation in the `ExceptT` transformer from an `Either` value.
except :: forall e m a. Applicative m => Either e a -> ExceptT e m a
except = ExceptT <<< pure

derive instance newtypeExceptT :: Newtype (ExceptT e m a) _

instance functorExceptT :: Functor m => Functor (ExceptT e m) where
  map f = mapExceptT (map (map f))

instance applyExceptT :: Apply m => Apply (ExceptT e m) where
  apply (ExceptT f) (ExceptT x) =
    let f' = apply <$> f
        x' = f' <*> x
    in ExceptT x'

instance applicativeExceptT :: Applicative m => Applicative (ExceptT e m) where
  pure = ExceptT <<< pure <<< Right

instance bindExceptT :: Monad m => Bind (ExceptT e m) where
  bind (ExceptT m) k =
    ExceptT (m >>= either (pure <<< Left) (\a -> case k a of ExceptT b -> b))

instance monadExceptT :: Monad m => Monad (ExceptT e m)

instance monadRecExceptT :: MonadRec m => MonadRec (ExceptT e m) where
  tailRecM f = ExceptT <<< tailRecM \a ->
    case f a of ExceptT m ->
      m >>= \m' ->
        pure case m' of
          Left e -> Done (Left e)
          Right (Loop a1) -> Loop a1
          Right (Done b) -> Done (Right b)

instance altExceptT :: (Semigroup e, Monad m) => Alt (ExceptT e m) where
  alt (ExceptT m) (ExceptT n) = ExceptT do
    rm <- m
    case rm of
      Right x -> pure (Right x)
      Left err -> do
        rn <- n
        case rn of
          Right x -> pure (Right x)
          Left err' -> pure (Left (err <> err'))

instance plusExceptT :: (Monoid e, Monad m) => Plus (ExceptT e m) where
  empty = throwError (mempty :: e)

instance alternativeExceptT :: (Monoid e, Monad m) => Alternative (ExceptT e m)

instance monadPlusExceptT :: (Monoid e, Monad m) => MonadPlus (ExceptT e m)

instance monadZeroExceptT :: (Monoid e, Monad m) => MonadZero (ExceptT e m)

instance monadTransExceptT :: MonadTrans (ExceptT e) where
  lift m = ExceptT do
    a <- m
    pure $ Right a

instance monadEffExceptT :: MonadEff eff m => MonadEff eff (ExceptT e m) where
  liftEff = lift <<< liftEff

instance monadContExceptT :: MonadCont m => MonadCont (ExceptT e m) where
  callCC f = ExceptT $ callCC \c ->
    case f (\a -> ExceptT $ c (Right a)) of ExceptT b -> b

instance monadErrorExceptT :: Monad m => MonadError e (ExceptT e m) where
  throwError = ExceptT <<< pure <<< Left
  catchError (ExceptT m) k =
    ExceptT (m >>= either (\a -> case k a of ExceptT b -> b) (pure <<< Right))

instance monadAskExceptT :: MonadAsk r m => MonadAsk r (ExceptT e m) where
  ask = lift ask

instance monadReaderExceptT :: MonadReader r m => MonadReader r (ExceptT e m) where
  local f = mapExceptT (local f)

instance monadStateExceptT :: MonadState s m => MonadState s (ExceptT e m) where
  state f = lift (state f)

instance monadTellExceptT :: MonadTell w m => MonadTell w (ExceptT e m) where
  tell = lift <<< tell

instance monadWriterExceptT :: MonadWriter w m => MonadWriter w (ExceptT e m) where
  listen = mapExceptT \m -> do
    Tuple a w <- listen m
    pure $ (\r -> Tuple r w) <$> a
  pass = mapExceptT \m -> pass do
    a <- m
    pure case a of
      Left e -> Tuple (Left e) id
      Right (Tuple r f) -> Tuple (Right r) f


Use emojis

Use emojis

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

isPlaying :: forall state action. BoardView state action => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

type PitState = Maybe Turn

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

pitColor :: PitState -> Color
pitColor = go
  where go (Just Turn.Capture) = rotateHue 50.0 $ go (Just Turn.Lift)
        go (Just Turn.Lift) = rotateHue 100.0 $ go Nothing
        go (Just Turn.Sow) = lighten 0.3 $ go Nothing
        go _ = hsl 40.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = div [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = viewPlayer player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewPlayer :: Player -> String
viewPlayer player = "Player " <> show player <> " " <> viewPlayerEmoji (Just player)

viewPlayerEmoji :: Maybe Player -> String
viewPlayerEmoji (Just A) = "🐼"
viewPlayerEmoji (Just B) = "🐔"
viewPlayerEmoji Nothing = "❀"

viewCellEmoji :: forall action state. BoardView state action
              => state -> PitRef -> String
viewCellEmoji state ref = viewPlayerEmoji $ do
  hand <- getHand state
  if hand.pitRef == ref
    then pure hand.player
    else Nothing

viewCell :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewCell state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ viewCellEmoji state ref <> numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = Just $ style do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitColor $ pitState state ref
        padding = 0.5

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, show, ($), (<>), (<), (==), pure, (<$>), (<<<))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

isPlaying :: forall state action. BoardView state action => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

type PitState = Maybe Turn

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  turn <- getTurn state
  if ref == hand.pitRef
    then pure turn
    else Nothing

pitColor :: PitState -> Color
pitColor = go
  where go (Just Turn.Capture) = rotateHue 50.0 $ go (Just Turn.Lift)
        go (Just Turn.Lift) = rotateHue 100.0 $ go Nothing
        go (Just Turn.Sow) = lighten 0.3 $ go Nothing
        go _ = hsl 40.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = div [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewCell :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewCell state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = Just $ style do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitColor $ pitState state ref
        padding = 0.5

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a