Remove unused import

Remove unused import

The PureScript compiler warns about unused imports as of 0.7.6.

module Data.Time where

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

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

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

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

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

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

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

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

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

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

instance divisionRingHours :: DivisionRing Hours

instance numHours :: Num Hours

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

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

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

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

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

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

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

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

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

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

instance divisionRingMinutes :: DivisionRing Minutes

instance numMinutes :: Num Minutes

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

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

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

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

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

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

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

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

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

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

instance divisionRingSeconds :: DivisionRing Seconds

instance numSeconds :: Num Seconds

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

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

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

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

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

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

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

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

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

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

instance divisionRingMilliseconds :: DivisionRing Milliseconds

instance numMilliseconds :: Num Milliseconds

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

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

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

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

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

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

module Data.Time where

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

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

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

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

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

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

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

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

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

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

instance divisionRingHours :: DivisionRing Hours

instance numHours :: Num Hours

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

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

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

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

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

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

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

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

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

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

instance divisionRingMinutes :: DivisionRing Minutes

instance numMinutes :: Num Minutes

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

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

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

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

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

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

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

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

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

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

instance divisionRingSeconds :: DivisionRing Seconds

instance numSeconds :: Num Seconds

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

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

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

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

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

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

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

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

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

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

instance divisionRingMilliseconds :: DivisionRing Milliseconds

instance numMilliseconds :: Num Milliseconds

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

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

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

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

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

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


arithmeticSequence evaluation fix

arithmeticSequence evaluation fix

module Evaluator where

import Prelude (class Show, top, bottom, class Semigroup, class Monad, Unit, Ordering(..), (++), ($), unit, return, (<*>), (<$>), pure, void, (==), otherwise, (>>=), (<), negate, (>), (>=), (<=), (/=), (-), (+), mod, div, (*), (<<<), compare, id, const, bind, show, map)
import Data.List (List(Nil, Cons), singleton, concatMap, intersect, zipWith, zipWithA, length, (:), replicate, drop, updateAt, (!!),concat)
import Data.StrMap (StrMap)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple), fst, snd)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity, runIdentity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (fromChar, toChar)
import Data.Enum (class Enum, fromEnum, toEnum, succ)
import Control.Bind (join)
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Control.Monad.State.Trans (StateT, modify, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..),Path(..))

data EvalError =
    PathError Path Expr
  | IndexError Int Int
  | DivByZero
  | EvalError Expr
  | BinaryOpError Op Expr Expr
  | UnaryOpError Op Expr
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | CannotEvaluate Expr
  | 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 (PathError p e)            = "PathError " ++ show p ++ " " ++ show e
  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 (CannotEvaluate e)         = "CannotEvaluate " ++ show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " ++ show e1 ++ " " ++ show e2 ++ ")"

data MatchingError =
    MatchingError Binding Expr
  | StrictnessError Binding Expr
  | TooFewArguments (List Binding) (List Expr)

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 = runIdentity <<< runExceptT

type Matcher = ExceptT MatchingError Identity

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

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr    <$> go p ce <*> pure te <*> pure ee
    ArithmSeq s b e -> ArithmSeq <$> go p s <*> pure b <*> pure e
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ PathError (Fst p) e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    ArithmSeq s b e -> ArithmSeq <$> pure s <*> (mapM' (go p) b) <*> pure e
    _               -> throwError $ PathError (Snd p) e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    ArithmSeq s b (Just e) -> ArithmSeq <$> pure s <*> pure b <*> (Just <$> (go p e))
    _               -> throwError $ PathError (Thrd p) e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ PathError (Nth n p) e

mapIndex :: forall a. Int -> (a -> Evaluator a) -> (List a) -> Evaluator (List a)
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ IndexError i (length as)
    Just a  -> do
      a' <- f a
      case updateAt i a' as of
        Nothing  -> throwError $ IndexError i (length as)
        Just as' -> return as'

evalPath1 :: Env -> Path -> Expr -> Either EvalError Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

evalPathAll :: Env -> Path -> Expr -> Either EvalError Expr
evalPathAll env path expr = runEvalM $ mapWithPath path (return <<< eval env) expr

type Env = StrMap (List (Tuple (List Binding) Expr))

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

envToDefs :: Env -> (List Definition)
envToDefs env = concat $ map tupleToDef $ Data.StrMap.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

eval1 :: Env -> Expr -> Evaluator Expr
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 _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
  (ArithmSeq start step end)         -> evalArithmSeq $ ArithmSeq start step end
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) (Cons e Nil)) -> return $ App f (singleton $ App 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 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) (Cons e1 Nil))           -> binary env op e1 e2 <|> (return $ Binary op e1 e2)
  (App (PrefixOp op) (Cons e1 (Cons e2 Nil)))         -> binary env op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _                                  -> throwError $ CannotEvaluate expr

eval :: Env -> Expr -> Expr
eval env expr = evalToBinding env expr (Lit (Name "_|_"))

evalToBinding :: Env -> Expr -> Binding -> Expr
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 Colon e es) -> Binary Colon (evalToBinding env e b) (evalToBinding env es bs)
    (List (Cons e es))  -> evalToBinding env (Binary Colon e (List es)) bind
    _                   -> recurse env expr bind

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

  (NTupleLit bs)     -> case expr of
    (NTuple es)  -> NTuple (zipWith (evalToBinding env) es bs)
    _            -> recurse env expr bind

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

wrapLambda :: (List Binding) -> (List Expr) -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

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

atomNext :: Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNext (AInt i) = atomNextTo (AInt i) (AInt top)
atomNext (Bool b) = atomNextTo (Bool b) (Bool top)
atomNext (Char x) = atomNextTo (Char x) (Char (fromChar top))
atomNext _ = Tuple Nothing Nothing

--allways rising sequence
atomNextTo :: Atom -> Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNextTo (AInt x) (AInt y) = if x == y then Tuple (Just (AInt y)) Nothing else
  if x < y then Tuple (Just (AInt x)) (Just (AInt (x + 1))) else Tuple Nothing Nothing
