put evalToBinding and recurse into a State Int monad

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 = StateT Int (ExceptT EvalError Identity)

runEvalM :: forall a. Int -> Evaluator a -> Either EvalError (Tuple a Int)
runEvalM idx = extract <<< runExceptT <<< flip runStateT idx

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 :: Int -> Env -> TypeTree -> Tuple TypeTree Int
eval nextIdx env expr = runState (evalToBinding env expr (Lit AST.emptyMeta (Name "_|_"))) nextIdx

freshMeta :: State Int Meta
freshMeta = do
  i <- get
  modify (\i -> i + 1)
  pure $ AST.idxMeta i

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

  (ConsLit _ b bs)     -> case expr of
    (Binary meta (Tuple Colon meta') e es) -> Binary meta (Tuple Colon meta') <$> evalToBinding env e b <*> evalToBinding env es bs
    (List _ (Cons e es))  -> do
      meta   <- freshMeta
      meta'  <- freshMeta
      meta'' <- freshMeta
      evalToBinding env (Binary meta (Tuple Colon meta') e (List meta'' es)) bind
    _                     -> recurse env expr bind

  (ListLit _ bs) -> case expr of
    (List meta es)
      | (length es == length bs) -> List meta <$> zipWithM (evalToBinding env) es bs -- TODO Define zipWithM
      | otherwise                -> pure expr
    _           -> recurse env expr bind

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

recurse :: Env -> TypeTree -> Binding Meta -> State Int TypeTree
recurse env expr bind = do
  e' <- expr'
  idx <- get
  eval1d <- case runEvalM (eval1 env e') i of
       Left _                -> pure e'
       Right (Tuple e' idx') -> do
         put idx'
         pure e'
  if expr == eval1d
     then pure expr
     else evalToBinding env eval1d bind
  where
    expr' :: State Int TypeTree
    expr' = case expr of
      (Binary meta op e1 e2)  ->
        Binary meta <$> pure op <*> evalToBinding env e1 bind <*> evalToBinding env e2 bind
      (Unary meta op e)       ->
        Unary meta <$> pure op <*> evalToBinding env e bind
      (List meta es)          ->
        List meta <$> mapM (\e -> evalToBinding env e bind) es
      (NTuple meta es)        ->
        NTuple meta <$> mapM (\e -> evalToBinding env e bind) es
      (IfExpr meta c t e)     ->
        IfExpr meta <$> evalToBinding env c bind <*> pure t <*> pure e
      (App meta c@(Atom _ (Constr _)) args) ->
        App meta <$> pure c <*> mapM (\e -> evalToBinding env e bind) args
      (App meta f args)       -> do
        App meta <$> evalToBinding env f bind <*> pure args
      (ArithmSeq meta c t e)     ->
        ArithmSeq meta <$> evalToBinding env c bind <*> mapM (\x -> evalToBinding env x bind) t <*> mapM (\x -> evalToBinding env x bind) e
      (ListComp meta e qs)    -> do
        ListComp meta <$> evalToBinding env e bind <*> mapM (\x -> evalToBindingQual env x bind) qs
      _                  -> pure expr

    evalToBindingQual :: Env -> TypeQual -> Binding Meta -> State Int TypeQual
    evalToBindingQual environment qual binding = case qual of
      Let meta b e -> Let meta b <$> evalToBinding environment e bind
      Gen meta b e -> Gen meta b <$> evalToBinding environment e bind
      Guard meta e -> Guard meta <$> 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 = StateT Int (ExceptT EvalError Identity)

runEvalM :: forall a. Int -> Evaluator a -> Either EvalError (Tuple a Int)
runEvalM idx = extract <<< runExceptT <<< flip runStateT idx

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 meta (Tuple Colon meta') e es) -> Binary meta (Tuple Colon meta') (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 meta es) -> if (length es == length bs) then List meta (zipWith (evalToBinding env) es bs) else expr
    _           -> recurse env expr bind

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

module comment

module Blueprint where

-- TODO: Lets import all the modules and re-export them within this module


Expand on 'uninhabitated data type' meaning for `Void`

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` becaue no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

-- | Eliminator for the `Void` type.
-- | Useful for stating that some code branch is impossible because you've
-- | "acquired" a value of type `Void` (which you can't).
-- |
-- | ```purescript
-- | rightOnly :: forall t . Either Void t -> t
-- | rightOnly (Left v) = absurd v
-- | rightOnly (Right t) = t
-- | ```
absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

-- | Eliminator for the `Void` type.
-- | Useful for stating that some code branch is impossible because you've
-- | "acquired" a value of type `Void` (which you can't).
-- |
-- | ```purescript
-- | rightOnly :: forall t . Either Void t -> t
-- | rightOnly (Left v) = absurd v
-- | rightOnly (Right t) = t
-- | ```
absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b


better map rendering

better map rendering

module Rendering where

import Debug.Trace
import Data.Array hiding (map, (..))
import Data.Function
import qualified Data.Map as M
import Data.Tuple
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
import Control.Monad.Eff
import Control.Monad (when)
import Control.Lens ((^.), (..))
import Math (pi, floor)

import LevelMap
import Types
import Utils

debug = false

pxPerBlock :: Number
pxPerBlock = 3

halfBlock :: Number
halfBlock = floor (pxPerBlock / 2)

pxPerTile :: Number
pxPerTile = pxPerBlock * tileSize

halfPxPerTile :: Number
halfPxPerTile = floor (pxPerTile / 2)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, h: scale, w: scale}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

-- the height and width of the canvas
canvasSize :: Number
canvasSize = pxPerBlock * LevelMap.mapSize

setupRendering :: forall e. Eff (canvas :: Canvas | e) RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  return { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: forall e.
  String -> Eff (canvas :: Canvas | e) Context2D
setupRenderingById elId =
  getCanvasElementById elId
    >>= setCanvasHeight canvasSize
    >>= setCanvasWidth canvasSize
    >>= getContext2D

clearBackground :: forall e.
  Context2D -> Eff (canvas :: Canvas | e) Unit
clearBackground ctx = do
  setFillStyle "hsl(200, 10%, 75%)" ctx
  void $ fillRect ctx {x: 0, y: 0, h: canvasSize, w: canvasSize}

foreign import renderMapDebugFFI
  """
  function renderMapDebugFFI(isEmpty, getBlockRect, getTileRect, ctx, map) {
    return function() {
      ctx.strokeStyle = 'hsl(40, 70%, 50%)'
      var t = map.tiles
      for (var i = 0; i < t.length; i++) {
        for (var j = 0; j < t[i].length; j++) {
          var r = getTileRect(i)(j)
          ctx.strokeRect(r.x, r.y, r.w, r.h)
        }
      }

      ctx.fillStyle = 'hsl(320, 20%, 10%)'
      var b = map.blocks
      for (var i = 0; i < b.length; i++) {
        for (var j = 0; j < b[i].length; j++) {
          if (isEmpty(b[i][j])) {
            var r = getBlockRect(i)(j)
            ctx.fillRect(r.x, r.y, r.w, r.h)
          }
        }
      }
    }
  }
  """ :: forall e.
  Fn5
    (Block -> Boolean)
    (Number -> Number -> Rectangle)
    (Number -> Number -> Rectangle)
    Context2D
    LevelMap
    (Eff (canvas :: Canvas | e) Unit)

renderMapDebug :: forall e.
  Context2D
  -> LevelMap
  -> Eff (canvas :: Canvas | e) Unit
renderMapDebug ctx map = do
  clearBackground ctx
  runFn5 renderMapDebugFFI (not .. isWall) getRectAt' getTileRectAt' ctx map

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e.
  Context2D
  -> LevelMap
  -> Eff (trace :: Trace, canvas :: Canvas | e) Unit
renderMap ctx map = do
  setStrokeStyle "hsl(200, 80%, 40%)" ctx
  strokeRect ctx {x:0, y:0, w: canvasSize, h: canvasSize}

  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above = fromMaybe W $ t i (j-1)
      let below = fromMaybe W $ t i (j+1)
      let right = fromMaybe W $ t (i+1) j
      let left  = fromMaybe W $ t (i-1) j

      case t i j of
        Just W -> do
          let cs = getCorners above right below left
          let es = getEdges above right below left
          withContext ctx $ do
            translate {translateX: (i + 0.5) * pxPerTile
                      , translateY: (j + 0.5) * pxPerTile} ctx
            renderCorners ctx cs
            renderEdges ctx es
        _ ->
          return unit

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" .:: cs.tl, "tr" .:: cs.tr, "br" .:: cs.br, "bl" .:: cs.bl]

getCorners :: BasicTile -> BasicTile -> BasicTile -> BasicTile -> Corners
getCorners above right below left =
  { tl: getCorner left above
  , tr: getCorner right above
  , br: getCorner right below
  , bl: getCorner left below
  }

-- order is: horizontal vertical
getCorner :: BasicTile -> BasicTile -> CornerType
getCorner W W = CRI
getCorner W E = CSH
getCorner E W = CSV
getCorner E E = CRO

cornerSize = 9
cornerMid = floor (cornerSize / 2)
cornerRadius = cornerMid

renderCorners :: forall e.
  Context2D
  -> Corners
  -> Eff (trace :: Trace, canvas :: Canvas | e) Unit
renderCorners ctx cs = do
  let renderCorner ctx c a t =
    case c of
        CRO ->
          { prep: do
              translate t ctx
              rotate a ctx
          , go:
              arc ctx
                { start: pi
                , end:   3*pi/2
                , x:     cornerMid
                , y:     cornerMid
                , r:     cornerRadius
                }
          }
        CRI ->
          { prep: do
              translate t ctx
              rotate a ctx
          , go:
              arc ctx
                { start: 0
                , end:   pi/2
                , x:     -cornerMid
                , y:     -cornerMid
                , r:     cornerRadius
                }
          }
        CSH ->
          { prep: translate t ctx
          , go: do
              moveTo ctx (-cornerMid - 1) 0
              lineTo ctx (cornerMid + 1) 0
          }
        CSV ->
          { prep: translate t ctx
          , go: do
              moveTo ctx 0 (-cornerMid - 1)
              lineTo ctx 0 (cornerMid + 1)
          }

  let s = (pxPerTile - cornerSize) / 2
  let cs' =
      [ { c: cs.tl
        , a: 0
        , t: {translateX: -s, translateY: -s}
        },

        { c: cs.tr
        , a: pi/2
        , t: {translateX: s, translateY: -s}
        },

        { c: cs.br
        , a: pi
        , t: {translateX: s, translateY: s}
        },

        { c: cs.bl
        , a: 3*pi/2
        , t: {translateX: -s, translateY: s}
        }
        ]

  for_ cs' $ \c -> do
    withContext ctx $ do
      let r = renderCorner ctx c.c c.a c.t
      r.prep
      beginPath ctx
      r.go
      stroke ctx

getEdges above right below left =
  { t: above, r: right, b: below, l: left }

renderEdges ctx es =
  let s = (pxPerTile / 2) - cornerSize
      x1 = -s - 1
      y1 = -s - (cornerSize / 2)
      x2 = s
      y2 = y1

      renderEdge ctx e =
        case e of
          W -> return unit
          E -> do
            moveTo ctx x1 y1
            void $ lineTo ctx x2 y2

      es' =
        [ { e: es.t, a: 0 }
        , { e: es.r, a: pi/2 }
        , { e: es.b, a: pi }
        , { e: es.l, a: 3*pi/2 }
        ]

  in
  for_ es' $ \e ->
    withContext ctx $ do
      rotate e.a ctx
      beginPath ctx
      renderEdge ctx e.e
      stroke ctx

renderPlayer :: forall e.
  Context2D
  -> PlayerId
  -> Player
  -> Eff (canvas :: Canvas | e) Unit
renderPlayer ctx pId player =
  void $ do
    setFillStyle (fillStyleFor pId) ctx
    let centre = getCentredRectAt (player ^. position)
    beginPath ctx
    arc ctx {x: centre.x, y: centre.y, start: 0, end: 2 * pi, r: 13}
    fill ctx

clearPlayer :: forall e.
  Context2D
  -> PlayerId
  -> Player
  -> Eff (canvas :: Canvas | e) Unit
clearPlayer ctx pId player =
  void $ clearRect ctx (enlargeRect 5 $ getRectAt (player ^. position))

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , w: r.w + (2 * delta)
  , h: r.h + (2 * delta)
  }

fillStyleFor :: PlayerId -> String
fillStyleFor P1 = "hsl(0, 100%, 60%)"
fillStyleFor P2 = "hsl(90, 100%, 60%)"
fillStyleFor P3 = "hsl(180, 100%, 60%)"
fillStyleFor P4 = "hsl(270, 100%, 60%)"

renderPlayers :: forall e.
  Context2D
  -> Game
  -> Eff (canvas :: Canvas | e) Unit
renderPlayers ctx game = do
  eachPlayer' game $ renderPlayer ctx

clearPreviousPlayers :: forall e.
  Context2D
  -> Game
  -> Eff (canvas :: Canvas | e) Unit
clearPreviousPlayers ctx game =
  void $ clearRect ctx {x: 0, y: 0, h: canvasSize, w: canvasSize}

render :: forall e.
  RenderingContext
  -> ClientState
  -> Eff (trace :: Trace, canvas :: Canvas | e) Unit
render ctx state = do
  when state.redrawMap $ do
    when debug $ renderMapDebug ctx.background state.game.map
    renderMap ctx.background state.game.map
  clearPreviousPlayers ctx.foreground state.prevGame
  renderPlayers ctx.foreground state.game

module Rendering where

import Debug.Trace
import Data.Array hiding (map, (..))
import Data.Function
import qualified Data.Map as M
import Data.Tuple
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
import Control.Monad.Eff
import Control.Monad (when)
import Control.Lens ((^.), (..))
import Math (pi, floor)

import LevelMap
import Types
import Utils

debug = true

pxPerBlock :: Number
pxPerBlock = 3

halfBlock :: Number
halfBlock = floor (pxPerBlock / 2)

pxPerTile :: Number
pxPerTile = pxPerBlock * tileSize

halfPxPerTile :: Number
halfPxPerTile = floor (pxPerTile / 2)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, h: scale, w: scale}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

-- the height and width of the canvas
canvasSize :: Number
canvasSize = pxPerBlock * LevelMap.mapSize

setupRendering :: forall e. Eff (canvas :: Canvas | e) RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  return { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: forall e.
  String -> Eff (canvas :: Canvas | e) Context2D
setupRenderingById elId =
  getCanvasElementById elId
    >>= setCanvasHeight canvasSize
    >>= setCanvasWidth canvasSize
    >>= getContext2D

clearBackground :: forall e.
  Context2D -> Eff (canvas :: Canvas | e) Unit
clearBackground ctx = do
  setFillStyle "hsl(200, 10%, 75%)" ctx
  void $ fillRect ctx {x: 0, y: 0, h: canvasSize, w: canvasSize}

foreign import renderMapDebugFFI
  """
  function renderMapDebugFFI(isEmpty, getBlockRect, getTileRect, ctx, map) {
    return function() {
      ctx.strokeStyle = 'hsl(40, 70%, 50%)'
      var t = map.tiles
      for (var i = 0; i < t.length; i++) {
        for (var j = 0; j < t[i].length; j++) {
          var r = getTileRect(i)(j)
          ctx.strokeRect(r.x, r.y, r.w, r.h)
        }
      }

      ctx.fillStyle = 'hsl(320, 20%, 10%)'
      var b = map.blocks
      for (var i = 0; i < b.length; i++) {
        for (var j = 0; j < b[i].length; j++) {
          if (isEmpty(b[i][j])) {
            var r = getBlockRect(i)(j)
            ctx.fillRect(r.x, r.y, r.w, r.h)
          }
        }
      }
    }
  }
  """ :: forall e.
  Fn5
    (Block -> Boolean)
    (Number -> Number -> Rectangle)
    (Number -> Number -> Rectangle)
    Context2D
    LevelMap
    (Eff (canvas :: Canvas | e) Unit)

renderMapDebug :: forall e.
  Context2D
  -> LevelMap
  -> Eff (canvas :: Canvas | e) Unit
renderMapDebug ctx map = do
  clearBackground ctx
  runFn5 renderMapDebugFFI (not .. isWall) getRectAt' getTileRectAt' ctx map

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e.
  Context2D
  -> LevelMap
  -> Eff (trace :: Trace, canvas :: Canvas | e) Unit
renderMap ctx map = do
  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above = fromMaybe W $ t i (j-1)
      let below = fromMaybe W $ t i (j+1)
      let right = fromMaybe W $ t (i+1) j
      let left  = fromMaybe W $ t (i-1) j

      case t i j of
        Just W -> do
          let cs = getCorners above right below left
          withContext ctx $ do
            translate {translateX: (i + 0.5) * pxPerTile
                      , translateY: (j + 0.5) * pxPerTile} ctx
            renderCorners ctx cs
        _ ->
          return unit

renderMapTemp ctx map =
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
      t i j = toBasic <$> getTile i j
      i = 1
      j = 1
      above = fromMaybe W $ t i (j-1)
      below = fromMaybe W $ t i (j+1)
      right = fromMaybe W $ t (i+1) j
      left  = fromMaybe W $ t (i-1) j
      cs = getCorners above right below left

  in do
    withContext ctx $ do
      translate { translateX: 1.5 * pxPerTile, translateY: 1.5 * pxPerTile } ctx
      renderCorners ctx cs

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" .:: cs.tl, "tr" .:: cs.tr, "br" .:: cs.br, "bl" .:: cs.bl]

getCorners :: BasicTile -> BasicTile -> BasicTile -> BasicTile -> Corners
getCorners above right below left =
  { tl: getCorner left above
  , tr: getCorner right above
  , br: getCorner right below
  , bl: getCorner left below
  }

-- order is: horizontal vertical
getCorner :: BasicTile -> BasicTile -> CornerType
getCorner W W = CRI
getCorner W E = CSH
getCorner E W = CSV
getCorner E E = CRO

renderCorners :: forall e.
  Context2D
  -> Corners
  -> Eff (trace :: Trace, canvas :: Canvas | e) Unit
renderCorners ctx cs = do
  setStrokeStyle "hsl(200, 80%, 40%)" ctx
  let cornerSize = 9
  let cornerMid = floor (cornerSize / 2)
  let cornerRadius = cornerMid

  -- these are the instructions for the top left corner. Others will
  -- need to be rotated
  let renderCorner ctx c a t =
    case c of
        CRO ->
          { prep: do
              translate t ctx
              rotate a ctx
          , go:
              arc ctx
                { start: pi
                , end:   3*pi/2
                , x:     cornerMid
                , y:     cornerMid
                , r:     cornerRadius
                }
          }
        CRI ->
          { prep: do
              translate t ctx
              rotate a ctx
          , go:
              arc ctx
                { start: pi/2
                , end:   0
                , x:     0
                , y:     0
                , r:     cornerRadius
                }
          }
        CSH ->
          { prep: translate t ctx
          , go: do
              moveTo ctx (-cornerMid) 0
              lineTo ctx cornerMid 0
          }
        CSV ->
          { prep: translate t ctx
          , go: do
              moveTo ctx 0 (-cornerMid)
              lineTo ctx 0 cornerMid
          }

  let s = (pxPerTile - cornerSize) / 2
  let cs' =
      [ { c: cs.tl
        , a: 0
        , t: {translateX: -s, translateY: -s}
        },

        { c: cs.tr
        , a: pi/2
        , t: {translateX: s, translateY: -s}
        },

        { c: cs.br
        , a: pi
        , t: {translateX: s, translateY: s}
        },

        { c: cs.bl
        , a: 3*pi/2
        , t: {translateX: -s, translateY: s}
        }
        ]

  for_ cs' $ \c -> do
    withContext ctx $ do
      let r = renderCorner ctx c.c c.a c.t
      r.prep
      beginPath ctx
      r.go
      stroke ctx

renderPlayer :: forall e.
  Context2D
  -> PlayerId
  -> Player
  -> Eff (canvas :: Canvas | e) Unit
renderPlayer ctx pId player =
  void $ do
    setFillStyle (fillStyleFor pId) ctx
    let centre = getCentredRectAt (player ^. position)
    beginPath ctx
    arc ctx {x: centre.x, y: centre.y, start: 0, end: 2 * pi, r: 9}
    fill ctx

clearPlayer :: forall e.
  Context2D
  -> PlayerId
  -> Player
  -> Eff (canvas :: Canvas | e) Unit
clearPlayer ctx pId player =
  void $ clearRect ctx (enlargeRect 5 $ getRectAt (player ^. position))

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , w: r.w + (2 * delta)
  , h: r.h + (2 * delta)
  }

fillStyleFor :: PlayerId -> String
fillStyleFor P1 = "hsl(0, 100%, 60%)"
fillStyleFor P2 = "hsl(90, 100%, 60%)"
fillStyleFor P3 = "hsl(180, 100%, 60%)"
fillStyleFor P4 = "hsl(270, 100%, 60%)"

renderPlayers :: forall e.
  Context2D
  -> Game
  -> Eff (canvas :: Canvas | e) Unit
renderPlayers ctx game = do
  eachPlayer' game $ renderPlayer ctx

clearPreviousPlayers :: forall e.
  Context2D
  -> Game
  -> Eff (canvas :: Canvas | e) Unit
clearPreviousPlayers ctx game =
  void $ clearRect ctx {x: 0, y: 0, h: canvasSize, w: canvasSize}

render :: forall e.
  RenderingContext
  -> ClientState
  -> Eff (trace :: Trace, canvas :: Canvas | e) Unit
render ctx state = do
  when state.redrawMap $ do
    when debug $ renderMapDebug ctx.background state.game.map
    renderMap ctx.background state.game.map
  clearPreviousPlayers ctx.foreground state.prevGame
  renderPlayers ctx.foreground state.game


Break execution context for each `it` action

Fixes #24

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  describe,
  pending,
  it,
  collect
  ) where

import Prelude

import Control.Monad.Aff           (Aff(), attempt, later)
import Control.Monad.Eff.Exception (Error())
import Control.Monad.State.Class   (modify)
import Control.Monad.State.Trans   (StateT(), runStateT)
import Control.Monad.Trans         (lift)
import Data.Either                 (either)
import Data.Monoid                 (Monoid)
import Data.Tuple                  (snd)

type Name = String

data Result = Success
            | Failure Error

data Group = Describe Name (Array Group)
           | It Name Result
           | Pending Name

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  eq Success Success = true
  eq (Failure _) (Failure _) = true
  eq _ _ = false

instance showGroup :: Show Group where
  show (Describe name groups) = "Describe " ++ show name ++ " " ++ show groups
  show (It name result) = "It " ++ show name ++ " " ++ show result
  show (Pending name) = "Describe " ++ show name

instance eqGroup :: Eq Group where
  eq (Describe n1 g1) (Describe n2 g2) = n1 == n2 && g1 == g2
  eq (It n1 r1)       (It n2 r2)       = n1 == n2 && r1 == r2
  eq (Pending n1)     (Pending n2)     = n1 == n2
  eq _                _                = false

type Spec r t = StateT (Array Group) (Aff r) t

describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe name its = do
  results <- lift $ collect its
  modify $ \r -> r ++ [Describe name results]
  return unit

pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p ++ [Pending name]

runCatch :: forall r. String
         -> Aff r Unit
         -> Aff r Group
runCatch name tests = do
  e <- attempt tests
  either onError onSuccess e
  where
  onError e = return $ It name $ Failure e
  onSuccess _ = return $ It name Success

it :: forall r. String
    -> Aff r Unit
    -> Spec r Unit
it description tests =
  do
    result <- lift $ later $ runCatch description tests
    modify $ \p -> p ++ [result]
    return unit

collect :: forall r. Spec r Unit
        -> Aff r (Array Group)
collect r = do
  c <- runStateT r []
  return $ snd c

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  describe,
  pending,
  it,
  collect
  ) where

import Prelude

import Control.Monad.Aff           (Aff(), attempt)
import Control.Monad.Eff.Exception (Error())
import Control.Monad.State.Class   (modify)
import Control.Monad.State.Trans   (StateT(), runStateT)
import Control.Monad.Trans         (lift)
import Data.Either                 (either)
import Data.Monoid                 (Monoid)
import Data.Tuple                  (snd)

type Name = String

data Result = Success
            | Failure Error

data Group = Describe Name (Array Group)
           | It Name Result
           | Pending Name

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  eq Success Success = true
  eq (Failure _) (Failure _) = true
  eq _ _ = false

instance showGroup :: Show Group where
  show (Describe name groups) = "Describe " ++ show name ++ " " ++ show groups
  show (It name result) = "It " ++ show name ++ " " ++ show result
  show (Pending name) = "Describe " ++ show name

instance eqGroup :: Eq Group where
  eq (Describe n1 g1) (Describe n2 g2) = n1 == n2 && g1 == g2
  eq (It n1 r1)       (It n2 r2)       = n1 == n2 && r1 == r2
  eq (Pending n1)     (Pending n2)     = n1 == n2
  eq _                _                = false

type Spec r t = StateT (Array Group) (Aff r) t

describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe name its = do
  results <- lift $ collect its
  modify $ \r -> r ++ [Describe name results]
  return unit

pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p ++ [Pending name]

runCatch :: forall r. String
         -> Aff r Unit
         -> Aff r Group
runCatch name tests = do
  e <- attempt tests
  either onError onSuccess e
  where
  onError e = return $ It name $ Failure e
  onSuccess _ = return $ It name Success

it :: forall r. String
    -> Aff r Unit
    -> Spec r Unit
it description tests =
  do
    result <- lift $ runCatch description tests
    modify $ \p -> p ++ [result]
    return unit

collect :: forall r. Spec r Unit
        -> Aff r (Array Group)
collect r = do
  c <- runStateT r []
  return $ snd c


Parser version of 'test-typeclassed'

Parser version of 'test-typeclassed'

module JSON where

  import Prelude
  import Either
  import Monad
  import Maybe

  foreign import data JSON :: *

  foreign import fromString "function fromString (str) { \
                            \  try { \
                            \    return _ps.Either.Right(JSON.parse(str)); \
                            \  } catch (e) { \
                            \    return _ps.Either.Left(e.toString()); \
                            \  } \
                            \}" :: String -> Either String JSON

  foreign import readPrimType "function readPrimType (typeName) { \
                              \  return function (value) { \
                              \    if (toString.call(value) == '[object ' + typeName + ']') { \
                              \      return _ps.Either.Right(value);\
                              \    } \
                              \    return _ps.Either.Left('Value is not a ' + typeName + ''); \
                              \  }; \
                              \}" :: forall a. String -> JSON -> Either String a

  foreign import readMaybe "function readMaybe (value) { \
                           \  return value === undefined || value === null ? _ps.Maybe.Nothing : _ps.Maybe.Just(value); \
                           \}" :: forall a. JSON -> Maybe.Maybe JSON

  foreign import readProp "function readProp (k) { \
                          \  return function (obj) { \
                          \    return _ps.Either.Right(obj[k]);\
                          \  }; \
                          \}" :: forall a. String -> JSON -> Either String JSON

  foreign import showJSON "function showJSON (obj) { \
                          \  return JSON.stringify(obj); \
                          \}" :: JSON -> String

  instance Prelude.Show JSON where
    show = showJSON

  data JSONParser a = JSONParser (JSON -> Either String a)

  str :: JSONParser String
  str = JSONParser $ readPrimType "String"

  num :: JSONParser Number
  num = JSONParser $ readPrimType "Number"

  bool :: JSONParser Boolean
  bool = JSONParser $ readPrimType "Boolean"

  arr :: JSONParser [JSON]
  arr = JSONParser $ readPrimType "Array"

  mayb :: JSONParser (Maybe.Maybe JSON)
  mayb = JSONParser $ Right <<< readMaybe

  prop :: String -> JSONParser JSON
  prop p = JSONParser \x -> readProp p x

  runParser :: forall a. JSONParser a -> JSON -> Either String a
  runParser (JSONParser p) x = p x

  instance Prelude.Monad JSONParser where
    return x = JSONParser \_ -> Right x
    (>>=) (JSONParser p) f = JSONParser \x -> case p x of
        Left err -> Left err
        Right x' -> runParser (f x') x

  instance Prelude.Applicative JSONParser where
    pure x = JSONParser \_ -> Right x
    (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
        Left err -> Left err
        Right f' -> f' <$> p x

  instance Prelude.Functor JSONParser where
    (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

  class ReadJSON a where
    readJSON :: JSONParser a

  instance ReadJSON String where
    readJSON = str

  instance ReadJSON Number where
    readJSON = num

  instance ReadJSON Boolean where
    readJSON = bool

  instance (ReadJSON a) => ReadJSON [a] where
    readJSON = arr >>= \xs -> JSONParser $ \_ -> (runParser readJSON) `mapM` xs

  instance (ReadJSON a) => ReadJSON (Maybe a) where
    readJSON = mayb >>= \x -> JSONParser $ \_ -> case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

  readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
  readJSONProp p = (prop p) >>= \x -> JSONParser $ \_ -> runParser readJSON x

module Main where

  import Prelude
  import JSON
  import Either
  import Monad
  import Maybe
  import Trace

  foreign import toJSON "function toJSON (obj) { return obj; }" :: forall a. a -> JSON

  showUnsafe :: forall a. a -> String
  showUnsafe = showJSON <<< toJSON

  data Object = Object { foo :: String
                       , bar :: Boolean
                       , baz :: Number
                       , list :: [ListItem] }

  data ListItem = ListItem { x :: Number
                           , y :: Number
                           , z :: Maybe Number }

  instance JSON.ReadJSON ListItem where
    readJSON = do
      x <- readJSONProp "x"
      y <- readJSONProp "y"
      z <- readJSONProp "z"
      return $ ListItem { x: x, y: y, z: z }

  instance JSON.ReadJSON Object where
    readJSON = do
      foo <- readJSONProp "foo"
      bar <- readJSONProp "bar"
      baz <- readJSONProp "baz"
      list <- readJSONProp "list"
      return $ Object { foo: foo, bar: bar, baz: baz, list: list }

  main = do
    let obj = fromString "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4,\"z\":999}]}"
    case obj of
      Left err -> Trace.print $ "Error parsing: " ++ err
      Right obj -> case runParser readJSON obj of
        Left err -> Trace.print err
        Right (Object result) -> Trace.print $ showUnsafe result

module JSON where

  import Prelude
  import Either
  import Monad

  foreign import data JSON :: *

  foreign import fromString "function fromString (str) { \
                            \  try { \
                            \    return _ps.Either.Right(JSON.parse(str)); \
                            \  } catch (e) { \
                            \    return _ps.Either.Left(e.toString()); \
                            \  } \
                            \}" :: String -> Either String JSON

  foreign import readPrimType "function readPrimType (typeName) { \
                              \  return function (value) { \
                              \    if (toString.call(value) == '[object ' + typeName + ']') { \
                              \      return _ps.Either.Right(value);\
                              \    } \
                              \    return _ps.Either.Left('Value is not a ' + typeName + ''); \
                              \  }; \
                              \}" :: forall a. String -> JSON -> Either String a

  foreign import readMaybe "function readMaybe (value) { \
                           \  return value === undefined || value === null ? _ps.Maybe.Nothing : _ps.Maybe.Just(value); \
                           \}" :: forall a. JSON -> Maybe.Maybe JSON

  foreign import readProp "function prop (k) { \
                          \  return function (obj) { \
                          \    return _ps.Either.Right(obj[k]);\
                          \  }; \
                          \}" :: forall a. String -> JSON -> Either String JSON

  foreign import showJSON "function showJSON (obj) { \
                          \  return JSON.stringify(obj); \
                          \}" :: JSON -> String

  instance Prelude.Show JSON where
    show = showJSON

  data JSONParser a = JSONParser (JSON -> Either String a)

  str :: JSONParser String
  str = JSONParser $ readPrimType "String"

  num :: JSONParser Number
  num = JSONParser $ readPrimType "Number"

  bool :: JSONParser Boolean
  bool = JSONParser $ readPrimType "Boolean"

  arr :: JSONParser [JSON]
  arr = JSONParser $ readPrimType "Array"

  maybe :: JSONParser (Maybe.Maybe JSON)
  maybe = JSONParser $ Right <<< readMaybe

  prop :: String -> JSONParser JSON
  prop p = JSONParser \x -> readProp p x

  runParser :: forall a. JSONParser a -> JSON -> Either String a
  runParser (JSONParser p) x = p x

  instance Prelude.Monad JSONParser where
    return x = JSONParser \_ -> Right x
    (>>=) (JSONParser p) f = JSONParser \x -> case p x of
        Left err -> Left err
        Right x' -> runParser (f x') x


Fix: constrain unquoted attribute value.

1. Treat as whitespace not only spacebar but also tabulation and carriage returns.
2. Consider slash be the end of attribute value. (Otherwise void tags won't parse.)
3. Consider unquoted attribute value unempty. (Otherwise we couldn't allow whitespace between
equals sign and unquoted attribute value.)

module Text.HTML.Parser.Internal where

import Prelude
import Control.Alt
import Control.Apply
import Data.Either
import Data.List (List(..))
import Data.Maybe
import Data.Tuple

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String (eof, string)

import Text.HTML.Parser.Combinators
import Text.HTML.Parser.Types

parseHTML :: String -> Either ParseError (List HTML)
parseHTML s = flip runParser s $ many parseNode <* eof

parseElement = do
  Tuple name attrs <- parseOpenTag
  children <- many parseNode
  parseCloseTag name
  pure $ Element name attrs children

parseNode = fix \_ ->
  try parseElement <|>
  try parseVoidElement <|>
  parseTextNode

parseOpenTag :: Parser (Tuple String (List Attribute))
parseOpenTag = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  char '>'
  pure $ Tuple name attrs

parseCloseTag :: String -> Parser Char
parseCloseTag name = do
  string "</"
  string name
  char '>'

notClosedTag :: Parser Unit
notClosedTag = notFollowedBy $ string "</"

parseVoidElement = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  string "/>"
  pure $ VoidElement name attrs

parseTagName :: Parser String
parseTagName = catChars <$> many1 (satisfy isAlphaNumeric)

parseTextNode :: Parser HTML
parseTextNode = TextNode <<< catChars <$> many1 (noneOf ['<', '>'])

parseAttributes :: Parser (List Attribute)
parseAttributes = sepEndBy parseAttribute skipSpaces

parseAttribute :: Parser Attribute
parseAttribute = do
  name <- parseAttributeName
  skipSpaces
  maybeEquals <- optionMaybe $ char '='
  value <- case maybeEquals of
    Nothing -> pure ""
    Just _ -> parseAttributeValue
  pure $ Attribute name value

parseAttributeName :: Parser String
parseAttributeName = catChars <$> many1 (noneOf [' ', '"', '\'', '>', '/', '='])

parseAttributeValue :: Parser String
parseAttributeValue = do
  maybeOpenChar <- optionMaybe $ skipSpaces *> (char '"' <|> char '\'')
  case maybeOpenChar of
    Nothing -> catChars <$> many1 (noneOf [' ', '\t', '\n', '\r', '>', '/'])
    Just openChar -> do
      value <- catChars <$> many (noneOf [openChar])
      char openChar
      pure value

module Text.HTML.Parser.Internal where

import Prelude
import Control.Alt
import Control.Apply
import Data.Either
import Data.List (List(..))
import Data.Maybe
import Data.Tuple

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String (eof, string)

import Text.HTML.Parser.Combinators
import Text.HTML.Parser.Types

parseHTML :: String -> Either ParseError (List HTML)
parseHTML s = flip runParser s $ many parseNode <* eof

parseElement = do
  Tuple name attrs <- parseOpenTag
  children <- many parseNode
  parseCloseTag name
  pure $ Element name attrs children

parseNode = fix \_ ->
  try parseElement <|>
  try parseVoidElement <|>
  parseTextNode

parseOpenTag :: Parser (Tuple String (List Attribute))
parseOpenTag = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  char '>'
  pure $ Tuple name attrs

parseCloseTag :: String -> Parser Char
parseCloseTag name = do
  string "</"
  string name
  char '>'

notClosedTag :: Parser Unit
notClosedTag = notFollowedBy $ string "</"

parseVoidElement = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  string "/>"
  pure $ VoidElement name attrs

parseTagName :: Parser String
parseTagName = catChars <$> many1 (satisfy isAlphaNumeric)

parseTextNode :: Parser HTML
parseTextNode = TextNode <<< catChars <$> many1 (noneOf ['<', '>'])

parseAttributes :: Parser (List Attribute)
parseAttributes = sepEndBy parseAttribute skipSpaces

parseAttribute :: Parser Attribute
parseAttribute = do
  name <- parseAttributeName
  skipSpaces
  maybeEquals <- optionMaybe $ char '='
  value <- case maybeEquals of
    Nothing -> pure ""
    Just _ -> parseAttributeValue
  pure $ Attribute name value

parseAttributeName :: Parser String
parseAttributeName = catChars <$> many1 (noneOf [' ', '"', '\'', '>', '/', '='])

parseAttributeValue :: Parser String
parseAttributeValue = do
  maybeOpenChar <- optionMaybe $ skipSpaces *> (char '"' <|> char '\'')
  case maybeOpenChar of
    Nothing -> catChars <$> many (noneOf [' ', '>'])
    Just openChar -> do
      value <- catChars <$> many (noneOf [openChar])
      char openChar
      pure value