removed invalid cases from eval1

removed invalid cases from eval1

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 (..))
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 MType) TypeTree
  | StrictnessError (Binding MType) TypeTree
  | TooFewArguments (List (Binding MType)) (List TypeTree)

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

type Evaluator = ExceptT EvalError Identity

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

type Matcher = ExceptT MatchingError Identity

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

type Env = StrMap (List (Tuple (List (Binding MType)) 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 Nothing f (singleton $ App Nothing 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 Nothing op e1 e2)
  (App _ (SectR _ op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (PrefixOp _ op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (Atom _ (Name name)) args)      -> apply env name args
  (App _ (App _ func es) es')            -> pure $ App Nothing 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 Nothing (Name "_|_"))

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

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

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

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

recurse :: Env -> TypeTree -> Binding MType -> 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 Nothing op (evalToBinding env e1 bind) (evalToBinding env e2 bind)
      (Unary _ op e)       ->
        Unary Nothing op (evalToBinding env e bind)
      (List _ es)          ->
        List Nothing ((\e -> evalToBinding env e bind) <$> es)
      (NTuple _ es)        ->
        NTuple Nothing ((\e -> evalToBinding env e bind) <$> es)
      (IfExpr _ c t e)     ->
        IfExpr Nothing (evalToBinding env c bind) t e
      (App _ c@(Atom _ (Constr _)) args) ->
        App Nothing c ((\e -> evalToBinding env e bind) <$> args)
      (App _ f args)       -> do
        App Nothing (evalToBinding env f bind) args
      (ArithmSeq _ c t e)     ->
        ArithmSeq Nothing (evalToBinding env c bind) ((\x -> evalToBinding env x bind) <$> t) ((\x -> evalToBinding env x bind) <$> e)
      (ListComp _ e qs)    -> do
        ListComp Nothing (evalToBinding env e bind) ((\x -> evalToBindingQual env x bind) <$> qs)
      _                  ->
        expr

    evalToBindingQual :: Env -> TypeQual -> Binding MType ->TypeQual
    evalToBindingQual environment qual binding = case qual of
      Let _ b e -> Let Nothing b (evalToBinding environment e bind)
      Gen _ b e -> Gen Nothing b (evalToBinding environment e bind)
      Guard _ e -> Guard Nothing (evalToBinding environment e bind)

wrapLambda :: (List (Binding MType)) -> (List TypeTree) -> TypeTree -> Evaluator TypeTree
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> pure body
    GT -> pure $ Lambda Nothing (drop (length args) binds) body
    LT -> pure $ App Nothing 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 Nothing <<< AInt) <$> x) <$> intQuat
  Atom _ (Bool b) -> (\x -> (Atom Nothing <<< Bool) <$> x) <$> (intToABool intQuat)
  Atom _ (Char c) -> (\x -> (Atom Nothing <<< 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 Nothing 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 Nothing Nil
      Quat (Just a) Nothing _ _   -> pure $ AST.binary Colon a (List Nothing Nil)
      Quat (Just a) (Just na) b c -> pure $ AST.binary Colon a (ArithmSeq Nothing na b c)

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

evalListComp :: Env -> TypeTree -> List TypeQual -> Evaluator TypeTree
evalListComp _   expr Nil         = pure $ List Nothing $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard _ (Atom _ (Bool false)) -> pure $ List Nothing Nil
  Guard _ (Atom _ (Bool true))  -> if null qs then pure (List Nothing (singleton expr)) else pure (ListComp Nothing expr qs)
  Gen _ _ (List _ Nil)          -> pure $ List Nothing Nil
  -- Gen _ b (List (Cons e Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (List _ (Cons e es))  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing b (List Nothing es)) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ Binary Nothing (Tuple Colon Nothing) x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  -- Gen _ b (Binary Colon e (List Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (Binary Nothing (Tuple Colon _) e es)  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing 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 Nothing expr (Cons (Gen Nothing b (evalToBinding env e (ConsLit Nothing b (Lit Nothing (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 Nothing $ singleton expr'
          _   -> pure $ ListComp Nothing expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp Nothing 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 Nothing b e'
      Let _ b e -> scope b e >>= \e' -> pure $ Let Nothing b e'
      Guard _ e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard Nothing e'

scope :: Binding MType -> 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 MType) 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 Nothing rest' expr'

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

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

binary :: Env -> (Tuple Op MType) -> TypeTree -> TypeTree -> Evaluator TypeTree
binary env (Tuple operator mtype) = case operator of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List _ ls) -> pure $ List Nothing $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List _ ls1) (List _ ls2)) -> pure $ List Nothing $ 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 Nothing $ Bool false
    (Tuple _                     (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple (Atom _ (Bool true))  (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple _                   _                     )  -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool true))  _                   )  -> pure $ Atom Nothing $ Bool true
    (Tuple _                     (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple (Atom _ (Bool false)) (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple _                     _                   )  -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ App Nothing 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 Nothing (Tuple operator mtype) e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> TypeTree -> TypeTree -> Evaluator TypeTree
    aint _   f (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ 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 Nothing $ Bool $ fi i j
    ord _  _  fs _  (Atom _ (Char s1)) (Atom _ (Char s2)) = pure $ Atom Nothing $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom _ (Bool b1)) (Atom _ (Bool b2)) = pure $ Atom Nothing $ Bool $ fb b1 b2
    ord op _  _  _  e1               e2               = throwError $ BinaryOpError op e1 e2

unary :: Env -> Tuple Op MType -> TypeTree -> Evaluator TypeTree
unary env (Tuple Sub _) (Atom _ (AInt i)) = pure $ Atom Nothing $ 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 Nothing $ 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 Nothing $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List (Binding MType)) 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 MType -> TypeTree -> MatchingError
checkStrictness bs es | whnf es   = MatchingError bs es
                      | otherwise = StrictnessError bs es

matchls' :: Env -> (List (Binding MType)) -> (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 MType -> 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 Nothing ba) (Atom Nothing ea)
match' (Lit _ b)           e                   = throwError $ checkStrictness (Lit Nothing 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 Nothing b bs) (AST.binary Colon e (List Nothing es))
match' (ConsLit _ b bs)    (List _ Nil)          = throwError $ MatchingError (ConsLit Nothing b bs) (List Nothing Nil)
match' (ConsLit _ b bs)    e                     = throwError $ checkStrictness (ConsLit Nothing b bs) e

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

match' (NTupleLit _ bs)    (NTuple _ es) = case length bs == length es of
                                           true  -> void $ zipWithA match' bs es
                                           false -> throwError $ MatchingError (NTupleLit Nothing bs) (NTuple Nothing es)
match' (NTupleLit _ bs)    e             = throwError $ checkStrictness (NTupleLit Nothing 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 MType -> 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 Nothing <$> (traverse go exprs)
    (NTuple _ exprs)       -> NTuple Nothing <$> (traverse go exprs)
    (Binary _ op e1 e2)    -> Binary Nothing <$> pure op <*> go e1 <*> go e2
    (Unary _ op e)         -> Unary Nothing <$> pure op <*> go e
    (SectL _ e op)         -> SectL Nothing <$> go e <*> pure op
    (SectR _ op e)         -> SectR Nothing <$> pure op <*> go e
    (IfExpr _ ce te ee)    -> IfExpr Nothing <$> go ce <*> go te <*> go ee
    (ArithmSeq _ ce te ee) -> ArithmSeq Nothing <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda _ binds body)  -> (avoidCapture subs binds) *> (Lambda Nothing <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App _ func exprs)     -> App Nothing <$> go func <*> traverse go exprs
    (ListComp _ expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      pure $ ListComp Nothing expr' quals'
    (LetExpr _ binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr Nothing binds' expr'
    e                     -> pure e

avoidCapture :: StrMap TypeTree -> (List (Binding MType)) -> 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 MType)) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding MType -> (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 (..))
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 MType) TypeTree
  | StrictnessError (Binding MType) TypeTree
  | TooFewArguments (List (Binding MType)) (List TypeTree)

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

type Evaluator = ExceptT EvalError Identity

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

type Matcher = ExceptT MatchingError Identity

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

type Env = StrMap (List (Tuple (List (Binding MType)) 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 Nothing f (singleton $ App Nothing 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 Nothing op e1 e2)
  (App _ (SectR _ op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (PrefixOp _ op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (Atom _ (Name name)) args)      -> apply env name args
  (App _ (App _ func es) es')            -> pure $ App Nothing 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 Nothing (Name "_|_"))

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

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

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

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

recurse :: Env -> TypeTree -> Binding MType -> 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 Nothing op (evalToBinding env e1 bind) (evalToBinding env e2 bind)
      (Unary _ op e)       ->
        Unary Nothing op (evalToBinding env e bind)
      (List _ es)          ->
        List Nothing ((\e -> evalToBinding env e bind) <$> es)
      (NTuple _ es)        ->
        NTuple Nothing ((\e -> evalToBinding env e bind) <$> es)
      (IfExpr _ c t e)     ->
        IfExpr Nothing (evalToBinding env c bind) t e
      (App _ c@(Atom _ (Constr _)) args) ->
        App Nothing c ((\e -> evalToBinding env e bind) <$> args)
      (App _ f args)       -> do
        App Nothing (evalToBinding env f bind) args
      (ArithmSeq _ c t e)     ->
        ArithmSeq Nothing (evalToBinding env c bind) ((\x -> evalToBinding env x bind) <$> t) ((\x -> evalToBinding env x bind) <$> e)
      (ListComp _ e qs)    -> do
        ListComp Nothing (evalToBinding env e bind) ((\x -> evalToBindingQual env x bind) <$> qs)
      _                  ->
        expr

    evalToBindingQual :: Env -> TypeQual -> Binding MType ->TypeQual
    evalToBindingQual environment qual binding = case qual of
      Let _ b e -> Let Nothing b (evalToBinding environment e bind)
      Gen _ b e -> Gen Nothing b (evalToBinding environment e bind)
      Guard _ e -> Guard Nothing (evalToBinding environment e bind)

wrapLambda :: (List (Binding MType)) -> (List TypeTree) -> TypeTree -> Evaluator TypeTree
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> pure body
    GT -> pure $ Lambda Nothing (drop (length args) binds) body
    LT -> pure $ App Nothing 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 Nothing <<< AInt) <$> x) <$> intQuat
  Atom _ (Bool b) -> (\x -> (Atom Nothing <<< Bool) <$> x) <$> (intToABool intQuat)
  Atom _ (Char c) -> (\x -> (Atom Nothing <<< 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 Nothing 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 Nothing Nil
      Quat (Just a) Nothing _ _   -> pure $ AST.binary Colon a (List Nothing Nil)
      Quat (Just a) (Just na) b c -> pure $ AST.binary Colon a (ArithmSeq Nothing na b c)

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

evalListComp :: Env -> TypeTree -> List TypeQual -> Evaluator TypeTree
evalListComp _   expr Nil         = pure $ List Nothing $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard _ (Atom _ (Bool false)) -> pure $ List Nothing Nil
  Guard _ (Atom _ (Bool true))  -> if null qs then pure (List Nothing (singleton expr)) else pure (ListComp Nothing expr qs)
  Gen _ _ (List _ Nil)          -> pure $ List Nothing Nil
  -- Gen _ b (List (Cons e Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (List _ (Cons e es))  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing b (List Nothing es)) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ Binary Nothing (Tuple Colon Nothing) x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  -- Gen _ b (Binary Colon e (List Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (Binary Nothing (Tuple Colon _) e es)  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing 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 Nothing expr (Cons (Gen Nothing b (evalToBinding env e (ConsLit Nothing b (Lit Nothing (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 Nothing $ singleton expr'
          _   -> pure $ ListComp Nothing expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp Nothing 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 Nothing b e'
      Let _ b e -> scope b e >>= \e' -> pure $ Let Nothing b e'
      Guard _ e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard Nothing e'

scope :: Binding MType -> 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 MType) 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 Nothing rest' expr'

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

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

binary :: Env -> (Tuple Op MType) -> TypeTree -> TypeTree -> Evaluator TypeTree
binary env (Tuple operator mtype) = case operator of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List _ ls) -> pure $ List Nothing $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List _ ls1) (List _ ls2)) -> pure $ List Nothing $ 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 Nothing $ Bool false
    (Tuple _                     (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple (Atom _ (Bool true))  (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple _                   _                     )  -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool true))  _                   )  -> pure $ Atom Nothing $ Bool true
    (Tuple _                     (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple (Atom _ (Bool false)) (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple _                     _                   )  -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ App Nothing 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 Nothing (Tuple operator mtype) e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> TypeTree -> TypeTree -> Evaluator TypeTree
    aint _   f (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ 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 Nothing $ Bool $ fi i j
    ord _  _  fs _  (Atom _ (Char s1)) (Atom _ (Char s2)) = pure $ Atom Nothing $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom _ (Bool b1)) (Atom _ (Bool b2)) = pure $ Atom Nothing $ Bool $ fb b1 b2
    ord op _  _  _  e1               e2               = throwError $ BinaryOpError op e1 e2

unary :: Env -> Tuple Op MType -> TypeTree -> Evaluator TypeTree
unary env (Tuple Sub _) (Atom _ (AInt i)) = pure $ Atom Nothing $ 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 Nothing $ 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 Nothing $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List (Binding MType)) 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 MType -> TypeTree -> MatchingError
checkStrictness bs es | whnf es   = MatchingError bs es
                      | otherwise = StrictnessError bs es

matchls' :: Env -> (List (Binding MType)) -> (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 MType -> 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 Nothing ba) (Atom Nothing ea)
match' (Lit _ b)           e                   = throwError $ checkStrictness (Lit Nothing 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 Nothing b bs) (AST.binary Colon e (List Nothing es))
match' (ConsLit _ b bs)    (List _ Nil)          = throwError $ MatchingError (ConsLit Nothing b bs) (List Nothing Nil)
match' (ConsLit _ b bs)    e                     = throwError $ checkStrictness (ConsLit Nothing b bs) e

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

match' (NTupleLit _ bs)    (NTuple _ es) = case length bs == length es of
                                           true  -> void $ zipWithA match' bs es
                                           false -> throwError $ MatchingError (NTupleLit Nothing bs) (NTuple Nothing es)
match' (NTupleLit _ bs)    e             = throwError $ checkStrictness (NTupleLit Nothing 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 MType -> 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 Nothing <$> (traverse go exprs)
    (NTuple _ exprs)       -> NTuple Nothing <$> (traverse go exprs)
    (Binary _ op e1 e2)    -> Binary Nothing <$> pure op <*> go e1 <*> go e2
    (Unary _ op e)         -> Unary Nothing <$> pure op <*> go e
    (SectL _ e op)         -> SectL Nothing <$> go e <*> pure op
    (SectR _ op e)         -> SectR Nothing <$> pure op <*> go e
    (IfExpr _ ce te ee)    -> IfExpr Nothing <$> go ce <*> go te <*> go ee
    (ArithmSeq _ ce te ee) -> ArithmSeq Nothing <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda _ binds body)  -> (avoidCapture subs binds) *> (Lambda Nothing <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App _ func exprs)     -> App Nothing <$> go func <*> traverse go exprs
    (ListComp _ expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      pure $ ListComp Nothing expr' quals'
    (LetExpr _ binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr Nothing binds' expr'
    e                     -> pure e

avoidCapture :: StrMap TypeTree -> (List (Binding MType)) -> 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 MType)) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding MType -> (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


Add replaceRange property to suggestion (#22)

module Psa.Types
  ( ErrorCode
  , ModuleName
  , Filename
  , PsaOptions
  , PsaResult
  , PsaError
  , PsaAnnotedError
  , PsaPath(..)
  , Position
  , Suggestion
  , Lines
  , parsePsaResult
  , parsePsaError
  , encodePsaResult
  , encodePsaError
  , compareByLocation
  ) where

import Prelude
import Data.Argonaut.Core (Json, JObject, jsonNull)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Encode (encodeJson)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Either (Either)
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (runPure)
import Unsafe.Coerce (unsafeCoerce)

type ErrorCode = String
type ModuleName = String
type Filename = String
type Lines = Array String

-- | Relative files paths from the cwd, tagged as either being part of the
-- | source files or library files of a project. The `Unknown` variant exists
-- | because some psc errors are inter-module and aren't reported with a
-- | canonical file.
data PsaPath
  = Src String
  | Lib String
  | Unknown

instance eqPsaPath :: Eq PsaPath where
  eq (Src a) (Src b) = eq a b
  eq (Lib a) (Lib b) = eq a b
  eq Unknown Unknown = true
  eq _       _       = false

instance ordPsaPath :: Ord PsaPath where
  compare (Src a) (Src b) = compare a b
  compare (Src _) (Lib _) = GT
  compare (Src _) Unknown = GT
  compare (Lib _) (Src _) = LT
  compare (Lib a) (Lib b) = compare a b
  compare (Lib _) Unknown = GT
  compare Unknown Unknown = EQ
  compare Unknown _       = LT

type PsaOptions =
  { ansi :: Boolean
  , censorWarnings :: Boolean
  , censorLib :: Boolean
  , censorSrc :: Boolean
  , censorCodes :: Set ErrorCode
  , filterCodes :: Set ErrorCode
  , verboseStats :: Boolean
  , libDirs :: Array String
  , strict :: Boolean
  , cwd :: String
  }

type PsaResult =
  { warnings :: Array PsaError
  , errors :: Array PsaError
  }

type PsaError =
  { moduleName :: Maybe ModuleName
  , errorCode :: ErrorCode
  , errorLink :: String
  , suggestion :: Maybe Suggestion
  , message :: String
  , filename :: Maybe Filename
  , position :: Maybe Position
  }

type PsaAnnotedError =
  { error :: PsaError
  , path :: PsaPath
  , source :: Maybe Lines
  , position :: Maybe Position
  , message :: String
  }

type Position =
  { startLine :: Int
  , startColumn :: Int
  , endLine :: Int
  , endColumn :: Int
  }

type Suggestion =
  { replacement :: String
  , replaceRange :: Maybe Position
  }

compareByLocation :: PsaAnnotedError -> PsaAnnotedError -> Ordering
compareByLocation err1 err2 =
  case compare err1.path err2.path of
    EQ ->
      case err1.position, err2.position of
        Nothing, Nothing -> EQ
        Nothing, _       -> LT
        _      , Nothing -> GT
        Just a , Just b  ->
          compare (Tuple a.startLine a.startColumn)
                  (Tuple b.startLine b.startColumn)
    x  -> x

parsePsaResult :: JObject -> Either String PsaResult
parsePsaResult obj =
  { warnings: _
  , errors: _
  } <$> (obj .? "warnings" >>= traverse parsePsaError)
    <*> (obj .? "errors" >>= traverse parsePsaError)

parsePsaError :: JObject -> Either String PsaError
parsePsaError obj =
  { moduleName: _
  , errorCode: _
  , errorLink: _
  , message: _
  , filename: _
  , position: _
  , suggestion: _
  } <$> obj .? "moduleName"
    <*> obj .? "errorCode"
    <*> obj .? "errorLink"
    <*> obj .? "message"
    <*> obj .? "filename"
    <*> (obj .? "position" >>= parsePosition)
    <*> (obj .? "suggestion" >>= parseSuggestion)

parsePosition :: Maybe JObject -> Either String (Maybe Position)
parsePosition =
  maybe (pure Nothing) \obj -> map Just $
    { startLine: _
    , startColumn: _
    , endLine: _
    , endColumn: _
    } <$> obj .? "startLine"
      <*> obj .? "startColumn"
      <*> obj .? "endLine"
      <*> obj .? "endColumn"

parseSuggestion :: Maybe JObject -> Either String (Maybe Suggestion)
parseSuggestion =
  maybe (pure Nothing) \obj -> map Just $
    { replacement: _
    , replaceRange: _
    } <$> obj .? "replacement"
      <*> (obj .? "replaceRange" >>= parsePosition)

encodePsaResult :: PsaResult -> Json
encodePsaResult res = encodeJson $ runPure $ StrMap.runST do
  obj <- STMap.new
  STMap.poke obj "warnings" $ encodeJson (encodePsaError <$> res.warnings)
  STMap.poke obj "errors"   $ encodeJson (encodePsaError <$> res.errors)

encodePsaError :: PsaError -> Json
encodePsaError error = encodeJson $ runPure $ StrMap.runST do
  obj <- STMap.new
  STMap.poke obj "moduleName"  $ encodeJson error.moduleName
  STMap.poke obj "errorCode"   $ encodeJson error.errorCode
  STMap.poke obj "errorLink"   $ encodeJson error.errorLink
  STMap.poke obj "message"     $ encodeJson error.message
  STMap.poke obj "filename"    $ encodeJson error.filename
  STMap.poke obj "position"    $ encodeJson (maybe jsonNull encodePosition error.position)
  STMap.poke obj "suggestion"  $ encodeJson (maybe jsonNull encodeSuggestion error.suggestion)

encodePosition :: Position -> Json
encodePosition = unsafeCoerce

encodeSuggestion :: Suggestion -> Json
encodeSuggestion suggestion = encodeJson $ runPure $ StrMap.runST do
  obj <- STMap.new
  STMap.poke obj "replacement"  $ encodeJson suggestion.replacement
  STMap.poke obj "replaceRange" $ encodeJson (maybe jsonNull encodePosition suggestion.replaceRange)

module Psa.Types
  ( ErrorCode
  , ModuleName
  , Filename
  , PsaOptions
  , PsaResult
  , PsaError
  , PsaAnnotedError
  , PsaPath(..)
  , Position
  , Suggestion
  , Lines
  , parsePsaResult
  , parsePsaError
  , encodePsaResult
  , encodePsaError
  , compareByLocation
  ) where

import Prelude
import Data.Argonaut.Core (Json, JObject, jsonNull)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Encode (encodeJson)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Either (Either)
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (runPure)
import Unsafe.Coerce (unsafeCoerce)

type ErrorCode = String
type ModuleName = String
type Filename = String
type Lines = Array String

-- | Relative files paths from the cwd, tagged as either being part of the
-- | source files or library files of a project. The `Unknown` variant exists
-- | because some psc errors are inter-module and aren't reported with a
-- | canonical file.
data PsaPath
  = Src String
  | Lib String
  | Unknown

instance eqPsaPath :: Eq PsaPath where
  eq (Src a) (Src b) = eq a b
  eq (Lib a) (Lib b) = eq a b
  eq Unknown Unknown = true
  eq _       _       = false

instance ordPsaPath :: Ord PsaPath where
  compare (Src a) (Src b) = compare a b
  compare (Src _) (Lib _) = GT
  compare (Src _) Unknown = GT
  compare (Lib _) (Src _) = LT
  compare (Lib a) (Lib b) = compare a b
  compare (Lib _) Unknown = GT
  compare Unknown Unknown = EQ
  compare Unknown _       = LT

type PsaOptions =
  { ansi :: Boolean
  , censorWarnings :: Boolean
  , censorLib :: Boolean
  , censorSrc :: Boolean
  , censorCodes :: Set ErrorCode
  , filterCodes :: Set ErrorCode
  , verboseStats :: Boolean
  , libDirs :: Array String
  , strict :: Boolean
  , cwd :: String
  }

type PsaResult =
  { warnings :: Array PsaError
  , errors :: Array PsaError
  }

type PsaError =
  { moduleName :: Maybe ModuleName
  , errorCode :: ErrorCode
  , errorLink :: String
  , suggestion :: Maybe Suggestion
  , message :: String
  , filename :: Maybe Filename
  , position :: Maybe Position
  }

type PsaAnnotedError =
  { error :: PsaError
  , path :: PsaPath
  , source :: Maybe Lines
  , position :: Maybe Position
  , message :: String
  }

type Position =
  { startLine :: Int
  , startColumn :: Int
  , endLine :: Int
  , endColumn :: Int
  }

type Suggestion =
  { replacement :: String
  }

compareByLocation :: PsaAnnotedError -> PsaAnnotedError -> Ordering
compareByLocation err1 err2 =
  case compare err1.path err2.path of
    EQ ->
      case err1.position, err2.position of
        Nothing, Nothing -> EQ
        Nothing, _       -> LT
        _      , Nothing -> GT
        Just a , Just b  ->
          compare (Tuple a.startLine a.startColumn)
                  (Tuple b.startLine b.startColumn)
    x  -> x

parsePsaResult :: JObject -> Either String PsaResult
parsePsaResult obj =
  { warnings: _
  , errors: _
  } <$> (obj .? "warnings" >>= traverse parsePsaError)
    <*> (obj .? "errors" >>= traverse parsePsaError)

parsePsaError :: JObject -> Either String PsaError
parsePsaError obj =
  { moduleName: _
  , errorCode: _
  , errorLink: _
  , message: _
  , filename: _
  , position: _
  , suggestion: _
  } <$> obj .? "moduleName"
    <*> obj .? "errorCode"
    <*> obj .? "errorLink"
    <*> obj .? "message"
    <*> obj .? "filename"
    <*> (obj .? "position" >>= parsePosition)
    <*> (obj .? "suggestion" >>= parseSuggestion)

parsePosition :: Maybe JObject -> Either String (Maybe Position)
parsePosition =
  maybe (pure Nothing) \obj -> map Just $
    { startLine: _
    , startColumn: _
    , endLine: _
    , endColumn: _
    } <$> obj .? "startLine"
      <*> obj .? "startColumn"
      <*> obj .? "endLine"
      <*> obj .? "endColumn"

parseSuggestion :: Maybe JObject -> Either String (Maybe Suggestion)
parseSuggestion =
  maybe (pure Nothing) \obj -> map Just $
    { replacement: _ } <$> obj .? "replacement"

encodePsaResult :: PsaResult -> Json
encodePsaResult res = encodeJson $ runPure $ StrMap.runST do
  obj <- STMap.new
  STMap.poke obj "warnings" $ encodeJson (encodePsaError <$> res.warnings)
  STMap.poke obj "errors"   $ encodeJson (encodePsaError <$> res.errors)

encodePsaError :: PsaError -> Json
encodePsaError error = encodeJson $ runPure $ StrMap.runST do
  obj <- STMap.new
  STMap.poke obj "moduleName"  $ encodeJson error.moduleName
  STMap.poke obj "errorCode"   $ encodeJson error.errorCode
  STMap.poke obj "errorLink"   $ encodeJson error.errorLink
  STMap.poke obj "message"     $ encodeJson error.message
  STMap.poke obj "filename"    $ encodeJson error.filename
  STMap.poke obj "position"    $ encodeJson (maybe jsonNull encodePosition error.position)
  STMap.poke obj "suggestion"  $ encodeJson (maybe jsonNull encodeSuggestion error.suggestion)

encodePosition :: Position -> Json
encodePosition = unsafeCoerce

encodeSuggestion :: Suggestion -> Json
encodeSuggestion = unsafeCoerce


Remove members from Data.Aray import

Remove members from Data.Aray import

module GulpPurescript.Plugin
  ( Effects
  , Errorback
  , Callback
  , psc
  , pscBundle
  , pscDocs
  , psci
  ) where

import Prelude (Unit, ($), (<>), (<$>), (<*>), (<<<), (>>=), (+), bind, const, id, pure, show, unit)

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Error.Class (catchError, throwError)

import Data.Array as Array
import Data.Either (either)
import Data.Foreign (Foreign)
import Data.Foreign.Class (read)
import Data.Maybe (Maybe(Just))
import Data.String (joinWith, null)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested (tuple2)

import GulpPurescript.Buffer (mkBufferFromString)
import GulpPurescript.ChildProcess (ChildProcess, spawn)
import GulpPurescript.Glob (Glob, globAll)
import GulpPurescript.GulpUtil (File, mkFile, mkPluginError)
import GulpPurescript.Logalot (Logalot, info)
import GulpPurescript.OS (OS, Platform(Win32), platform)
import GulpPurescript.Options (Psci(..), pscOptions, pscBundleOptions, pscDocsOptions)
import GulpPurescript.Path (relative)
import GulpPurescript.ResolveBin (ResolveBin, resolveBin)
import GulpPurescript.Stream (Stream, ReadableStream, mkReadableStreamFromAff)
import GulpPurescript.Which (Which, which)

foreign import argv :: Array String

rtsOpts :: Array String
rtsOpts =
  let startIndex = Array.elemIndex "--psc-rts-flags" argv
  in case startIndex of
    Just i -> ["+RTS"] <> Array.drop (i + 1) argv <> ["-RTS"]
    _ -> []

type Effects eff =
  ( cp :: ChildProcess
  , glob :: Glob
  , logalot :: Logalot
  , os :: OS
  , resolveBin :: ResolveBin
  , stream :: Stream
  , which :: Which
  | eff
  )

type Errorback eff = Error -> Eff (Effects eff) Unit

type Callback eff a = a -> Eff (Effects eff) Unit

nodeCommand :: String
nodeCommand = "node"

pursPackage :: String
pursPackage = "purescript"

psciFilename :: String
psciFilename = ".psci"

psciLoadModuleCommand :: String
psciLoadModuleCommand = ":m"

psciLoadForeignCommand :: String
psciLoadForeignCommand = ":f"

pscCommand :: String
pscCommand = "psc"

pscBundleCommand :: String
pscBundleCommand = "psc-bundle"

pscDocsCommand :: String
pscDocsCommand = "psc-docs"

foreign import cwd :: String

throwPluginError :: forall eff result. String -> Aff (Effects eff) result
throwPluginError = throwError <<< mkPluginError "gulp-purescript"

resolve :: forall eff. String -> Array String -> Aff (Effects eff) (Tuple String (Array String))
resolve cmd args = catchError primary fallback
  where
    primary :: Aff (Effects eff) (Tuple String (Array String))
    primary = do
      bin <- resolveBin pursPackage { executable: cmd }
      os <- liftEff platform
      pure $ case os of
                  Just Win32 -> tuple2 nodeCommand ([bin] <> args)
                  _ -> tuple2 bin args

    fallback :: Error -> Aff (Effects eff) (Tuple String (Array String))
    fallback _ = (const $ tuple2 cmd args) <$> catchError (which cmd) mapError

    mapError :: Error -> Aff (Effects eff) String
    mapError _ = throwPluginError ("Failed to find " <> cmd <> ". " <> "Please ensure it is available on your system.")

execute :: forall eff. String -> Array String -> Aff (Effects eff) String
execute cmd args = do
  Tuple cmd' args' <- resolve cmd args
  result <- spawn cmd' args'
  pure result

psc :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream Unit)
psc opts = mkReadableStreamFromAff $ do
  output <- either (throwPluginError <<< show)
                   (execute pscCommand <<< (_ <> rtsOpts))
                   (pscOptions opts)
  if null output
     then pure unit
     else liftEff $ info $ pscCommand <> "\n" <> output

pscBundle :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream File)
pscBundle opts = mkReadableStreamFromAff (either (throwPluginError <<< show) run (pscBundleOptions opts))
  where
    run :: Array String -> Aff (Effects eff) File
    run args = mkFile "." <$> mkBufferFromString
                          <$> execute pscBundleCommand args

pscDocs :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream File)
pscDocs opts = mkReadableStreamFromAff (either (throwPluginError <<< show) run (pscDocsOptions opts))
  where
    run :: Array String -> Aff (Effects eff) File
    run args = mkFile "." <$> mkBufferFromString
                          <$> execute pscDocsCommand args

psci :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream File)
psci opts = mkReadableStreamFromAff (either (throwPluginError <<< show) run (read opts))
  where
    run :: Psci -> Aff (Effects eff) File
    run (Psci a) = do
      srcs <- globAll (either pure id a.src)

      let lines = loadModule <$> Array.concat srcs
          buffer = mkBufferFromString (joinWith "\n" lines)

      pure (mkFile psciFilename buffer)

    loadModule :: String -> String
    loadModule a = psciLoadModuleCommand <> " " <> relative cwd a

    loadForeign :: String -> String
    loadForeign a = psciLoadForeignCommand <> " " <> relative cwd a

module GulpPurescript.Plugin
  ( Effects
  , Errorback
  , Callback
  , psc
  , pscBundle
  , pscDocs
  , psci
  ) where

import Prelude (Unit, ($), (<>), (<$>), (<*>), (<<<), (>>=), (+), bind, const, id, pure, show, unit)

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Error.Class (catchError, throwError)

import Data.Array (elemIndex, drop, concat) as Array
import Data.Either (either)
import Data.Foreign (Foreign)
import Data.Foreign.Class (read)
import Data.Maybe (Maybe(Just))
import Data.String (joinWith, null)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested (tuple2)

import GulpPurescript.Buffer (mkBufferFromString)
import GulpPurescript.ChildProcess (ChildProcess, spawn)
import GulpPurescript.Glob (Glob, globAll)
import GulpPurescript.GulpUtil (File, mkFile, mkPluginError)
import GulpPurescript.Logalot (Logalot, info)
import GulpPurescript.OS (OS, Platform(Win32), platform)
import GulpPurescript.Options (Psci(..), pscOptions, pscBundleOptions, pscDocsOptions)
import GulpPurescript.Path (relative)
import GulpPurescript.ResolveBin (ResolveBin, resolveBin)
import GulpPurescript.Stream (Stream, ReadableStream, mkReadableStreamFromAff)
import GulpPurescript.Which (Which, which)

foreign import argv :: Array String

rtsOpts :: Array String
rtsOpts =
  let startIndex = Array.elemIndex "--psc-rts-flags" argv
  in case startIndex of
    Just i -> ["+RTS"] <> Array.drop (i + 1) argv <> ["-RTS"]
    _ -> []

type Effects eff =
  ( cp :: ChildProcess
  , glob :: Glob
  , logalot :: Logalot
  , os :: OS
  , resolveBin :: ResolveBin
  , stream :: Stream
  , which :: Which
  | eff
  )

type Errorback eff = Error -> Eff (Effects eff) Unit

type Callback eff a = a -> Eff (Effects eff) Unit

nodeCommand :: String
nodeCommand = "node"

pursPackage :: String
pursPackage = "purescript"

psciFilename :: String
psciFilename = ".psci"

psciLoadModuleCommand :: String
psciLoadModuleCommand = ":m"

psciLoadForeignCommand :: String
psciLoadForeignCommand = ":f"

pscCommand :: String
pscCommand = "psc"

pscBundleCommand :: String
pscBundleCommand = "psc-bundle"

pscDocsCommand :: String
pscDocsCommand = "psc-docs"

foreign import cwd :: String

throwPluginError :: forall eff result. String -> Aff (Effects eff) result
throwPluginError = throwError <<< mkPluginError "gulp-purescript"

resolve :: forall eff. String -> Array String -> Aff (Effects eff) (Tuple String (Array String))
resolve cmd args = catchError primary fallback
  where
    primary :: Aff (Effects eff) (Tuple String (Array String))
    primary = do
      bin <- resolveBin pursPackage { executable: cmd }
      os <- liftEff platform
      pure $ case os of
                  Just Win32 -> tuple2 nodeCommand ([bin] <> args)
                  _ -> tuple2 bin args

    fallback :: Error -> Aff (Effects eff) (Tuple String (Array String))
    fallback _ = (const $ tuple2 cmd args) <$> catchError (which cmd) mapError

    mapError :: Error -> Aff (Effects eff) String
    mapError _ = throwPluginError ("Failed to find " <> cmd <> ". " <> "Please ensure it is available on your system.")

execute :: forall eff. String -> Array String -> Aff (Effects eff) String
execute cmd args = do
  Tuple cmd' args' <- resolve cmd args
  result <- spawn cmd' args'
  pure result

psc :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream Unit)
psc opts = mkReadableStreamFromAff $ do
  output <- either (throwPluginError <<< show)
                   (execute pscCommand <<< (_ <> rtsOpts))
                   (pscOptions opts)
  if null output
     then pure unit
     else liftEff $ info $ pscCommand <> "\n" <> output

pscBundle :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream File)
pscBundle opts = mkReadableStreamFromAff (either (throwPluginError <<< show) run (pscBundleOptions opts))
  where
    run :: Array String -> Aff (Effects eff) File
    run args = mkFile "." <$> mkBufferFromString
                          <$> execute pscBundleCommand args

pscDocs :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream File)
pscDocs opts = mkReadableStreamFromAff (either (throwPluginError <<< show) run (pscDocsOptions opts))
  where
    run :: Array String -> Aff (Effects eff) File
    run args = mkFile "." <$> mkBufferFromString
                          <$> execute pscDocsCommand args

psci :: forall eff. Foreign -> Eff (Effects eff) (ReadableStream File)
psci opts = mkReadableStreamFromAff (either (throwPluginError <<< show) run (read opts))
  where
    run :: Psci -> Aff (Effects eff) File
    run (Psci a) = do
      srcs <- globAll (either pure id a.src)

      let lines = loadModule <$> Array.concat srcs
          buffer = mkBufferFromString (joinWith "\n" lines)

      pure (mkFile psciFilename buffer)

    loadModule :: String -> String
    loadModule a = psciLoadModuleCommand <> " " <> relative cwd a

    loadForeign :: String -> String
    loadForeign a = psciLoadForeignCommand <> " " <> relative cwd a


More tests

More tests

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console (log, CONSOLE())
import Test.Assert

import Node.Buffer
import Node.Encoding

type Test = forall e. Eff (assert :: ASSERT, buffer :: BUFFER, console :: CONSOLE | e) Unit

main :: Test
main = do
  log "Testing..."

  log "Reading and writing"
  testReadWrite

  log "fromArray"
  testFromArray

  log "toArray"
  testToArray

  log "fromString"
  testFromString

  log "toString"
  testToString

  log "readString"
  testReadString

testReadWrite :: Test
testReadWrite = do
  buf <- create 1
  let val = 42
  write UInt8 val 0 buf
  readVal <- read UInt8 0 buf

  assertEq val readVal

testFromArray :: Test
testFromArray = do
  buf <- fromArray [1,2,3,4,5]
  readVal <- read UInt8 2 buf

  assertEq 3 readVal

testToArray :: Test
testToArray = do
  let val = [1,2,67,3,3,7,8,3,4,237]

  buf    <- fromArray val
  valOut <- toArray buf

  assertEq val valOut

testFromString :: Test
testFromString = do
  let str = "hello, world"

  buf <- fromString str ASCII
  val <- read UInt8 6 buf

  assertEq val 32 -- ASCII space

testToString :: Test
testToString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- toString ASCII buf

  assertEq str strOut

testReadString :: Test
testReadString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- readString ASCII 7 12 buf

  assertEq "world" strOut

assertEq :: forall a. (Eq a, Show a) => a -> a -> Test
assertEq x y =
  if x == y
    then return unit
    else let msg = show x ++ " and " ++ show y ++ " were not equal."
         in assert' msg false

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console (log)
import Test.Assert

import Node.Buffer

main :: Eff _ Unit
main = do
  log "Testing..."
  log "Reading and writing"
  testReadWrite
  log "fromArray"
  testFromArray
  log "toArray"
  testToArray

testReadWrite :: Eff _ Unit
testReadWrite = do
  buf <- create 1
  let val = 42
  write UInt8 val 0 buf
  readVal <- read UInt8 0 buf

  assertEq val readVal

testFromArray :: Eff _ Unit
testFromArray = do
  buf <- fromArray [1,2,3,4,5]
  readVal <- read UInt8 2 buf

  assertEq 3 readVal

testToArray :: Eff _ Unit
testToArray = do
  let val = [1,2,67,3,3,7,8,3,4,237]

  buf    <- fromArray val
  valOut <- toArray buf

  assertEq val valOut

assertEq :: forall a. (Eq a, Show a) => a -> a -> Eff _ Unit
assertEq x y =
  if x == y
    then return unit
    else let msg = show x ++ " and " ++ show y ++ " were not equal."
         in assert' msg false


Add `not` precedence test

Add `not` precedence test

module Main where

import Control.Monad.Eff
import Debug.Trace

foreign import data Assert :: !

foreign import assert
  """
  function assert(x) {
    return function(desc) {
      return function() {
        if (!x) throw new Error('assertion (' + desc + ') failed');
        return {};
      };
    };
  }
  """ :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit

bug :: Number -> Number -> Number
bug a b = 0 - (a - b)

foreign import explode
  """
  function explode() {
    throw new Error('Assertion failed!');
  }
  """ :: forall eff a. Eff eff a

main = do
    assert (bug 0 2 == 2)       "bug 0 2 == 2"
    assert (0 - (0 - 2) == 2)   "0 - (0 - 2) == 2"
    assert (0 - (0 + 2) == -2)  "0 - (0 + 2) == -2"

    assert (6 / (3 * 2) == 1)   "6 / (3 * 2) == 1"
    assert ((6 / 3) * 2 == 4)   "(6 / 3) * 2 == 4"

    assert (6 % (2 * 2) == 2)   "6 % (2 * 2) == 2"
    assert ((6 % 2) * 2 == 0)   "(6 % 2) * 2 == 0"

    assert (4 % (9 / 3) == 1)   "4 % (9 / 3) == 1"
    assert ((4 % 9) / 2 == 2)   "(4 % 9) / 2 == 2"

    assert (not (1 < 0) == true)   "not (1 < 0) == true"


added tests for arithmetic sequences

added tests for arithmetic sequences

module Test.Evaluator where

import Prelude (Unit, bind, (++), ($), show, unit, return, (==), (<<<), (+), negate, (*))
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.StrMap as M
import Data.List (List, singleton)

import Text.Parsing.Parser (runParser)

import Control.Monad.Writer (Writer, tell)

import Parser (definitions, expression)
import Evaluator (eval, eval1, runEvalM, defsToEnv)
import Test.Parser (prelude)

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

eval1test :: String -> String -> String -> Writer (List String) Unit
eval1test name input expected = case (Tuple (runParser input expression) (runParser expected expression)) of
  (Tuple (Right inExp) (Right expExp)) ->
    case runEvalM (eval1 M.empty inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then return unit -- log $ "Eval success (" ++ name ++ ")"
          else tell' $ "Eval fail (" ++ name ++ "): " ++ show eval1Exp ++ " should be " ++ show expExp
      (Left err) -> tell' $ "Eval fail (" ++ name ++ "): " ++ show err ++ ")"
  _ -> tell' $ "Parse fail (" ++ name ++ ")"

eval1EnvTest :: String -> String -> String -> String -> Writer (List String) Unit
eval1EnvTest name env input expected = case (Tuple (Tuple (runParser input expression) (runParser expected expression)) (runParser env definitions)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    case runEvalM (eval1 (defsToEnv defs) inExp) of
      (Right eval1Exp) ->
        if eval1Exp == expExp
          then return unit -- log $ "Eval success (" ++ name ++ ")"
          else tell' $ "Eval fail (" ++ name ++ "): " ++ show eval1Exp ++ " should be " ++ show expExp
      (Left err) -> tell' $ "Eval fail (" ++ name ++ "): " ++ show err ++ ")"
  _ -> tell' $ "Parse fail (" ++ name ++ ")"

evalEnvTest :: String -> String -> String -> String -> Writer (List String) Unit
evalEnvTest name env input expected = case (Tuple (Tuple (runParser input expression) (runParser expected expression)) (runParser env definitions)) of
  (Tuple (Tuple (Right inExp) (Right expExp)) (Right defs)) ->
    let evalExp = eval (defsToEnv defs) inExp in
      if evalExp == expExp
        then return unit -- log $ "Eval success (" ++ name ++ ")"
        else tell' $ "Eval fail (" ++ name ++ "): " ++ show evalExp ++ " should be " ++ show expExp
  (Tuple (Tuple pi pe) pd) -> tell' $ "Parse fail (" ++ name ++ "): (input: " ++ show pi ++ ", expected: " ++ show pe ++ ", definitions: " ++ show pd ++ ")"

runTests :: Writer (List String) Unit
runTests = do
  eval1test "add" "1+1" "2"
  eval1test "power" "2^10" "1024"
  eval1test "append" "[1] ++ [2]" "[1, 2]"
  eval1test "cons" "True:[]" "[True]"
  eval1test "lambda" "(\\a b -> a + b) 1 2" "1 + 2"
  eval1test "section1" "(*5) 7" "35"
  eval1test "section2" "(10<) 8" "False"
  eval1test "prefix" "(&&) True True" "True"
  eval1test "if_then_else" "if True then 42 else 0" "42"
  eval1test "pattern_matching1" "(\\(x:xs) -> x) [1, 2, 3]" "1"
  eval1test "pattern_matching2" "(\\[a, b, c] -> c) [1, 2, 3]" "3"
  eval1test "pattern_matching3" "(\\(a, b) (c, d, e) -> d) (1, 2) (3, 2*2, 5)" "2*2"
  eval1test "lambda2" "(\\x y -> [0, x, y, x + y]) 1 2" "[0, 1, 2, 1 + 2]"
  eval1test "string1" "\"as\" ++ \"df\"" "\"asdf\""
  eval1test "string2" "'a' : \"sdf\"" "\"asdf\""

  eval1EnvTest "double_func" "double x = x + x" "double 10" "10 + 10"
  eval1EnvTest "map_func1" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) []" "[]"
  eval1EnvTest "map_func2" "map f [] = []\nmap f (x:xs) = f x : map f xs" "map (^2) [1, 2, 3]" "(^2) 1 : map (^2) [2, 3]"

  evalEnvTest "evalAll1" "" "1 + 2 + 3" "6"
  evalEnvTest "evalAll2" "" "(2^10) > (10^2)" "True"
  evalEnvTest "evalAll3" "" "3" "3"
  evalEnvTest "evalAll4" "" "x + y" "x + y"
  evalEnvTest "evalAll5" "" "(2 * 5) * x + 2 ^ 3" "10 * x + 8"
  evalEnvTest "evalAll6" "" "1 / 0" "1 / 0"

  evalEnvTest "evalNegNumber1" "" "(-3) - (-4)" "1"
  evalEnvTest "evalNegNumber2" "" "(-2) * (-2)" "4"
  evalEnvTest "evalNegNumber3" "" "-(-(5*5) + 6*6) + 7*7" (show (-(-(5*5) + 6*6) + 7*7)) -- 38
  evalEnvTest "evalNegNumber4" "" "-3 * 7 + 23" "2"

  evalEnvTest "if1" "" "if 10 > 5 then 10 else 5" "10"
  evalEnvTest "if2" "" "if 2 /= 2 then 1 else 0" "0"
  evalEnvTest "if3" "" "if x >= y then 5 * 5 else 6 * 6" "if x >= y then 5 * 5 else 6 * 6"

  evalEnvTest "env1" "x = 10" "x" "10"
  evalEnvTest "env2" "x = 10\ny = 20" "x * y" "200"
  evalEnvTest "env3" "double x = x + x" "double 10" "20"
  evalEnvTest "env4" "double x = x + x" "double (double (double 10))" "80"
  evalEnvTest "env5" "double x = x + x" "double $ double $ double 10" "80"
  evalEnvTest "env6" "double x = x + x" "(double . double . double) 10" "80"
  evalEnvTest "env6" "length (_:xs) = 1 + length xs\nlength [] = 0" "length [1, 2, 3, 4, 5]" "5"

  evalEnvTest "eval_list" "" "[2 + 2, 3 * 3]" "[4, 9]"
  evalEnvTest "eval_tuple" "" "(2+2, 3 * 3)" "(4, 9)"

  -- This test gets stuck in an endless loop,
  -- evalEnvTest "fix" "f x = f x" "f 10" "f 10"

  evalEnvTest "fac" "fac 1 = 1\nfac n = n * fac (n - 1)" "fac 6" "720"
  evalEnvTest "prelude" prelude "sum (map (^2) [1,2,3,4])" "30"

  evalEnvTest "TAE2a"
    ( prelude ++ "\n" ++
      "pair (x:y:rs) = (x, y) : pair (y:rs)\n" ++
      "pair _        = []")
    "pair [1, 2, 3, 4]"
    "[(1, 2), (2, 3), (3, 4)]"
  evalEnvTest "TAE2b" prelude "foldr (\\a b -> a + b * 10) 0 [3, 2, 1]" "123"
  evalEnvTest "TAE2c"
    (prelude ++ "\nsublist f t ls = drop f (take (t + f) ls)\n")
    "sublist 1 3 [0, 1, 2, 3, 4]"
    "[1, 2, 3]"

  evalEnvTest "TAE3a" prelude "map (>= 2) [1, 2, 3]" "[False, True, True]"
  evalEnvTest "TAE3b" prelude "foldr (\\a b -> b ++ [a]) [] [1, 2, 3]" "[3, 2, 1]"
  evalEnvTest "TAE3c" prelude "take 3 (iterate (3*) 1)" "[1, 3, 9]"
  evalEnvTest "TAE3d" prelude "filter (const True) [1, 3, 5, 7]" "[1, 3, 5, 7]"
  evalEnvTest "TAE3e" prelude "map (length . snd) [(7, \"sieben\"), (1, \"eins\")]" "[6, 4]"
  evalEnvTest "TAE3f" prelude "foldr (:) [3, 4] [1, 2]" "[1, 2, 3, 4]"
  evalEnvTest "TAE3g" prelude "foldl (\\(i, c) s -> (i + 1, c + length s)) (0, 0) [\"a\", \"bc\", \"defg\"]" "(3, 7)"

  evalEnvTest "TAT2a"
    (prelude ++ "\nnth ls n = head (drop n ls)\n")
    "nth [0, 1, 2, 3] 2"
    "2"
  evalEnvTest "TAT2b"
    ( prelude ++ "\n" ++
      "smallest (x:y:rs) = if x < y then smallest (x:rs) else smallest (y:rs)\n" ++
      "smallest [x]      = x")
    "smallest [5, 3, 7]"
    "3"
  evalEnvTest "TAT2c" prelude "foldl (\\(s, p) i -> (i + s, i * p)) (0, 1) [2, 3, 4]" "(9, 24)"

  evalEnvTest "TAT3a" prelude "map (2^) [1, 2, 3]" "[2, 4, 8]"
  evalEnvTest "TAT3b" prelude "foldl (*) 1 [1, 2, 3, 4]" "24"
  evalEnvTest "TAT3c" prelude "map (== 3) [1, 2, 3, 4]" "[False, False, True, False]"
  evalEnvTest "TAT3d" prelude "filter (/= 's') \"asdf\"" "\"adf\""
  evalEnvTest "TAT3e" prelude "map (fst . head) [[(1, 2)], [(3, 4)]]" "[1, 3]"
  evalEnvTest "TAT3f" prelude "foldl (-) 10 [1, 2, 3]" "4"
  evalEnvTest "TAT3g" prelude "zipWith (\\a b -> map (+a) b) [1, 2] [[3, 4], [5, 6]]" "[[4, 5], [7, 8]]"

  evalEnvTest "string_third1" "thrd (_:(_:(x:_))) = x" "thrd \"1234\"" "'3'"
  evalEnvTest "string_third2" "thrd [_,_,x,_] = x" "thrd \"1234\"" "'3'"

  evalEnvTest "pattern_matching4" "f ( x :  y : z : rs  ) = (x + y + z) * length rs\nlength (_:xs) = 1 + length xs\nlength [] = 0" "f [2, 3, 5, 8, 11]" "20"
  evalEnvTest "pattern_matching5" "f ( [ x ] : [ y , z ] : [ ] ) = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching6" "f [  [ x ] , [ y , z ] ] = x + y + z" "f [[1],[2,3]]" "6"
  evalEnvTest "pattern_matching7" "f [(a:b:c:rs1), (x:y:z:rs2)] = a * x + b * y + c * z" "f [[1, 2, 3], [100, 10, 1]]" "123"

  evalEnvTest "eval_names" "nat = [1, 2, 3, 4, 5]" "nat" "[1, 2, 3, 4, 5]"

  evalEnvTest "infix_functions_1" prelude "3 `take` (2 `drop` [1, 2, 3, 4, 5, 6, 7])" "[3, 4, 5]"
  evalEnvTest "infix_functions_2" prelude "(\\x -> x `mod` 2 == 0) `filter` [1, 2, 3, 4, 5, 6]" "[2, 4, 6]"
  evalEnvTest "infix_functions_3" prelude "(*2) `map` [1, 2, 3]" "[2, 4, 6]"

  evalEnvTest "arithmetic_sequences_1" prelude "sum [1, 3 .. 100]" "2500"
  --call-stack-size-error
  --evalEnvTest "arithmetic_sequences_2" prelude "sum [1 .. 50]" "1250"
  evalEnvTest "arithmetic_sequences_3" prelude "length [ 7 * 7, 8 * 8 .. 42 * 42]" "115"
  --call-stack-size-error
  --evalEnvTest "arithmetic_sequences_4" prelude "sum [ head (drop 50 [7..70]) .. length [1..100]]" "3454"
  evalEnvTest "arithmetic_sequences_5" prelude "sum $ take 100 [500 ..]" "54950"
  evalEnvTest "arithmetic_sequences_6" prelude "[1, -1 .. 0]" "[1]"
  evalEnvTest "arithmetic_sequences_7" prelude "sum [10, 9 .. -10]" "0"
  evalEnvTest "arithmetic_sequences_8" prelude "[True .. False]" "[]"
  evalEnvTest "arithmetic_sequences_9" prelude "[True, False ..]" "[True, False]"
  --/= (neq) does not evaluate for lists!
  --evalEnvTest "arithmetic_sequences_10" prelude "[False, False ..] /= [False]" "True"
  evalEnvTest "arithmetic_sequences_11" prelude "[False, True ..]" "[False, True]"
  evalEnvTest "arithmetic_sequences_12" prelude "[True, False ..]" "[True, False]"


Update EuclideanRing docs

Update EuclideanRing docs

module Data.EuclideanRing
  ( class EuclideanRing, degree, div, mod, (/)
  , gcd
  , lcm
  , module Data.CommutativeRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.BooleanAlgebra ((||))
import Data.CommutativeRing (class CommutativeRing)
import Data.Eq (class Eq, (==))
import Data.Ring (class Ring, sub, (-))
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `EuclideanRing` class is for commutative rings that support division.
-- | The mathematical structure this class is based on is sometimes also called
-- | a *Euclidean domain*.
-- |
-- | Instances must satisfy the following laws in addition to the `Ring`
-- | laws:
-- |
-- | - Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then
-- |   so is their product `a * b`
-- | - Euclidean function `degree`:
-- |   - Nonnegativity: For all nonzero `a`, `degree a >= 0`
-- |   - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,
-- |     let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also
-- |     either `r = zero` or `degree r < degree b`
-- | - Submultiplicative euclidean function:
-- |   - For all nonzero `a` and `b`, `degree a <= degree (a * b)`
-- |
-- | The behaviour of division by `zero` is unconstrained by these laws,
-- | meaning that individual instances are free to choose how to behave in this
-- | case. Similarly, there are no restrictions on what the result of
-- | `degree zero` is; it doesn't make sense to ask for `degree zero` in the
-- | same way that it doesn't make sense to divide by `zero`, so again,
-- | individual instances may choose how to handle this case.
-- |
-- | For any `EuclideanRing` which is also a `Field`, one valid choice
-- | for `degree` is simply `const 1`. In fact, unless there's a specific
-- | reason not to, `Field` types should normally use this definition of
-- | `degree`.
class CommutativeRing a <= EuclideanRing a where
  degree :: a -> Int
  div :: a -> a -> a
  mod :: a -> a -> a

infixl 7 div as /

instance euclideanRingInt :: EuclideanRing Int where
  degree = intDegree
  div = intDiv
  mod = intMod

instance euclideanRingNumber :: EuclideanRing Number where
  degree _ = 1
  div = numDiv
  mod _ _ = 0.0

foreign import intDegree :: Int -> Int
foreign import intDiv :: Int -> Int -> Int
foreign import intMod :: Int -> Int -> Int

foreign import numDiv :: Number -> Number -> Number

-- | The *greatest common divisor* of two values.
gcd :: forall a. Eq a => EuclideanRing a => a -> a -> a
gcd a b =
  if b == zero
    then a
    else gcd b (a `mod` b)

-- | The *least common multiple* of two values.
lcm :: forall a. Eq a => EuclideanRing a => a -> a -> a
lcm a b =
  if a == zero || b == zero
    then zero
    else a * b / gcd a b

module Data.EuclideanRing
  ( class EuclideanRing, degree, div, mod, (/)
  , gcd
  , lcm
  , module Data.CommutativeRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.BooleanAlgebra ((||))
import Data.CommutativeRing (class CommutativeRing)
import Data.Eq (class Eq, (==))
import Data.Ring (class Ring, sub, (-))
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `EuclideanRing` class is for commutative rings that support division.
-- | The mathematical structure this class is based on is sometimes also called
-- | a *Euclidean domain*.
-- |
-- | Instances must satisfy the following laws in addition to the `Ring`
-- | laws:
-- |
-- | - Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then
-- |   so is their product `a * b`
-- | - Euclidean function `degree`:
-- |   - Nonnegativity: For all nonzero `a`, `degree a >= 0`
-- |   - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,
-- |     let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also
-- |     either `r = zero` or `degree r < degree b`
-- | - Submultiplicative euclidean function:
-- |   - For all nonzero `a` and `b`, `degree a <= degree (a * b)`
-- |
-- | The behaviour of division by `zero` is unconstrained by these laws,
-- | meaning that individual instances are free to choose how to behave in this
-- | case. Similarly, there are no restrictions on what the result of
-- | `degree zero` is; it doesn't make sense to ask for `degree zero` in the
-- | same way that it doesn't make sense to divide by `zero`, so again,
-- | individual instances may choose how to handle this case.
-- |
-- | For any `EuclideanRing` which is also a `Field`, one valid choice
-- | for `degree` is simply `const 1`. In fact, unless there's a specific
-- | reason not to, `Field` types should normally use this definition of
-- | `degree`.
-- |
-- | The `Unit` instance is provided for backwards compatibility, but it is
-- | not law-abiding, because `Unit` fails to form an integral domain. This
-- | instance will be removed in a future release.
class CommutativeRing a <= EuclideanRing a where
  degree :: a -> Int
  div :: a -> a -> a
  mod :: a -> a -> a

infixl 7 div as /

instance euclideanRingInt :: EuclideanRing Int where
  degree = intDegree
  div = intDiv
  mod = intMod

instance euclideanRingNumber :: EuclideanRing Number where
  degree _ = 1
  div = numDiv
  mod _ _ = 0.0

foreign import intDegree :: Int -> Int
foreign import intDiv :: Int -> Int -> Int
foreign import intMod :: Int -> Int -> Int

foreign import numDiv :: Number -> Number -> Number

-- | The *greatest common divisor* of two values.
gcd :: forall a. Eq a => EuclideanRing a => a -> a -> a
gcd a b =
  if b == zero
    then a
    else gcd b (a `mod` b)

-- | The *least common multiple* of two values.
lcm :: forall a. Eq a => EuclideanRing a => a -> a -> a
lcm a b =
  if a == zero || b == zero
    then zero
    else a * b / gcd a b