atomNextTo (Bool x) (Bool y) = if x == y then Tuple (Just (Bool y)) Nothing else
  if x < y then Tuple (Just (Bool x)) (Bool <$> (succ x)) else Tuple Nothing Nothing
atomNextTo (Char x) (Char y) = case toChar x of
  Just a -> case toChar y of
    Just b  -> if a == b then Tuple (Just (Char y)) Nothing else
                 if a < b then Tuple (Just (Char x)) ((Char <<< fromChar) <$> (succ a))
                          else Tuple Nothing Nothing
    Nothing -> Tuple Nothing Nothing
  Nothing -> Tuple Nothing Nothing
atomNextTo _ _ = Tuple Nothing Nothing

intNextStepTo :: Int -> Int -> Int -> Tuple (Maybe Int) (Maybe Int)
intNextStepTo x y z = case x == z of
  true  -> Tuple (Just z) Nothing
  false -> case x <= y of
    true  -> if x > z then Tuple Nothing Nothing else Tuple (Just x) (Just (y + y - x))
    false -> if x < z then Tuple Nothing Nothing else Tuple (Just x) (Just (y + y - x))

eNextStepTo :: forall e. (Enum e) => e -> e -> e -> Tuple (Maybe e) (Maybe e)
eNextStepTo x y z = case (fromEnum x) <= (fromEnum y) of
  true  -> Tuple (join (toEnum <$> (fst tup))) ((\q -> fromMaybe top (toEnum q)) <$> (snd tup))
  false -> Tuple (join (toEnum <$> (fst tup))) ((\q -> fromMaybe bottom (toEnum q)) <$> (snd tup))
  where tup = intNextStepTo (fromEnum x) (fromEnum y) (fromEnum z)

atomNextStepTo :: Atom -> Atom -> Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNextStepTo (AInt x) (AInt y) (AInt z) = let tup = intNextStepTo x y z in
  Tuple (AInt <$> (fst tup)) (AInt <$> (snd tup))
atomNextStepTo (Bool x) (Bool y) (Bool z) = let tup = eNextStepTo x y z in
  Tuple (Bool <$> (fst) tup) (Bool <$> (snd tup))
atomNextStepTo (Char x) (Char y) (Char z) = case toChar x of
  Nothing -> Tuple Nothing Nothing
  Just a  -> case toChar y of
    Nothing -> Tuple Nothing Nothing
    Just b  -> case toChar z of
      Nothing -> Tuple Nothing Nothing
      Just c  -> let tup = eNextStepTo a b c in
        Tuple ((Char <<< fromChar) <$> (fst tup)) ((Char <<< fromChar) <$> (snd tup))
atomNextStepTo _ _ _ = Tuple Nothing Nothing

atomNextStep :: Atom -> Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNextStep (AInt x) (AInt y) = case x < y of
  true  -> atomNextStepTo (AInt x) (AInt y) (AInt top)
  false -> atomNextStepTo (AInt x) (AInt y) (AInt bottom)
atomNextStep (Bool x) (Bool y) = case x < y of
  true  -> atomNextStepTo (Bool x) (Bool y) (Bool top)
  false -> atomNextStepTo (Bool x) (Bool y) (Bool bottom)
atomNextStep (Char x) (Char y) = case toChar x of
  Just a  -> case toChar y of
    Just b  -> if a < b then atomNextStepTo (Char x) (Char y) (Char (fromChar top))
                        else atomNextStepTo (Char x) (Char y) (Char (fromChar bottom))
    Nothing -> Tuple Nothing Nothing
  Nothing -> Tuple Nothing Nothing
atomNextStep _ _ = Tuple Nothing Nothing

evalArithmSeq :: Expr -> Evaluator Expr
evalArithmSeq as = case as of
  ArithmSeq (Atom (AInt _)) _ _ -> evalArithmSeq' as
  ArithmSeq (Atom (Bool _)) _ _ -> evalArithmSeq' as
  ArithmSeq (Atom (Char _)) _ _ -> evalArithmSeq' as
  _                             -> throwError $ CannotEvaluate as
  where
    evalArithmSeq' :: Expr -> Evaluator Expr
    evalArithmSeq' as = case as of
      ArithmSeq (Atom x) Nothing Nothing -> case atomNext x of
        Tuple Nothing _         -> return $ List Nil
        Tuple (Just a) Nothing  -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just b) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom b) Nothing Nothing)

      ArithmSeq (Atom x) (Just (Atom y)) Nothing -> case atomNextStep x y of
        Tuple Nothing _                -> return $ List Nil
        Tuple (Just a) Nothing         -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just nextStep) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom y) (Just (Atom nextStep)) Nothing)

      ArithmSeq (Atom x) Nothing end@(Just (Atom z)) -> case atomNextTo x z of
        Tuple Nothing _         -> return $ List Nil
        Tuple (Just a) Nothing  -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just b) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom b) Nothing Nothing)

      ArithmSeq (Atom x) (Just (Atom y)) end@(Just (Atom z)) -> case atomNextStepTo x y z of
        Tuple Nothing _                -> return $ List Nil
        Tuple (Just a) Nothing         -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just nextStep) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom y) (Just (Atom nextStep)) end)

      _ -> throwError $ CannotEvaluate as

------------------------------------------------------------------------------------------
-- Arithmetic Sequences End
------------------------------------------------------------------------------------------

binary :: Env -> Op -> Expr -> Expr -> Evaluator Expr
binary env op = case op 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) -> return $ List $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List ls1) (List ls2)) -> return $ List $ 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)) _                  ) -> return $ Atom $ Bool false
    (Tuple _                   (Atom (Bool false))) -> return $ Atom $ Bool false
    (Tuple (Atom (Bool true))  (Atom (Bool true)) ) -> return $ Atom $ Bool true
    (Tuple _                   _                  ) -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom (Bool true))  _                   ) -> return $ Atom $ Bool true
    (Tuple _                   (Atom (Bool true))  ) -> return $ Atom $ Bool true
    (Tuple (Atom (Bool false))  (Atom (Bool false))) -> return $ Atom $ Bool false
    (Tuple _                   _                   ) -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> return $ App f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  InfixFunc name -> \e1 e2 -> apply env name (e1 : e2 : Nil)
  where
    aint :: Op -> (Int -> Int -> Int) -> Expr -> Expr -> Evaluator Expr
    aint _   f (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ f i j
    aint op  _ e1              e2              = throwError $ BinaryOpError op e1 e2

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

unary :: Env -> Op -> Expr -> Evaluator Expr
unary env Sub (Atom (AInt i)) = return $ Atom $ AInt (-i)
unary env op e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List Expr) -> Evaluator Expr
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

--builtin ipo
division :: Expr -> Expr -> Evaluator Expr
division (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
division (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ div i j
division e1 e2 = throwError $ BinaryOpError (InfixFunc "div") e1 e2

--builtin mod
modulo :: Expr -> Expr -> Evaluator Expr
modulo (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
modulo (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List Binding) Expr)) -> (List Expr) -> String -> (List MatchingError) -> Evaluator Expr
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 :: Expr -> Boolean
whnf (Atom (Name _)) = false
whnf (Atom _)        = true
whnf (List _)        = true
whnf (NTuple _)      = true
whnf _               = false

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

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

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

match' (ConsLit b bs)    (Binary Colon e es)  = match' b e *> match' bs es
match' (ConsLit b bs)    (List (Cons e es))  = match' (ConsLit b bs) (Binary Colon e (List es))
match' (ConsLit b bs)    (List Nil)           = throwError $ MatchingError (ConsLit b bs) (List Nil)
match' (ConsLit b bs)    e                   = throwError $ checkStrictness (ConsLit b bs) e

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

match' (NTupleLit bs)    (NTuple es)         = case length bs == length es of
                                                 true  -> void $ zipWithA match' bs es
                                                 false -> throwError $ MatchingError (NTupleLit bs) (NTuple es)
match' (NTupleLit bs)    e                   = throwError $ checkStrictness (NTupleLit bs) e

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)

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case Map.lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (IfExpr ce te ee)    -> IfExpr <$> go ce <*> go te <*> go ee
    (ArithmSeq ce te ee) -> ArithmSeq <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

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

freeVariables :: Expr -> (List String)
freeVariables _ = Nil
-- freeVariables = nub <<< foldExpr
--   (\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) -> (List String)
boundNames' = concatMap boundNames

boundNames :: Binding -> (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 (class Show, top, bottom, class Semigroup, class Monad, Unit, Ordering(..), (++), ($), unit, return, (<*>), (<$>), pure, void, (==), otherwise, (>>=), (<), negate, (>), (>=), (<=), (/=), (-), (+), mod, div, (*), (<<<), compare, id, const, bind, show, map)
import Data.List (List(Nil, Cons), singleton, concatMap, intersect, zipWith, zipWithA, length, (:), replicate, drop, updateAt, (!!),concat)
import Data.StrMap (StrMap)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple), fst, snd)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity, runIdentity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (fromChar, toChar)
import Data.Enum (class Enum, fromEnum, toEnum, succ)
import Control.Bind (join)
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Control.Monad.State.Trans (StateT, modify, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..),Path(..))

data EvalError =
    PathError Path Expr
  | IndexError Int Int
  | DivByZero
  | EvalError Expr
  | BinaryOpError Op Expr Expr
  | UnaryOpError Op Expr
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | CannotEvaluate Expr
  | 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 (PathError p e)            = "PathError " ++ show p ++ " " ++ show e
  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 (CannotEvaluate e)         = "CannotEvaluate " ++ show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " ++ show e1 ++ " " ++ show e2 ++ ")"

data MatchingError =
    MatchingError Binding Expr
  | StrictnessError Binding Expr
  | TooFewArguments (List Binding) (List Expr)

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 = runIdentity <<< runExceptT

type Matcher = ExceptT MatchingError Identity

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

mapWithPath :: Path -> (Expr -> Evaluator Expr) -> Expr -> Evaluator Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    IfExpr ce te ee -> IfExpr    <$> go p ce <*> pure te <*> pure ee
    ArithmSeq s b e -> ArithmSeq <$> go p s <*> pure b <*> pure e
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ PathError (Fst p) e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    ArithmSeq s b e -> ArithmSeq <$> pure s <*> (mapM' (go p) b) <*> pure e
    _               -> throwError $ PathError (Snd p) e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    ArithmSeq s b (Just e) -> ArithmSeq <$> pure s <*> pure b <*> (Just <$> (go p e))
    _               -> throwError $ PathError (Thrd p) e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ PathError (Nth n p) e

mapIndex :: forall a. Int -> (a -> Evaluator a) -> (List a) -> Evaluator (List a)
mapIndex i f as = do
  case as !! i of
    Nothing -> throwError $ IndexError i (length as)
    Just a  -> do
      a' <- f a
      case updateAt i a' as of
        Nothing  -> throwError $ IndexError i (length as)
        Just as' -> return as'

evalPath1 :: Env -> Path -> Expr -> Either EvalError Expr
evalPath1 env path expr = runEvalM $ mapWithPath path (eval1 env) expr

evalPathAll :: Env -> Path -> Expr -> Either EvalError Expr
evalPathAll env path expr = runEvalM $ mapWithPath path (return <<< eval env) expr

type Env = StrMap (List (Tuple (List Binding) Expr))

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

envToDefs :: Env -> (List Definition)
envToDefs env = concat $ map tupleToDef $ Data.StrMap.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

eval1 :: Env -> Expr -> Evaluator Expr
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 _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
  (ArithmSeq start step end)         -> evalArithmSeq $ ArithmSeq start step end
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) (Cons e Nil)) -> return $ App f (singleton $ App 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 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) (Cons e1 Nil))           -> binary env op e1 e2 <|> (return $ Binary op e1 e2)
  (App (PrefixOp op) (Cons e1 (Cons e2 Nil)))         -> binary env op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _                                  -> throwError $ CannotEvaluate expr

eval :: Env -> Expr -> Expr
eval env expr = evalToBinding env expr (Lit (Name "_|_"))

evalToBinding :: Env -> Expr -> Binding -> Expr
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 Colon e es) -> Binary Colon (evalToBinding env e b) (evalToBinding env es bs)
    (List (Cons e es))  -> evalToBinding env (Binary Colon e (List es)) bind
    _                   -> recurse env expr bind

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

  (NTupleLit bs)     -> case expr of
    (NTuple es)  -> NTuple (zipWith (evalToBinding env) es bs)
    _            -> recurse env expr bind

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

wrapLambda :: (List Binding) -> (List Expr) -> Expr -> Evaluator Expr
wrapLambda binds args body =
  case compare (length binds) (length args) of
    EQ -> return body
    GT -> return $ Lambda (drop (length args) binds) body
    LT -> return $ App body (drop (length binds) args)

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

atomNext :: Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNext (AInt i) = atomNextTo (AInt i) (AInt top)
atomNext (Bool b) = atomNextTo (Bool b) (Bool top)
atomNext (Char x) = atomNextTo (Char x) (Char (fromChar top))
atomNext _ = Tuple Nothing Nothing

--allways rising sequence
atomNextTo :: Atom -> Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNextTo (AInt x) (AInt y) = if x == y then Tuple (Just (AInt y)) Nothing else
  if x < y then Tuple (Just (AInt x)) (Just (AInt (x + 1))) else Tuple Nothing Nothing
atomNextTo (Bool x) (Bool y) = if x == y then Tuple (Just (Bool y)) Nothing else
  if x < y then Tuple (Just (Bool x)) (Bool <$> (succ x)) else Tuple Nothing Nothing
atomNextTo (Char x) (Char y) = case toChar x of
  Just a -> case toChar y of
    Just b  -> if a == b then Tuple (Just (Char y)) Nothing else
                 if a < b then Tuple (Just (Char x)) ((Char <<< fromChar) <$> (succ a))
                          else Tuple Nothing Nothing
    Nothing -> Tuple Nothing Nothing
  Nothing -> Tuple Nothing Nothing
atomNextTo _ _ = Tuple Nothing Nothing

intNextStepTo :: Int -> Int -> Int -> Tuple (Maybe Int) (Maybe Int)
intNextStepTo x y z = case x == z of
  true  -> Tuple (Just z) Nothing
  false -> case x <= y of
    true  -> if x > z then Tuple Nothing Nothing else Tuple (Just x) (Just (y + y - x))
    false -> if x < z then Tuple Nothing Nothing else Tuple (Just x) (Just (y + y - x))

eNextStepTo :: forall e. (Enum e) => e -> e -> e -> Tuple (Maybe e) (Maybe e)
eNextStepTo x y z = Tuple (join (toEnum <$> (fst tup))) (join (toEnum <$> (snd tup)))
  where tup = intNextStepTo (fromEnum x) (fromEnum y) (fromEnum z)

atomNextStepTo :: Atom -> Atom -> Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNextStepTo (AInt x) (AInt y) (AInt z) = let tup = intNextStepTo x y z in
  Tuple (AInt <$> (fst tup)) (AInt <$> (snd tup))
atomNextStepTo (Bool x) (Bool y) (Bool z) = let tup = eNextStepTo x y z in
  Tuple (Bool <$> (fst) tup) (Bool <$> (snd tup))
atomNextStepTo (Char x) (Char y) (Char z) = case toChar x of
  Nothing -> Tuple Nothing Nothing
  Just a  -> case toChar y of
    Nothing -> Tuple Nothing Nothing
    Just b  -> case toChar z of
      Nothing -> Tuple Nothing Nothing
      Just c  -> let tup = eNextStepTo a b c in
        Tuple ((Char <<< fromChar) <$> (fst tup)) ((Char <<< fromChar) <$> (snd tup))
atomNextStepTo _ _ _ = Tuple Nothing Nothing

atomNextStep :: Atom -> Atom -> Tuple (Maybe Atom) (Maybe Atom)
atomNextStep (AInt x) (AInt y) = case x < y of
  true  -> atomNextStepTo (AInt x) (AInt y) (AInt top)
  false -> atomNextStepTo (AInt x) (AInt y) (AInt bottom)
atomNextStep (Bool x) (Bool y) = case x < y of
  true  -> atomNextStepTo (Bool x) (Bool y) (Bool top)
  false -> atomNextStepTo (Bool x) (Bool y) (Bool bottom)
atomNextStep (Char x) (Char y) = case toChar x of
  Just a  -> case toChar y of
    Just b  -> if a < b then atomNextStepTo (Char x) (Char y) (Char (fromChar top))
                        else atomNextStepTo (Char x) (Char y) (Char (fromChar bottom))
    Nothing -> Tuple Nothing Nothing
  Nothing -> Tuple Nothing Nothing
atomNextStep _ _ = Tuple Nothing Nothing

evalArithmSeq :: Expr -> Evaluator Expr
evalArithmSeq as = case as of
  ArithmSeq (Atom (AInt _)) _ _ -> evalArithmSeq' as
  ArithmSeq (Atom (Bool _)) _ _ -> evalArithmSeq' as
  ArithmSeq (Atom (Char _)) _ _ -> evalArithmSeq' as
  _                             -> throwError $ CannotEvaluate as
  where
    evalArithmSeq' :: Expr -> Evaluator Expr
    evalArithmSeq' as = case as of
      ArithmSeq (Atom x) Nothing Nothing -> case atomNext x of
        Tuple Nothing _         -> return $ List Nil
        Tuple (Just a) Nothing  -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just b) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom b) Nothing Nothing)

      ArithmSeq (Atom x) (Just (Atom y)) Nothing -> case atomNextStep x y of
        Tuple Nothing _                -> return $ List Nil
        Tuple (Just a) Nothing         -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just nextStep) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom y) (Just (Atom nextStep)) Nothing)

      ArithmSeq (Atom x) Nothing end@(Just (Atom z)) -> case atomNextTo x z of
        Tuple Nothing _         -> return $ List Nil
        Tuple (Just a) Nothing  -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just b) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom b) Nothing end)

      ArithmSeq (Atom x) (Just (Atom y)) end@(Just (Atom z)) -> case atomNextStepTo x y z of
        Tuple Nothing _                -> return $ List Nil
        Tuple (Just a) Nothing         -> return $ List (singleton (Atom a))
        Tuple (Just a) (Just nextStep) -> return $ Binary Colon (Atom a) (ArithmSeq (Atom y) (Just (Atom nextStep)) end)

      _ -> throwError $ CannotEvaluate as

------------------------------------------------------------------------------------------
-- Arithmetic Sequences End
------------------------------------------------------------------------------------------

binary :: Env -> Op -> Expr -> Expr -> Evaluator Expr
binary env op = case op 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) -> return $ List $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List ls1) (List ls2)) -> return $ List $ 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)) _                  ) -> return $ Atom $ Bool false
    (Tuple _                   (Atom (Bool false))) -> return $ Atom $ Bool false
    (Tuple (Atom (Bool true))  (Atom (Bool true)) ) -> return $ Atom $ Bool true
    (Tuple _                   _                  ) -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom (Bool true))  _                   ) -> return $ Atom $ Bool true
    (Tuple _                   (Atom (Bool true))  ) -> return $ Atom $ Bool true
    (Tuple (Atom (Bool false))  (Atom (Bool false))) -> return $ Atom $ Bool false
    (Tuple _                   _                   ) -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> return $ App f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  InfixFunc name -> \e1 e2 -> apply env name (e1 : e2 : Nil)
  where
    aint :: Op -> (Int -> Int -> Int) -> Expr -> Expr -> Evaluator Expr
    aint _   f (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ f i j
    aint op  _ e1              e2              = throwError $ BinaryOpError op e1 e2

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

unary :: Env -> Op -> Expr -> Evaluator Expr
unary env Sub (Atom (AInt i)) = return $ Atom $ AInt (-i)
unary env op e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List Expr) -> Evaluator Expr
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

--builtin ipo
division :: Expr -> Expr -> Evaluator Expr
division (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
division (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ div i j
division e1 e2 = throwError $ BinaryOpError (InfixFunc "div") e1 e2

--builtin mod
modulo :: Expr -> Expr -> Evaluator Expr
modulo (Atom (AInt i)) (Atom (AInt 0)) = throwError DivByZero
modulo (Atom (AInt i)) (Atom (AInt j)) = return $ Atom $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List Binding) Expr)) -> (List Expr) -> String -> (List MatchingError) -> Evaluator Expr
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 :: Expr -> Boolean
whnf (Atom (Name _)) = false
whnf (Atom _)        = true
whnf (List _)        = true
whnf (NTuple _)      = true
whnf _               = false

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

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

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

match' (ConsLit b bs)    (Binary Colon e es)  = match' b e *> match' bs es
match' (ConsLit b bs)    (List (Cons e es))  = match' (ConsLit b bs) (Binary Colon e (List es))
match' (ConsLit b bs)    (List Nil)           = throwError $ MatchingError (ConsLit b bs) (List Nil)
match' (ConsLit b bs)    e                   = throwError $ checkStrictness (ConsLit b bs) e

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

match' (NTupleLit bs)    (NTuple es)         = case length bs == length es of
                                                 true  -> void $ zipWithA match' bs es
                                                 false -> throwError $ MatchingError (NTupleLit bs) (NTuple es)
match' (NTupleLit bs)    e                   = throwError $ checkStrictness (NTupleLit bs) e

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)

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case Map.lookup name subs of
      Just subExpr -> return subExpr
      Nothing      -> return a
    (List exprs)         -> List <$> (traverse go exprs)
    (NTuple exprs)       -> NTuple <$> (traverse go exprs)
    (Binary op e1 e2)    -> Binary <$> pure op <*> go e1 <*> go e2
    (Unary op e)         -> Unary <$> pure op <*> go e
    (SectL e op)         -> SectL <$> go e <*> pure op
    (SectR op e)         -> SectR <$> pure op <*> go e
    (IfExpr ce te ee)    -> IfExpr <$> go ce <*> go te <*> go ee
    (ArithmSeq ce te ee) -> ArithmSeq <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

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

freeVariables :: Expr -> (List String)
freeVariables _ = Nil
-- freeVariables = nub <<< foldExpr
--   (\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) -> (List String)
boundNames' = concatMap boundNames

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


Started work on replacing Maybe with ErrorT

This will be a lot of refactoring, but will (hopefully) allow us to
present better error messages to the user (and developer).

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl, foldMap, any)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class

import Control.Monad.Error
import Control.Monad.Error.Trans
import Control.Monad.Error.Class

import Control.Monad.Trans

import AST

type EvalError = ErrorT String Identity

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> EvalError Expr) -> Expr -> EvalError Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> pure e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> pure op
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapMaybeIndex n (go p) es
    NTuple es -> NTuple <$> mapMaybeIndex n (go p) es
    App e es -> App e <$> mapMaybeIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

mapMaybeIndex :: forall m a. Number -> (a -> EvalError a) -> [a] -> EvalError [a]
mapMaybeIndex i f as = do
  case as !! i of
    Nothing -> throwError $ "Nothing at index " ++ show i ++ "! (length = " ++ show (length as) ++ ")"
    Just a  -> return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = Nothing --mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
--  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (Atom (Name name))            -> apply env name []
  (List (e:es))                 -> Just $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> Just $ App f [App g [e]]
  (App (Lambda binds body) args) -> matchls binds args body
  (App (SectL e1 op) [e2])      -> Just $ Binary op e1 e2
  (App (SectR op e2) [e1])      -> Just $ Binary op e1 e2
  (App (Prefix op) [e1, e2])    -> Just $ Binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  (App (App func es) es')       -> Just $ App func (es ++ es')
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> EvalError Expr
binary = go
  where
  retA = return <<< Atom
  go Power (Atom (Num i)) (Atom (Num j)) = retA $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = throwError "Division by zero!"
  go Div (Atom (Num i)) (Atom (Num j)) = retA $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = throwError "Mod by zero!"
  go Mod (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = retA $ Num $ i - j

  go Cons   e          (List es)  = return $ List $ e:es
  go Append (List es1) (List es2) = return $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = retA $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = retA $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = retA $ Bool $ i > j

  go And (Atom (Bool true))  b = return b
  go And (Atom (Bool false)) _ = retA $ Bool $ false

  go Or  (Atom (Bool true))  _ = retA $ Bool $ true
  go Or  (Atom (Bool false)) b = return b

  go Dollar f e = return $ App f [e]

  go op e1 e2 = throwError $ "Cannot apply operator " ++ show op ++  " to " ++ show e1 ++ " and " ++ show e2

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls []     es     expr = Just $ App expr es
matchls _ _ _ = Nothing

type Matches = [Tuple Atom Expr]

type Matcher = StateT Expr (WriterT Matches (ErrorT String Identity))

runMatcher :: forall a. Matcher a -> Expr -> EvalError (Tuple (Tuple a Expr) Matches)
runMatcher m e = runWriterT $ runStateT m e

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit l)          (Atom a)         | a == l  = return unit
--match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ConsLit b bs)   (Binary Cons e es) = match b e *> match bs es
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
--match (ListLit (b:bs)) (Binary Cons e es) = match b e *> match (ListLit bs) es
match (NTupleLit bs)   (NTuple es)      = match (ListLit bs) (List es)
match _                _                = lift Nothing

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs

isNameBound :: String -> Binding -> Boolean
isNameBound name binding = (elemIndex name $ boundNames binding) >= 0

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (NTuple exprs)      -> NTuple (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    l@(Lambda binds body) -> if any (isNameBound name) binds
                               then l
                               else Lambda binds (go body)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl, foldMap, any)

import Math (pow)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Nth Number Path
          | Fst Path
          | Snd Path
          | End

instance showPath :: Show Path where
  show p = case p of
    Nth i p -> "(Nth " ++ show i ++ " " ++ show p ++")"
    Fst   p -> "(Fst " ++ show p ++")"
    Snd   p -> "(Snd " ++ show p ++")"
    End     -> "End"

mapWithPath :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
mapWithPath p f = go p
  where
  go End e     = f e
  go (Fst p) e = case e of
    Binary op e1 e2 -> Binary op <$> go p e1 <*> Just e2
    Unary op e      -> Unary op  <$> go p e
    SectL e op      -> SectL     <$> go p e <*> Just op
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> Just es
    _               -> Nothing
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    _               -> Nothing
  go (Nth n p) e = case e of
    List es  -> List  <$> mapMaybeIndex n (go p) es
    NTuple es -> NTuple <$> mapMaybeIndex n (go p) es
    App e es -> App e <$> mapMaybeIndex n (go p) es
    _        -> Nothing

mapMaybeIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMaybeIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = mapWithPath path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (Atom (Name name))            -> apply env name []
  (List (e:es))                 -> Just $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> Just $ App f [App g [e]]
  (App (Lambda binds body) args) -> matchls binds args body
  (App (SectL e1 op) [e2])      -> Just $ Binary op e1 e2
  (App (SectR op e2) [e1])      -> Just $ Binary op e1 e2
  (App (Prefix op) [e1, e2])    -> Just $ Binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  (App (App func es) es')       -> Just $ App func (es ++ es')
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Power (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Mod (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i > j

  go And (Atom (Bool true))  b = Just b
  go And (Atom (Bool false)) _ = Just $ Atom $ Bool $ false

  go Or  (Atom (Bool true))  _ = Just $ Atom $ Bool $ true
  go Or  (Atom (Bool false)) b = Just b

  go Dollar f e = Just $ App f [e]

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls []     es     expr = Just $ App expr es
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit l)          (Atom a)         | a == l  = return unit
--match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ConsLit b bs)   (Binary Cons e es) = match b e *> match bs es
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
--match (ListLit (b:bs)) (Binary Cons e es) = match b e *> match (ListLit bs) es
match (NTupleLit bs)   (NTuple es)      = match (ListLit bs) (List es)
match _                _                = lift Nothing

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs
  go (NTupleLit bs)    = foldMap go bs

isNameBound :: String -> Binding -> Boolean
isNameBound name binding = (elemIndex name $ boundNames binding) >= 0

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (NTuple exprs)      -> NTuple (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    l@(Lambda binds body) -> if any (isNameBound name) binds
                               then l
                               else Lambda binds (go body)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e


Fix typo in associativity law

Fix typo in associativity law

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (id)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixl 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= id

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (id)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixl 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= id

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f


Big UI

Big UI

module App.BoardView where

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

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

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

type PitState = Maybe Turn

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

pitColor :: PitState -> Color
pitColor (Just Turn.Capture) = hsl 300.0 1.0 0.3
pitColor (Just Turn.Lift) = hsl 150.0 1.0 0.3
pitColor (Just Turn.Sow) = C.lighten 0.4 $ pitColor Nothing
pitColor _ = hsl 70.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewRow player =
      div [] $ FM.mapRowWithIndex player (viewPit state) board.cells

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player =
  H.pre [css] [ text s ]
    where s = viewPlayer player <> showPadded seeds
          seeds = getStore player board
          board = getBoard state
          color = if isPlaying state player
                    then pitColor (Just Turn.Sow)
                    else pitColor Nothing # C.darken 0.1
          css = style do
            C.display C.inlineFlex
            C.textAlign C.center
            C.fontSize (em 2.5)
            C.backgroundColor color
            C.width (pct 20.0)
            C.height (em 2.0)
            C.marginLeft (pct 35.0)
            C.border C.solid (px 1.0) C.black
            C.padding (em 0.0) (em padding) (em 0.0) (em padding)
              where padding = 0.5

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.div (getJusts [css, event]) [body]
  where
    body = div [style do apply4 C.margin (em 1.0) ] [text $ showPadded count]
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ style do
      C.display C.inlineFlex
      C.width (pct 10.0)
      C.height (em 3.0)
      C.textAlign C.center
      C.fontSize (em 2.5)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      apply4 C.margin (em 0.0)
      C.border C.solid (px 1.0) C.black
        where padding = 0.5

showPadded :: Int -> String
showPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

viewPlayer :: Player -> String
viewPlayer player = viewPlayerEmoji player

viewPlayerEmoji :: Player -> String
viewPlayerEmoji A = "🐄"
viewPlayerEmoji B = "🐓"

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

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

module App.BoardView where

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

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

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

type PitState = Maybe Turn

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

pitColor :: PitState -> Color
pitColor (Just Turn.Capture) = hsl 300.0 1.0 0.3
pitColor (Just Turn.Lift) = hsl 150.0 1.0 0.3
pitColor (Just Turn.Sow) = C.lighten 0.4 $ pitColor Nothing
pitColor _ = hsl 70.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewRow player =
      div [] $ FM.mapRowWithIndex player (viewPit state) board.cells

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player =
  H.pre [css] [ text s ]
    where s = viewPlayer player <> showPadded seeds
          seeds = getStore player board
          board = getBoard state
          color = if isPlaying state player
                    then pitColor (Just Turn.Sow)
                    else pitColor Nothing # C.darken 0.1
          css = style do
            C.display C.block
            C.textAlign C.center
            C.fontSize (em 2.0)
            C.backgroundColor color
            C.width (em 5.0)
            C.margin (em 1.0) (em 0.0) (em 1.0) (em 8.5)
            C.border C.solid (px 1.0) C.black

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ showPadded count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ style do
      C.display C.inlineFlex
      C.position C.relative
      C.width boxSize
      C.height boxSize
      C.textAlign C.center
      C.fontSize (em 2.5)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      apply4 C.margin (em 0.0)
      C.border C.solid (px 1.0) C.black
      where
        padding = 0.5
        boxSize = (em 1.5)

showPadded :: Int -> String
showPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

viewPlayer :: Player -> String
viewPlayer player = viewPlayerEmoji player

viewPlayerEmoji :: Player -> String
viewPlayerEmoji A = "🐄"
viewPlayerEmoji B = "🐓"

cellStyle :: forall a. Color -> Display -> Attribute a
cellStyle color display = style do
    C.display display
    C.position C.relative
    C.width boxSize
    C.height boxSize
    C.textAlign C.center
    C.fontSize (em 2.5)
    C.backgroundColor color
    C.padding (em 0.0) (em padding) (em 0.0) (em padding)
    apply4 C.margin (em 0.0)
    C.border C.solid (px 1.0) C.black
    where
      padding = 0.5
      boxSize = (em 1.5)

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

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


Parse mutex groupings inside groups

Parse mutex groupings inside groups

module Docopt.Parser.Usage where

import Prelude
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Control.Monad.State (get)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.List (List(..), many, some, (:), toList, concat)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import Data.String (length)
import Data.Either
import Data.Tuple
import Data.Maybe hiding (maybe)
import Docopt.Parser.Base
import Docopt.Parser.Common
import Docopt.Parser.Lexer
import Docopt.Parser.State

type OptionAlias    = String
type OptionArgument = String
type IsOptional     = Boolean
type IsRepeatable   = Boolean

data UsageNode
  = Command     String
  | Positional  String
                IsRepeatable
  | Option      String
                (Maybe OptionArgument)
                IsRepeatable
  | OptionStack Char
                (List Char)
                (Maybe OptionArgument)
                IsRepeatable
  | Group       IsOptional
                (List UsageNode)
                IsRepeatable

-- | Represent a single program usage.
-- | A single usage is made up of a list of mutually exclusive groups,
-- | separated by a vertical bar `|`. Each of those groups can contain
-- | one or more `UsageNode`.
-- |
-- | node node | node | node
-- | ^^^^ ^^^^   ^^^^   ^^^^
-- |   |   |      |      |
-- | [ 0 , 1 ]  [ 0 ]  [ 0 ]
-- |    \ /       |      |
-- | [   0    ,   1   ,  2 ]
data Usage = Usage String (List (List UsageNode))

instance showUsage :: Show Usage where
  show (Usage n xs) = "Usage " ++ show n ++ " " ++ show xs

instance showUsageNode :: Show UsageNode where
  show (Command n) =
    "Command " ++ n
  show (Positional n b) =
    "Positional " ++ n ++ " " ++ show b
  show (Option n a b) =
    "Option " ++ show n ++ " " ++ show a ++ " " ++ show b
  show (OptionStack n s a b) =
    "OptionStack " ++ show n ++ " " ++ show s ++ " " ++ show a ++ " " ++ show b
  show (Group n b o) =
    "Group " ++ show n ++ " " ++ show b ++ " " ++ show o

-- | Parse the usage section
parseUsage :: TokenParser Unit
parseUsage = do

  -- Calculate the leading start indentation.
  -- The first usage line is indicative of of the start indentation of every
  -- other usage line!
  name <- parseProgram
  col' <- getCol
  let startCol = col' - (length name) - 1

  usages <- mark' startCol $ P.manyTill
    (P.try $ Usage name <$> (parseElems name))
    eof
  debug usages

  where

    parseElems :: String -> TokenParser (List (List UsageNode))
    parseElems programName = do
      concat <$> P.manyTill
        ((some parseElem) `P.sepBy` vbar)
        ((void $ same *>
          parseKnownProgram programName) <|> (P.lookAhead eof))

    parseProgram :: TokenParser String
    parseProgram = name

    parseKnownProgram :: String -> TokenParser Unit
    parseKnownProgram s = do
      s' <- parseProgram
      guard (s == s') P.<?> "Program token " ++ s

    parseElem :: TokenParser UsageNode
    parseElem = defer \_ -> do
          (indented *> parseOption)
      <|> (indented *> parsePositional)
      <|> (indented *> parseCommand)
      <|> (indented *> parseGroup)

    parseLongOption :: TokenParser UsageNode
    parseLongOption = Option
        <$> lopt
        <*> (tryMaybe $ equal *> (shoutName <|> angleName <|> name))
        <*> parseRepetition

    parseShortOption :: TokenParser UsageNode
    parseShortOption = do
        { flag: flag, stack: stack, arg: arg } <- sopt
        OptionStack flag stack
            <$> (case arg of
                    Just _  -> pure $ arg
                    Nothing -> do
                        (tryMaybe do
                            equal *> (shoutName <|> angleName <|> name)))
            <*> parseRepetition

    parseOption :: TokenParser UsageNode
    parseOption = (parseLongOption <|> parseShortOption)

    parsePositional :: TokenParser UsageNode
    parsePositional = Positional
      <$> (angleName <|> shoutName)
      <*> parseRepetition

    parseCommand :: TokenParser UsageNode
    parseCommand = Command <$> name

    parseGroup :: TokenParser UsageNode
    parseGroup = defer \_ ->
          parseReqGroup
      <|> parseOptGroup

    parseOptGroup :: TokenParser UsageNode
    parseOptGroup = defer \_ -> Group true
      <$> (P.between
            (indented *> lsquare)
            (indented *> rsquare)
            (concat <$> ((some parseElem) `P.sepBy` vbar)))
      <*> parseRepetition

    parseReqGroup :: TokenParser UsageNode
    parseReqGroup = defer \_ -> Group false
      <$> (P.between
            (indented *> lparen)
            (indented *> rparen)
            (concat <$> ((some parseElem) `P.sepBy` vbar)))
      <*> parseRepetition

    parseRepetition :: TokenParser Boolean
    parseRepetition = P.choice
      [ P.try $ indented *> tripleDot *> pure true
      , pure false
      ]

module Docopt.Parser.Usage where

import Prelude
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Control.Monad.State (get)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.List (List(..), many, some, (:), toList, concat)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import Data.String (length)
import Data.Either
import Data.Tuple
import Data.Maybe hiding (maybe)
import Docopt.Parser.Base
import Docopt.Parser.Common
import Docopt.Parser.Lexer
import Docopt.Parser.State

type OptionAlias    = String
type OptionArgument = String
type IsOptional     = Boolean
type IsRepeatable   = Boolean

data UsageNode
  = Command     String
  | Positional  String
                IsRepeatable
  | Option      String
                (Maybe OptionArgument)
                IsRepeatable
  | OptionStack Char
                (List Char)
                (Maybe OptionArgument)
                IsRepeatable
  | Group       IsOptional
                (List UsageNode)
                IsRepeatable

-- | Represent a single program usage.
-- | A single usage is made up of a list of mutually exclusive groups,
-- | separated by a vertical bar `|`. Each of those groups can contain
-- | one or more `UsageNode`.
-- |
-- | node node | node | node
-- | ^^^^ ^^^^   ^^^^   ^^^^
-- |   |   |      |      |
-- | [ 0 , 1 ]  [ 0 ]  [ 0 ]
-- |    \ /       |      |
-- | [   0    ,   1   ,  2 ]
data Usage = Usage String (List (List UsageNode))

instance showUsage :: Show Usage where
  show (Usage n xs) = "Usage " ++ show n ++ " " ++ show xs

instance showUsageNode :: Show UsageNode where
  show (Command n) =
    "Command " ++ n
  show (Positional n b) =
    "Positional " ++ n ++ " " ++ show b
  show (Option n a b) =
    "Option " ++ show n ++ " " ++ show a ++ " " ++ show b
  show (OptionStack n s a b) =
    "OptionStack " ++ show n ++ " " ++ show s ++ " " ++ show a ++ " " ++ show b
  show (Group n b o) =
    "Group " ++ show n ++ " " ++ show b ++ " " ++ show o

-- | Parse the usage section
parseUsage :: TokenParser Unit
parseUsage = do

  -- Calculate the leading start indentation.
  -- The first usage line is indicative of of the start indentation of every
  -- other usage line!
  name <- parseProgram
  col' <- getCol
  let startCol = col' - (length name) - 1

  usages <- mark' startCol $ P.manyTill
    (P.try $ Usage name <$> (parseElems name))
    eof
  debug usages

  where

    parseElems :: String -> TokenParser (List (List UsageNode))
    parseElems programName = do
      concat <$> P.manyTill
        ((some parseElem) `P.sepBy` vbar)
        ((void $ same *>
          parseKnownProgram programName) <|> (P.lookAhead eof))

    parseProgram :: TokenParser String
    parseProgram = name

    parseKnownProgram :: String -> TokenParser Unit
    parseKnownProgram s = do
      s' <- parseProgram
      guard (s == s') P.<?> "Program token " ++ s

    parseElem :: TokenParser UsageNode
    parseElem = defer \_ -> do
          (indented *> parseOption)
      <|> (indented *> parsePositional)
      <|> (indented *> parseCommand)
      <|> (indented *> parseGroup)

    parseLongOption :: TokenParser UsageNode
    parseLongOption = Option
        <$> lopt
        <*> (tryMaybe $ equal *> (shoutName <|> angleName <|> name))
        <*> parseRepetition

    parseShortOption :: TokenParser UsageNode
    parseShortOption = do
        { flag: flag, stack: stack, arg: arg } <- sopt
        OptionStack flag stack
            <$> (case arg of
                    Just _  -> pure $ arg
                    Nothing -> do
                        (tryMaybe do
                            equal *> (shoutName <|> angleName <|> name)))
            <*> parseRepetition

    parseOption :: TokenParser UsageNode
    parseOption = (parseLongOption <|> parseShortOption)

    parsePositional :: TokenParser UsageNode
    parsePositional = Positional
      <$> (angleName <|> shoutName)
      <*> parseRepetition

    parseCommand :: TokenParser UsageNode
    parseCommand = Command <$> name

    parseGroup :: TokenParser UsageNode
    parseGroup = defer \_ ->
          parseReqGroup
      <|> parseOptGroup

    parseOptGroup :: TokenParser UsageNode
    parseOptGroup = defer \_ -> Group true
      <$> (P.between
            (indented *> lsquare)
            (indented *> rsquare)
            (some parseElem))
      <*> parseRepetition

    parseReqGroup :: TokenParser UsageNode
    parseReqGroup = defer \_ -> Group false
      <$> (P.between
            (indented *> lparen)
            (indented *> rparen)
            (some parseElem))
      <*> parseRepetition

    parseRepetition :: TokenParser Boolean
    parseRepetition = P.choice
      [ P.try $ indented *> tripleDot *> pure true
      , pure false
      ]