use toEnum/fromEnum in pred/succ

use toEnum/fromEnum in pred/succ

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  , fromStringStrict
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import Data.Function
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import strictJsDate
  """function strictJsDate(Just, Nothing, s) {
    var epoch = Date.parse(s);
    if (isNaN(epoch)) return Nothing;
    var date = new Date(epoch);
    var s2 = date.toISOString();
    var idx = s2.indexOf(s);
    if (idx < 0) return Nothing;
    else return Just(date);
  }""" :: Fn3 (forall a. a -> Maybe a) (forall a. Maybe a) String (Maybe JSDate)

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance eqMonth :: Eq Month where
  (==) January January = true
  (==) February February = true
  (==) March March = true
  (==) April April = true
  (==) May May = true
  (==) June June = true
  (==) July July = true
  (==) August August = true
  (==) September September = true
  (==) October October = true
  (==) November November = true
  (==) December December = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordMonth :: Ord Month where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumMonth :: Enum Month where
  cardinality = Cardinality 12

  firstEnum = January

  lastEnum = December

  succ = defaultSucc monthToEnum monthFromEnum

  pred = defaultPred monthToEnum monthFromEnum

  toEnum = monthToEnum

  fromEnum = monthFromEnum

monthToEnum :: Number -> Maybe Month
monthToEnum  0 = Just January
monthToEnum  1 = Just February
monthToEnum  2 = Just March
monthToEnum  3 = Just April
monthToEnum  4 = Just May
monthToEnum  5 = Just June
monthToEnum  6 = Just July
monthToEnum  7 = Just August
monthToEnum  8 = Just September
monthToEnum  9 = Just October
monthToEnum 10 = Just November
monthToEnum 11 = Just December
monthToEnum  _ = Nothing

monthFromEnum :: Month -> Number
monthFromEnum January    = 0
monthFromEnum February   = 1
monthFromEnum March      = 2
monthFromEnum April      = 3
monthFromEnum May        = 4
monthFromEnum June       = 5
monthFromEnum July       = 6
monthFromEnum August     = 7
monthFromEnum September  = 8
monthFromEnum October    = 9
monthFromEnum November   = 10
monthFromEnum December   = 11

instance showMonth :: Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance eqDayOfWeek :: Eq DayOfWeek where
  (==) Sunday Sunday = true
  (==) Monday Monday = true
  (==) Tuesday Tuesday = true
  (==) Wednesday Wednesday = true
  (==) Thursday Thursday = true
  (==) Friday Friday = true
  (==) Saturday Saturday = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordDayOfWeek :: Ord DayOfWeek where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumDayOfWeek :: Enum DayOfWeek where
  cardinality = Cardinality 7

  firstEnum = Sunday

  lastEnum = Saturday

  succ = defaultSucc dayOfWeekToEnum dayOfWeekFromEnum

  pred = defaultPred dayOfWeekToEnum dayOfWeekFromEnum

  toEnum = dayOfWeekToEnum

  fromEnum = dayOfWeekFromEnum

dayOfWeekToEnum :: Number -> Maybe DayOfWeek
dayOfWeekToEnum 0 = Just Sunday
dayOfWeekToEnum 1 = Just Monday
dayOfWeekToEnum 2 = Just Tuesday
dayOfWeekToEnum 3 = Just Wednesday
dayOfWeekToEnum 4 = Just Thursday
dayOfWeekToEnum 5 = Just Friday
dayOfWeekToEnum 6 = Just Saturday
dayOfWeekToEnum _ = Nothing

dayOfWeekFromEnum :: DayOfWeek -> Number
dayOfWeekFromEnum Sunday     = 0
dayOfWeekFromEnum Monday     = 1
dayOfWeekFromEnum Tuesday    = 2
dayOfWeekFromEnum Wednesday  = 3
dayOfWeekFromEnum Thursday   = 4
dayOfWeekFromEnum Friday     = 5
dayOfWeekFromEnum Saturday   = 6

instance showDayOfWeek :: Show DayOfWeek where
  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import nowImpl """
  function nowImpl(f) {
    return function(){
      return f(new Date());
    };
  }
  """ :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

fromStringStrict :: String -> Maybe Date
fromStringStrict s = runFn3 strictJsDate Just Nothing s >>= fromJSDate

instance showDate :: Show Date where
  show = liftDate $ jsDateMethod "toString"

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  , fromStringStrict
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import Data.Function
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import strictJsDate
  """function strictJsDate(Just, Nothing, s) {
    var epoch = Date.parse(s);
    if (isNaN(epoch)) return Nothing;
    var date = new Date(epoch);
    var s2 = date.toISOString();
    var idx = s2.indexOf(s);
    if (idx < 0) return Nothing;
    else return Just(date);
  }""" :: Fn3 (forall a. a -> Maybe a) (forall a. Maybe a) String (Maybe JSDate)

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance eqMonth :: Eq Month where
  (==) January January = true
  (==) February February = true
  (==) March March = true
  (==) April April = true
  (==) May May = true
  (==) June June = true
  (==) July July = true
  (==) August August = true
  (==) September September = true
  (==) October October = true
  (==) November November = true
  (==) December December = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordMonth :: Ord Month where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumMonth :: Enum Month where
  cardinality = Cardinality 12

  firstEnum = January

  lastEnum = December

  succ January    = Just February
  succ February   = Just March
  succ March      = Just April
  succ April      = Just May
  succ May        = Just June
  succ June       = Just July
  succ July       = Just August
  succ August     = Just September
  succ September  = Just October
  succ October    = Just November
  succ November   = Just December
  succ December   = Nothing

  pred January    = Nothing
  pred February   = Just January
  pred March      = Just February
  pred April      = Just March
  pred May        = Just April
  pred June       = Just May
  pred July       = Just June
  pred August     = Just July
  pred September  = Just August
  pred October    = Just September
  pred November   = Just October
  pred December   = Just November

  toEnum  0 = Just January
  toEnum  1 = Just February
  toEnum  2 = Just March
  toEnum  3 = Just April
  toEnum  4 = Just May
  toEnum  5 = Just June
  toEnum  6 = Just July
  toEnum  7 = Just August
  toEnum  8 = Just September
  toEnum  9 = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum  _ = Nothing

  fromEnum January    = 0
  fromEnum February   = 1
  fromEnum March      = 2
  fromEnum April      = 3
  fromEnum May        = 4
  fromEnum June       = 5
  fromEnum July       = 6
  fromEnum August     = 7
  fromEnum September  = 8
  fromEnum October    = 9
  fromEnum November   = 10
  fromEnum December   = 11

instance showMonth :: Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance eqDayOfWeek :: Eq DayOfWeek where
  (==) Sunday Sunday = true
  (==) Monday Monday = true
  (==) Tuesday Tuesday = true
  (==) Wednesday Wednesday = true
  (==) Thursday Thursday = true
  (==) Friday Friday = true
  (==) Saturday Saturday = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordDayOfWeek :: Ord DayOfWeek where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumDayOfWeek :: Enum DayOfWeek where
  cardinality = Cardinality 7

  firstEnum = Sunday

  lastEnum = Saturday

  succ Sunday     = Just Monday
  succ Monday     = Just Tuesday
  succ Tuesday    = Just Wednesday
  succ Wednesday  = Just Thursday
  succ Thursday   = Just Friday
  succ Friday     = Just Saturday
  succ Saturday   = Nothing

  pred Sunday     = Nothing
  pred Monday     = Just Sunday
  pred Tuesday    = Just Monday
  pred Wednesday  = Just Tuesday
  pred Thursday   = Just Wednesday
  pred Friday     = Just Thursday
  pred Saturday   = Just Friday

  toEnum 0 = Just Sunday
  toEnum 1 = Just Monday
  toEnum 2 = Just Tuesday
  toEnum 3 = Just Wednesday
  toEnum 4 = Just Thursday
  toEnum 5 = Just Friday
  toEnum 6 = Just Saturday
  toEnum _ = Nothing

  fromEnum Sunday     = 0
  fromEnum Monday     = 1
  fromEnum Tuesday    = 2
  fromEnum Wednesday  = 3
  fromEnum Thursday   = 4
  fromEnum Friday     = 5
  fromEnum Saturday   = 6

instance showDayOfWeek :: Show DayOfWeek where
  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import nowImpl """
  function nowImpl(f) {
    return function(){
      return f(new Date());
    };
  }
  """ :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

fromStringStrict :: String -> Maybe Date
fromStringStrict s = runFn3 strictJsDate Just Nothing s >>= fromJSDate

instance showDate :: Show Date where
  show = liftDate $ jsDateMethod "toString"


improved evaluation of list-comprehension: overlapping let expressions

module Evaluator where

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

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Qual(..), ExprQual, 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)
  | BindingError 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 (BindingError me)          = "BindingError " ++ show me
  show (CannotEvaluate e)         = "CannotEvaluate " ++ show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " ++ show e1 ++ " " ++ show e2 ++ ")"

data MatchingError =
    MatchingError Binding 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
    ListComp e qs   -> ListComp  <$> go p e <*> pure qs
    _               -> 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
    ListComp e qs -> ListComp e <$> mapIndexQual n (go p) qs
    _        -> throwError $ PathError (Nth n p) e

  evalQual :: (Expr -> Evaluator Expr) -> Qual Binding Expr -> Evaluator (Qual Binding Expr)
  evalQual f q = case q of
    Gen bin expr -> Gen bin <$> f expr
    Let bin expr -> Let bin <$> f expr
    Guard expr   -> Guard <$> f expr

  mapIndexQual :: Int -> (Expr -> Evaluator Expr) -> (List (Qual Binding Expr)) -> Evaluator (List (Qual Binding Expr))
  mapIndexQual i f qs = do
    case qs !! i of
      Nothing -> throwError $ IndexError i (length qs)
      Just q  -> do
        q' <- evalQual f q
        case updateAt i q' qs of
          Nothing  -> throwError $ IndexError i (length qs)
          Just qs' -> return qs'

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 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')
  (ListComp e qs)                    -> evalListComp e qs
  _                                  -> 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
      (ListComp e qs)    -> do
        ListComp (evalToBinding env e bind) ((\x -> evalToBindingQual env x bind) <$> qs)
      _                  ->
        expr

    evalToBindingQual :: Env -> ExprQual -> Binding -> ExprQual
    evalToBindingQual env qual binding = case qual of
      Let bin expr -> Let bin (evalToBinding env expr bind)
      Gen bin expr -> Gen bin (evalToBinding env expr bind)
      Guard expr   -> Guard (evalToBinding env expr bind)

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
------------------------------------------------------------------------------------------

--TODO: use fledged-out purescript-enum to solve everything with "enumFromThenTo"

{-
packs the evaluation result for arithmetic sequences (AS)
example:
Trip (Just x) (Just y) (Just z) will be displayed as x : [y, z ..]
if no end of (AS) was given or x : [y, z .. end] if end was given
-}
data Trip a = Trip a a a

instance functorTrip :: Functor Trip where
  map f (Trip x y z) = Trip (f x) (f y) (f z)

intFromStepTo :: Int -> Maybe Int -> Maybe Int -> Trip (Maybe Int)
intFromStepTo start Nothing Nothing     = Trip (Just start) (Just (start + 1)) Nothing
intFromStepTo start (Just step) Nothing = Trip (Just start) (Just step) (Just (step + step - start))
intFromStepTo start Nothing (Just end)  = case start > end of
  true  -> Trip Nothing Nothing Nothing
  false -> case start == end of
    true  -> Trip (Just end) Nothing Nothing
    false -> Trip (Just start) (Just (start + 1)) Nothing
intFromStepTo start (Just step) (Just end) = case (start <= step && start > end) || (start > step && start < end) of
  true  -> Trip Nothing Nothing Nothing
  false -> case start == end of
    true  -> Trip (Just end) Nothing Nothing
    false -> Trip (Just (start)) (Just (step)) (Just (step + step - start))

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

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

exprFromStepTo :: Expr -> Maybe Expr -> Maybe Expr -> Trip (Maybe Expr)
exprFromStepTo start step end = case start of
  Atom (AInt i) -> (\x -> (Atom <<< AInt) <$> x) <$> intTrip
  Atom (Bool b) -> (\x -> (Atom <<< Bool) <$> x) <$> (intToBool intTrip)
  Atom (Char c) -> (\x -> (Atom <<< Char <<< fromChar) <$> x) <$> (\x -> join (toEnum <$> x)) <$> intTrip
  _             -> Trip Nothing Nothing Nothing
    where
      intTrip = intFromStepTo (unsafeExprToInt start) (unsafeExprToInt <$> step) (unsafeExprToInt <$> end)

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

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

    evalArithmSeq' :: Evaluator Expr
    evalArithmSeq' = case (exprFromStepTo start step end) of
      Trip (Just a) (Just b) nextStep -> return $ Binary Colon a (ArithmSeq b nextStep end)
      Trip (Just a) Nothing _         -> return $ List (singleton a)
      Trip Nothing _ _                -> return $ List Nil

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

--TODO: remove redundancies
evalListComp :: Expr -> List ExprQual -> Evaluator Expr
evalListComp expr Nil           = return $ List $ singleton expr
evalListComp expr (Cons q qs) = case q of
  Guard (Atom (Bool false)) -> return $ List Nil
  Guard (Atom (Bool true))  -> if null qs then return (List (singleton expr)) else return (ListComp expr qs)
  Gen _ (List Nil)          -> return $ List Nil
  Gen b (List (Cons e Nil)) -> return $ ListComp expr (Cons (Let b e) qs)
  Gen b (List (Cons e es))  -> do
    listcomp1 <- return $ ListComp expr (Cons (Let b e) qs)
    listcomp2 <- return $ ListComp expr (Cons (Gen b (List es)) qs)
    return $ Binary Append listcomp1 listcomp2
  Gen b (Binary Colon e (List Nil)) -> return $ ListComp expr (Cons (Let b e) qs)
  Gen b (Binary Colon e es)  -> do
    listcomp1 <- return $ ListComp expr (Cons (Let b e) qs)
    listcomp2 <- return $ ListComp expr (Cons (Gen b es) qs)
    return $ Binary Append listcomp1 listcomp2
  Let b e -> case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
    Right r -> do
      Tuple qs' r' <- runStateT (replaceQualifiers qs) r
      expr'        <- replace' r' expr
      case qs' of
          Nil -> return $ List $ singleton expr'
          _   -> return $ ListComp expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp expr (Cons q qs))

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

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

-- built-in div
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

-- built-in 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

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

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

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
    (ListComp expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      return $ ListComp expr' quals'
    e                     -> return e

-- replaces expressions in List-Comprehension-Qualifiers and considers overlapping bindings
replaceQualifiers :: List ExprQual -> StateT (StrMap Expr) Evaluator (List ExprQual)
replaceQualifiers = traverse replaceQual
  where
    replaceQual :: ExprQual -> StateT (StrMap Expr) Evaluator ExprQual
    replaceQual qual = case qual of
      Gen b e -> scope b e >>= \e' -> return $ Gen b e'
      Let b e -> scope b e >>= \e' -> return $ Let b e'
      Guard e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        return $ Guard e'
    scope :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Expr
    scope b e = do
      sub <- get
      e'  <- lift $ replace' sub e
      modify (removeOverlapping b)
      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, class Semigroup, class Functor, 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))
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 (fromEnum, toEnum)
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(..), Qual(..), ExprQual, 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
    ListComp e qs   -> ListComp  <$> go p e <*> pure qs
    _               -> 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
    ListComp e qs -> ListComp e <$> mapIndexQual n (go p) qs
    _        -> throwError $ PathError (Nth n p) e

  evalQual :: (Expr -> Evaluator Expr) -> Qual Binding Expr -> Evaluator (Qual Binding Expr)
  evalQual f q = case q of
    Gen bin expr -> Gen bin <$> f expr
    Let bin expr -> Let bin <$> f expr
    Guard expr   -> Guard <$> f expr

  mapIndexQual :: Int -> (Expr -> Evaluator Expr) -> (List (Qual Binding Expr)) -> Evaluator (List (Qual Binding Expr))
  mapIndexQual i f qs = do
    case qs !! i of
      Nothing -> throwError $ IndexError i (length qs)
      Just q  -> do
        q' <- evalQual f q
        case updateAt i q' qs of
          Nothing  -> throwError $ IndexError i (length qs)
          Just qs' -> return qs'

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 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')
  (ListComp e qs)                    -> evalListComp env e qs
  _                                  -> 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
      --TODO: check
      --(ListComp e qs)    -> do
      --  ListComp (evalToBinding env e bind) ((\x -> evalToBindingQual env x bind) <$> qs)
      _                  ->
        expr

    --TODO: make correct
    evalToBindingQual :: Env -> Qual Binding Expr -> Binding -> Qual Binding Expr
    evalToBindingQual env qual binding = case qual of
      Let bin expr -> Let bin (evalToBinding env expr bind)
      Gen bin expr -> Gen bin (evalToBinding env expr bind)
      Guard expr   -> Guard (evalToBinding env expr bind)

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
------------------------------------------------------------------------------------------

{-
packs the evaluation result for arithmetic sequences (AS)
example:
Trip (Just x) (Just y) (Just z) will be displayed as x : [y, z ..]
if no end of (AS) was given or x : [y, z .. end] if end was given
-}
data Trip a = Trip a a a

instance functorTrip :: Functor Trip where
  map f (Trip x y z) = Trip (f x) (f y) (f z)

intFromStepTo :: Int -> Maybe Int -> Maybe Int -> Trip (Maybe Int)
intFromStepTo start Nothing Nothing     = Trip (Just start) (Just (start + 1)) Nothing
intFromStepTo start (Just step) Nothing = Trip (Just start) (Just step) (Just (step + step - start))
intFromStepTo start Nothing (Just end)  = case start > end of
  true  -> Trip Nothing Nothing Nothing
  false -> case start == end of
    true  -> Trip (Just end) Nothing Nothing
    false -> Trip (Just start) (Just (start + 1)) Nothing
intFromStepTo start (Just step) (Just end) = case (start <= step && start > end) || (start > step && start < end) of
  true  -> Trip Nothing Nothing Nothing
  false -> case start == end of
    true  -> Trip (Just end) Nothing Nothing
    false -> Trip (Just (start)) (Just (step)) (Just (step + step - start))

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

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

exprFromStepTo :: Expr -> Maybe Expr -> Maybe Expr -> Trip (Maybe Expr)
exprFromStepTo start step end = case start of
  Atom (AInt i) -> (\x -> (Atom <<< AInt) <$> x) <$> intTrip
  Atom (Bool b) -> (\x -> (Atom <<< Bool) <$> x) <$> (intToBool intTrip)
  Atom (Char c) -> (\x -> (Atom <<< Char <<< fromChar) <$> x) <$> (\x -> join (toEnum <$> x)) <$> intTrip
  _             -> Trip Nothing Nothing Nothing
    where
      intTrip = intFromStepTo (unsafeExprToInt start) (unsafeExprToInt <$> step) (unsafeExprToInt <$> end)

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

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

    evalArithmSeq' :: Evaluator Expr
    evalArithmSeq' = case (exprFromStepTo start step end) of
      Trip (Just a) (Just b) nextStep -> return $ Binary Colon a (ArithmSeq b nextStep end)
      Trip (Just a) Nothing _         -> return $ List (singleton a)
      Trip Nothing _ _                -> return $ List Nil

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

--TODO: let
evalListComp :: Env -> Expr -> List ExprQual -> Evaluator Expr
evalListComp _ expr Nil           = return $ List $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard (Atom (Bool false)) -> return $ List Nil
  Guard (Atom (Bool true))  -> return $ ListComp expr qs
  Gen _ (List Nil)          -> return $ List Nil
  Gen b (List (Cons e Nil)) -> return $ ListComp expr (Cons (Let b e) qs)
  Gen b (List (Cons e es))  -> do
    listcomp1 <- return $ ListComp expr (Cons (Let b e) qs)
    listcomp2 <- return $ ListComp expr (Cons (Gen b (List es)) qs)
    return $ Binary Append listcomp1 listcomp2
  --TODO: fix overlapping bindings
  Let b e -> case runMatcherM $ matchls' env (singleton b) (singleton e) of
    Right r -> do
      qs' <- traverse (replaceInQual r) qs
      expr' <- replace' r expr
      case qs' of
        Nil -> return $ List $ singleton expr'
        _   -> return $ ListComp expr' qs'
    Left  l -> throwError $ UnknownFunction "something went wrong in binding of let guard"
  _ -> throwError $ CannotEvaluate (ListComp expr (Cons q qs))
  where
    replaceInQual :: StrMap Expr -> ExprQual -> Evaluator ExprQual
    replaceInQual str qual = case qual of
      Gen b e -> replace' str e >>= \x -> return $ Gen b x
      Let b e -> replace' str e >>= \x -> return $ Let b x
      Guard e -> replace' str e >>= \x -> return $ Guard x

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

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

-- built-in div
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

-- built-in 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
    --TODO: Add ListComp
    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


add missing pattern match in unsafe section

module Ifrit.Semantic
  ( Schema(..)
  , analyze
  , fromJson
  , fromString
  ) where

import Prelude

import Data.Argonaut.Core(Json, foldJson, stringify)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.Argonaut.Parser(jsonParser)
import Data.Array(head, length)
import Data.Either(Either(..))
import Data.List(List(..), (:))
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.Pair(Pair(..))
import Data.StrMap as StrMap
import Data.StrMap(StrMap)
import Data.String(Pattern(..), Replacement(..), replaceAll, split)
import Data.Traversable(traverse)
import Partial.Unsafe(unsafePartial)

import Ifrit.Parser as Parser
import Ifrit.Lexer as Lexer

-- TYPES AND CLASSES
data Schema
  = Object (StrMap Schema)
  | Array Schema
  | String
  | Number
  | Boolean
  | Null

derive instance eqSchema :: Eq Schema

-- ERRORS
data Error
  = ErrIncompatibleSchema Schema
  | ErrUnexistingField Lexer.Keyword String
  | ErrIncompatibleUnaryType Lexer.Unary Schema
  | ErrIncompatibleBinaryTypes Lexer.Binary Schema Schema
  | ErrIncompatibleFnType Lexer.Funktion Schema
  | ErrInvalidFieldName String
  | ErrReservedFieldName String

instance showError :: Show Error where
  show err =
    case err of
      ErrUnexistingField stage field ->
        "unexisting field '" <> field <> "' in " <> show stage <> " expression"
      ErrIncompatibleSchema schema ->
        "incompatible object schema for operation: " <> show schema
      ErrIncompatibleUnaryType op type_ ->
        "incompatible type " <> show type_ <> " with unary operator " <> show op
      ErrIncompatibleBinaryTypes op type1 type2 ->
        "incompatible types " <> show type1 <> ", " <> show type2 <>
          " with binary operator " <> show op
      ErrIncompatibleFnType fn type_ ->
        "incompatible type " <> show type_ <> " with function " <> show fn
      ErrInvalidFieldName field ->
        "invalid field's name '" <> field <> "'"
      ErrReservedFieldName field ->
        "reserved field's name '" <> field <> "'"

-- UTILS
fromString :: String -> Either String Schema
fromString =
  jsonParser >=> fromJson

fromJson :: Json -> Either String Schema
fromJson =
  decodeJson

defaultAlias :: String -> Maybe String -> String
defaultAlias default =
    maybe (sanitize default) (\x -> x)
  where
    sanitize :: String -> String
    sanitize = replaceAll (Pattern ".") (Replacement "_")

lookup :: Lexer.Keyword -> Schema -> String -> Either String Schema
lookup stage schema key =
  case schema of
    Object source ->
      case List.fromFoldable $ split (Pattern ".") key of
        Nil ->
          Left $ show $ ErrInvalidFieldName key
        h : q ->
          case { q, schema: StrMap.lookup h source } of
            { q: Nil, schema: Just schema' } ->
              pure schema'
            { q: _, schema: Just schema' } ->
              lookup stage schema' (List.intercalate "." q)
            _ ->
              Left $ show $ ErrUnexistingField stage key
    _ ->
      Left $ show $ ErrIncompatibleSchema schema

-- ANALYZERS
analyze :: Schema -> Parser.Statement -> Either String Schema
analyze schema (Parser.Select projections statement condition orders limit offset) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  _ <- maybe (Right Null) (analyzeCondition schema') condition
  _ <- traverse (analyzeOrder schema') orders
  schema'' <- List.foldM (analyzeProjection schema') StrMap.empty projections
  pure $ Object schema''

analyze schema (Parser.Group index aggregations statement condition orders limit offset) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  _ <- maybe (Right Null) (analyzeCondition schema') condition
  _ <- traverse (analyzeOrder schema') orders
  schema'' <- List.foldM (analyzeAggregation schema') StrMap.empty aggregations
  case index of
    Parser.IdxNull ->
      pure $ Object $ StrMap.insert "_id" Null schema''
    Parser.IdxField key ->
      let
          extend idx = Object $ StrMap.insert "_id" idx schema''
      in
          map extend (lookup Lexer.GroupBy schema' key)

analyzeOrder :: Schema -> Parser.Order -> Either String Schema
analyzeOrder schema order =
  case order of
    Parser.OrderAsc key ->
      analyze' key
    Parser.OrderDesc key ->
      analyze' key
  where
    analyze' key =
      map (const Null) (lookup Lexer.OrderBy schema key)

analyzeCondition :: Schema -> Parser.Condition -> Either String Schema
analyzeCondition schema condition =
  case condition of
    Parser.Term t ->
      analyzeTerm schema t

    Parser.Or t1 t2 ->
      traverse (analyzeTerm schema) [t1, t2] >>= const (Right Boolean)

analyzeTerm :: Schema -> Parser.Term -> Either String Schema
analyzeTerm schema term =
  case term of
    Parser.Factor f ->
      analyzeFactor schema f

    Parser.And f1 f2 ->
      traverse (analyzeFactor schema) [f1, f2] >>= const (Right Boolean)

analyzeFactor :: Schema -> Parser.Factor -> Either String Schema
analyzeFactor schema factor =
  case factor of
    Parser.Operand o ->
      analyzeOperand schema o

    Parser.Condition c ->
      analyzeCondition schema c

    Parser.Unary op c -> do
      s <- analyzeFactor schema c
      case s of
        Boolean ->
          Right Boolean
        _ ->
          Left $ show $ ErrIncompatibleUnaryType op s

    Parser.Binary op o1 o2 -> do
      Pair s1 s2 <- traverse (analyzeOperand schema) (Pair o1 o2)
      case { op, s1, s2 } of
        { op: Lexer.Gt, s1: Number, s2: Number } ->
          Right Boolean
        { op: Lexer.Lt, s1: Number, s2: Number } ->
          Right Boolean
        { op: Lexer.Gt, s1: _, s2: _ } ->
          Left $ show $ ErrIncompatibleBinaryTypes op s1 s2
        { op: Lexer.Lt, s1: _, s2: _ } ->
          Left $ show $ ErrIncompatibleBinaryTypes op s1 s2
        { op: _, s1: Number, s2: Number } ->
          Right Boolean
        { op: _, s1: Boolean, s2: Boolean } ->
          Right Boolean
        { op: _, s1: String, s2: String } ->
          Right Boolean
        { op: _, s1: _, s2: Null } ->
          Right Boolean
        { op: _, s1: Null, s2: _ } ->
          Right Boolean
        _ ->
          Left $ show $ ErrIncompatibleBinaryTypes op s1 s2

analyzeOperand :: Schema -> Parser.Operand -> Either String Schema
analyzeOperand schema operand =
  case operand of
    Parser.String _ ->
      Right String

    Parser.Boolean _ ->
      Right Boolean

    Parser.Number _ ->
      Right Number

    Parser.Null ->
      Right Null

    Parser.Field key ->
      lookup Lexer.Where schema key

analyzeProjection :: Schema -> StrMap Schema -> Parser.Projection -> Either String (StrMap Schema)
analyzeProjection schema acc (Parser.Projection selector) =
    case selector of
      Parser.Selector key as ->
        case lookup Lexer.Select schema key of
          Right schema' ->
            Right $ StrMap.insert (defaultAlias key as) schema' acc

          Left err ->
            Left $ err

      Parser.Function Lexer.Count key as ->
        case lookup Lexer.Select schema key of
          Right (Array _) ->
            Right $ StrMap.insert (defaultAlias key as) Number acc

          Right schema' ->
            Left $ show $ ErrIncompatibleFnType Lexer.Count schema'

          Left err ->
            Left $ err

      f@(Parser.Function Lexer.Avg key as) ->
        unsafePartial $ analyzeNumberProjection f

      f@(Parser.Function Lexer.Max key as) ->
        unsafePartial $ analyzeNumberProjection f

      f@(Parser.Function Lexer.Min key as) ->
        unsafePartial $ analyzeNumberProjection f

      f@(Parser.Function Lexer.Sum key as) ->
        unsafePartial $ analyzeNumberProjection f

  where

    analyzeNumberProjection :: Partial => Parser.Selector -> Either String (StrMap Schema)
    analyzeNumberProjection (Parser.Function f key as) =
      case List.fromFoldable $ split (Pattern ".") key of
        _ : Nil ->
          case lookup Lexer.Select schema key of
            Right (Array Number) ->
              Right $ StrMap.insert (defaultAlias key as) Number acc

            Right schema' ->
              Left $ show $ ErrIncompatibleFnType f schema'

            Left err ->
              Left $ err

        base : key' ->
          case lookup Lexer.Select schema base of
            Right (Array schema') ->
              case lookup Lexer.Select schema' (List.intercalate "." key') of
                Right Number ->
                  Right $ StrMap.insert (defaultAlias key as) Number acc

                Right schema'' ->
                  Left $ show $ ErrIncompatibleFnType f schema''

                Left err ->
                  Left $ err

            Right _ ->
              Left $ show $ ErrIncompatibleFnType f schema

            Left err ->
              Left $ err

        _ ->
          Left $ show $ ErrInvalidFieldName key

analyzeAggregation :: Schema -> StrMap Schema -> Parser.Aggregation -> Either String (StrMap Schema)
analyzeAggregation schema acc (Parser.Aggregation selector) =
  case selector of
    Parser.Selector "_id" Nothing ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Selector _ (Just "_id") ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Function _ "_id" Nothing ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Function _ _ (Just "_id") ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Selector key as ->
      case lookup Lexer.Select schema key of
        Right schema' ->
          Right $ StrMap.insert (defaultAlias key as) (Array schema') acc

        Left err ->
          Left $ err

    f@(Parser.Function Lexer.Count key as) ->
      case lookup Lexer.Select schema key of
        Right _ ->
          Right $ StrMap.insert (defaultAlias key as) Number acc
        Left err ->
          Left $ err

    f@(Parser.Function Lexer.Avg key as) ->
      unsafePartial $ analyzeNumberAggregation f

    f@(Parser.Function Lexer.Max key as) ->
      unsafePartial $ analyzeNumberAggregation f

    f@(Parser.Function Lexer.Min key as) ->
      unsafePartial $ analyzeNumberAggregation f

    f@(Parser.Function Lexer.Sum key as) ->
      unsafePartial $ analyzeNumberAggregation f

  where

    analyzeNumberAggregation :: Partial => Parser.Selector -> Either String (StrMap Schema)
    analyzeNumberAggregation (Parser.Function f key as) =
      case lookup Lexer.Select schema key of
        Right Number ->
          Right $ StrMap.insert (defaultAlias key as) Number acc

        Right schema' ->
          Left $ show $ ErrIncompatibleFnType f schema'

        Left err ->
          Left $ err

instance decodeSchema :: DecodeJson Schema where
  decodeJson =
      foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject
    where
      decodeNull _ =
        Left "can't decode null to schema"

      decodeBoolean _ =
        Left "can't decode boolean to schema"

      decodeNumber _ =
        Left "can't decode number to schema"

      decodeString "string" =
        Right String

      decodeString "number" =
        Right Number

      decodeString "boolean" =
        Right Boolean

      decodeString "null" =
        Right Null

      decodeString s =
        Left ("unknown schema's type" <> s)

      decodeArray xs =
        if length xs /= 1
           then Left "can't decode array: exactly one element is expected"
           else case head xs of
             Nothing ->
              Left "can't decode array: exactly one element is expected"
             Just schema ->
               Array <$> decodeJson schema

      decodeObject obj =
        Object <$> traverse decodeJson obj

instance encodeJsonSchema :: EncodeJson Schema where
  encodeJson schema =
    case schema of
      Object schema' ->
        encodeJson $ map encodeJson schema'

      Array schema' ->
        encodeJson $ [encodeJson schema']

      Number ->
        encodeJson "number"

      String ->
        encodeJson "string"

      Boolean ->
        encodeJson "boolean"

      Null ->
        encodeJson "null"

instance showSchema :: EncodeJson Schema => Show Schema where
  show = encodeJson >>> stringify

module Ifrit.Semantic
  ( Schema(..)
  , analyze
  , fromJson
  , fromString
  ) where

import Prelude

import Data.Argonaut.Core(Json, foldJson, stringify)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.Argonaut.Parser(jsonParser)
import Data.Array(head, length)
import Data.Either(Either(..))
import Data.List(List(..), (:))
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.Pair(Pair(..))
import Data.StrMap as StrMap
import Data.StrMap(StrMap)
import Data.String(Pattern(..), Replacement(..), replaceAll, split)
import Data.Traversable(traverse)
import Partial.Unsafe(unsafePartial)

import Ifrit.Parser as Parser
import Ifrit.Lexer as Lexer

-- TYPES AND CLASSES
data Schema
  = Object (StrMap Schema)
  | Array Schema
  | String
  | Number
  | Boolean
  | Null

derive instance eqSchema :: Eq Schema

-- ERRORS
data Error
  = ErrIncompatibleSchema Schema
  | ErrUnexistingField Lexer.Keyword String
  | ErrIncompatibleUnaryType Lexer.Unary Schema
  | ErrIncompatibleBinaryTypes Lexer.Binary Schema Schema
  | ErrIncompatibleFnType Lexer.Funktion Schema
  | ErrInvalidFieldName String
  | ErrReservedFieldName String

instance showError :: Show Error where
  show err =
    case err of
      ErrUnexistingField stage field ->
        "unexisting field '" <> field <> "' in " <> show stage <> " expression"
      ErrIncompatibleSchema schema ->
        "incompatible object schema for operation: " <> show schema
      ErrIncompatibleUnaryType op type_ ->
        "incompatible type " <> show type_ <> " with unary operator " <> show op
      ErrIncompatibleBinaryTypes op type1 type2 ->
        "incompatible types " <> show type1 <> ", " <> show type2 <>
          " with binary operator " <> show op
      ErrIncompatibleFnType fn type_ ->
        "incompatible type " <> show type_ <> " with function " <> show fn
      ErrInvalidFieldName field ->
        "invalid field's name '" <> field <> "'"
      ErrReservedFieldName field ->
        "reserved field's name '" <> field <> "'"

-- UTILS
fromString :: String -> Either String Schema
fromString =
  jsonParser >=> fromJson

fromJson :: Json -> Either String Schema
fromJson =
  decodeJson

defaultAlias :: String -> Maybe String -> String
defaultAlias default =
    maybe (sanitize default) (\x -> x)
  where
    sanitize :: String -> String
    sanitize = replaceAll (Pattern ".") (Replacement "_")

lookup :: Lexer.Keyword -> Schema -> String -> Either String Schema
lookup stage schema key =
  case schema of
    Object source ->
      case List.fromFoldable $ split (Pattern ".") key of
        Nil ->
          Left $ show $ ErrInvalidFieldName key
        h : q ->
          case { q, schema: StrMap.lookup h source } of
            { q: Nil, schema: Just schema' } ->
              pure schema'
            { q: _, schema: Just schema' } ->
              lookup stage schema' (List.intercalate "." q)
            _ ->
              Left $ show $ ErrUnexistingField stage key
    _ ->
      Left $ show $ ErrIncompatibleSchema schema

-- ANALYZERS
analyze :: Schema -> Parser.Statement -> Either String Schema
analyze schema (Parser.Select projections statement condition orders limit offset) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  _ <- maybe (Right Null) (analyzeCondition schema') condition
  _ <- traverse (analyzeOrder schema') orders
  schema'' <- List.foldM (analyzeProjection schema') StrMap.empty projections
  pure $ Object schema''

analyze schema (Parser.Group index aggregations statement condition orders limit offset) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  _ <- maybe (Right Null) (analyzeCondition schema') condition
  _ <- traverse (analyzeOrder schema') orders
  schema'' <- List.foldM (analyzeAggregation schema') StrMap.empty aggregations
  case index of
    Parser.IdxNull ->
      pure $ Object $ StrMap.insert "_id" Null schema''
    Parser.IdxField key ->
      let
          extend idx = Object $ StrMap.insert "_id" idx schema''
      in
          map extend (lookup Lexer.GroupBy schema' key)

analyzeOrder :: Schema -> Parser.Order -> Either String Schema
analyzeOrder schema order =
  case order of
    Parser.OrderAsc key ->
      analyze' key
    Parser.OrderDesc key ->
      analyze' key
  where
    analyze' key =
      map (const Null) (lookup Lexer.OrderBy schema key)

analyzeCondition :: Schema -> Parser.Condition -> Either String Schema
analyzeCondition schema condition =
  case condition of
    Parser.Term t ->
      analyzeTerm schema t

    Parser.Or t1 t2 ->
      traverse (analyzeTerm schema) [t1, t2] >>= const (Right Boolean)

analyzeTerm :: Schema -> Parser.Term -> Either String Schema
analyzeTerm schema term =
  case term of
    Parser.Factor f ->
      analyzeFactor schema f

    Parser.And f1 f2 ->
      traverse (analyzeFactor schema) [f1, f2] >>= const (Right Boolean)

analyzeFactor :: Schema -> Parser.Factor -> Either String Schema
analyzeFactor schema factor =
  case factor of
    Parser.Operand o ->
      analyzeOperand schema o

    Parser.Condition c ->
      analyzeCondition schema c

    Parser.Unary op c -> do
      s <- analyzeFactor schema c
      case s of
        Boolean ->
          Right Boolean
        _ ->
          Left $ show $ ErrIncompatibleUnaryType op s

    Parser.Binary op o1 o2 -> do
      Pair s1 s2 <- traverse (analyzeOperand schema) (Pair o1 o2)
      case { op, s1, s2 } of
        { op: Lexer.Gt, s1: Number, s2: Number } ->
          Right Boolean
        { op: Lexer.Lt, s1: Number, s2: Number } ->
          Right Boolean
        { op: Lexer.Gt, s1: _, s2: _ } ->
          Left $ show $ ErrIncompatibleBinaryTypes op s1 s2
        { op: Lexer.Lt, s1: _, s2: _ } ->
          Left $ show $ ErrIncompatibleBinaryTypes op s1 s2
        { op: _, s1: Number, s2: Number } ->
          Right Boolean
        { op: _, s1: Boolean, s2: Boolean } ->
          Right Boolean
        { op: _, s1: String, s2: String } ->
          Right Boolean
        { op: _, s1: _, s2: Null } ->
          Right Boolean
        { op: _, s1: Null, s2: _ } ->
          Right Boolean
        _ ->
          Left $ show $ ErrIncompatibleBinaryTypes op s1 s2

analyzeOperand :: Schema -> Parser.Operand -> Either String Schema
analyzeOperand schema operand =
  case operand of
    Parser.String _ ->
      Right String

    Parser.Boolean _ ->
      Right Boolean

    Parser.Number _ ->
      Right Number

    Parser.Null ->
      Right Null

    Parser.Field key ->
      lookup Lexer.Where schema key

analyzeProjection :: Schema -> StrMap Schema -> Parser.Projection -> Either String (StrMap Schema)
analyzeProjection schema acc (Parser.Projection selector) =
    case selector of
      Parser.Selector key as ->
        case lookup Lexer.Select schema key of
          Right schema' ->
            Right $ StrMap.insert (defaultAlias key as) schema' acc

          Left err ->
            Left $ err

      Parser.Function Lexer.Count key as ->
        case lookup Lexer.Select schema key of
          Right (Array _) ->
            Right $ StrMap.insert (defaultAlias key as) Number acc

          Right schema' ->
            Left $ show $ ErrIncompatibleFnType Lexer.Count schema'

          Left err ->
            Left $ err

      f@(Parser.Function Lexer.Avg key as) ->
        unsafePartial $ analyzeNumberProjection f

      f@(Parser.Function Lexer.Max key as) ->
        unsafePartial $ analyzeNumberProjection f

      f@(Parser.Function Lexer.Min key as) ->
        unsafePartial $ analyzeNumberProjection f

      f@(Parser.Function Lexer.Sum key as) ->
        unsafePartial $ analyzeNumberProjection f

  where

    analyzeNumberProjection :: Partial => Parser.Selector -> Either String (StrMap Schema)
    analyzeNumberProjection (Parser.Function f key as) =
      case List.fromFoldable $ split (Pattern ".") key of
        _ : Nil ->
          case lookup Lexer.Select schema key of
            Right (Array Number) ->
              Right $ StrMap.insert (defaultAlias key as) Number acc

            Right schema' ->
              Left $ show $ ErrIncompatibleFnType f schema'

            Left err ->
              Left $ err

        base : key' ->
          case lookup Lexer.Select schema base of
            Right (Array schema') ->
              case lookup Lexer.Select schema' (List.intercalate "." key') of
                Right Number ->
                  Right $ StrMap.insert (defaultAlias key as) Number acc

                Right schema'' ->
                  Left $ show $ ErrIncompatibleFnType f schema''

                Left err ->
                  Left $ err

            Left err ->
              Left $ err

        _ ->
          Left $ show $ ErrInvalidFieldName key

analyzeAggregation :: Schema -> StrMap Schema -> Parser.Aggregation -> Either String (StrMap Schema)
analyzeAggregation schema acc (Parser.Aggregation selector) =
  case selector of
    Parser.Selector "_id" Nothing ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Selector _ (Just "_id") ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Function _ "_id" Nothing ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Function _ _ (Just "_id") ->
      Left $ show $ ErrReservedFieldName "_id"

    Parser.Selector key as ->
      case lookup Lexer.Select schema key of
        Right schema' ->
          Right $ StrMap.insert (defaultAlias key as) (Array schema') acc

        Left err ->
          Left $ err

    f@(Parser.Function Lexer.Count key as) ->
      case lookup Lexer.Select schema key of
        Right _ ->
          Right $ StrMap.insert (defaultAlias key as) Number acc
        Left err ->
          Left $ err

    f@(Parser.Function Lexer.Avg key as) ->
      unsafePartial $ analyzeNumberAggregation f

    f@(Parser.Function Lexer.Max key as) ->
      unsafePartial $ analyzeNumberAggregation f

    f@(Parser.Function Lexer.Min key as) ->
      unsafePartial $ analyzeNumberAggregation f

    f@(Parser.Function Lexer.Sum key as) ->
      unsafePartial $ analyzeNumberAggregation f

  where

    analyzeNumberAggregation :: Partial => Parser.Selector -> Either String (StrMap Schema)
    analyzeNumberAggregation (Parser.Function f key as) =
      case lookup Lexer.Select schema key of
        Right Number ->
          Right $ StrMap.insert (defaultAlias key as) Number acc

        Right schema' ->
          Left $ show $ ErrIncompatibleFnType f schema'

        Left err ->
          Left $ err

instance decodeSchema :: DecodeJson Schema where
  decodeJson =
      foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject
    where
      decodeNull _ =
        Left "can't decode null to schema"

      decodeBoolean _ =
        Left "can't decode boolean to schema"

      decodeNumber _ =
        Left "can't decode number to schema"

      decodeString "string" =
        Right String

      decodeString "number" =
        Right Number

      decodeString "boolean" =
        Right Boolean

      decodeString "null" =
        Right Null

      decodeString s =
        Left ("unknown schema's type" <> s)

      decodeArray xs =
        if length xs /= 1
           then Left "can't decode array: exactly one element is expected"
           else case head xs of
             Nothing ->
              Left "can't decode array: exactly one element is expected"
             Just schema ->
               Array <$> decodeJson schema

      decodeObject obj =
        Object <$> traverse decodeJson obj

instance encodeJsonSchema :: EncodeJson Schema where
  encodeJson schema =
    case schema of
      Object schema' ->
        encodeJson $ map encodeJson schema'

      Array schema' ->
        encodeJson $ [encodeJson schema']

      Number ->
        encodeJson "number"

      String ->
        encodeJson "string"

      Boolean ->
        encodeJson "boolean"

      Null ->
        encodeJson "null"

instance showSchema :: EncodeJson Schema => Show Schema where
  show = encodeJson >>> stringify


Terse up `case of` expression

Terse up `case of` expression

module Docopt.Parser.Scanner where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
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 Data.List (List(..), many, toList, fromList, (:), length, filter)
import qualified Data.Array as A
import Data.String (toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage

data Section
  = Preamble String
  | Usage String
  | Options String

unSection :: Section -> String
unSection (Preamble s) = s
unSection (Usage    s) = s
unSection (Options  s) = s

data Docopt = Docopt String (List String)

instance showDocopt :: Show Docopt where
  show (Docopt x xs) = "Docopt " ++ show x ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into sections.
scanDocopt :: P.Parser String Docopt
scanDocopt = do

  P.manyTill P.anyChar (P.lookAhead anySectionHeader)
  sections <- many parseSection
  usage <- case findUsages sections of
    Nil        -> P.fail "No usage section found!"
    Cons x Nil -> pure x
    _          -> P.fail "More than one usage section found!"

  return $ Docopt
    (unSection usage)
    (map unSection $ findOptions sections)

  where
    findUsages           = filter isUsage
    isUsage (Usage _)    = true
    isUsage _            = false
    findOptions          = filter isOption
    isOption (Options _) = true
    isOption _           = false

    anySectionHeader :: P.Parser String String
    anySectionHeader = usageSectionHeader <|> optionsSectionHeader

    usageSectionHeader :: P.Parser String String
    usageSectionHeader = sectionHeader "usage"

    optionsSectionHeader :: P.Parser String String
    optionsSectionHeader = sectionHeader "options"

    sectionHeader :: String -> P.Parser String String
    sectionHeader s = (do
      col <- getCol
      guard (col == 1)
      string' s <* (P.try $ P.char ':')
      ) P.<?> "section header"

    emptyLine :: P.Parser String Unit
    emptyLine = (do
      col <- getCol
      guard (col == 1)
      many space *> eol
      ) P.<?> "empty line"

    extractSectionSource :: P.Parser String String
    extractSectionSource = do
      many space *> eol
      many $ P.try emptyLine

      -- The section block extends until the first empty line is
      -- encountered OR until a new section is found OR the EOF
      -- is encountered.

      source <- fromCharArray <<< fromList <$> P.manyTill
        P.anyChar
        (P.try $ P.lookAhead do
              emptyLine
          <|> void anySectionHeader
          <|> P.eof)

      P.eof <|> (void $ P.try $ do
        emptyLine
        P.manyTill P.anyChar $ P.try do
          P.eof <|> (void $ P.lookAhead anySectionHeader))

      pure source

    parseSection :: P.Parser String Section
    parseSection = P.choice
      [ Usage   <$> (usageSectionHeader   *> extractSectionSource)
      , Options <$> (optionsSectionHeader *> extractSectionSource)
      ]

module Docopt.Parser.Scanner where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
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 Data.List (List(..), many, toList, fromList, (:), length, filter)
import qualified Data.Array as A
import Data.String (toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage

data Section
  = Preamble String
  | Usage String
  | Options String

unSection :: Section -> String
unSection (Preamble s) = s
unSection (Usage    s) = s
unSection (Options  s) = s

data Docopt = Docopt String (List String)

instance showDocopt :: Show Docopt where
  show (Docopt x xs) = "Docopt " ++ show x ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into sections.
scanDocopt :: P.Parser String Docopt
scanDocopt = do

  P.manyTill P.anyChar (P.lookAhead anySectionHeader)
  sections <- many parseSection
  usage <- case findUsages sections of
    Nil               -> P.fail "No usage section found!"
    Cons _ (Cons _ _) -> P.fail "More than one usage section found!"
    Cons x Nil        -> pure x

  return $ Docopt
    (unSection usage)
    (map unSection $ findOptions sections)

  where
    findUsages           = filter isUsage
    isUsage (Usage _)    = true
    isUsage _            = false
    findOptions          = filter isOption
    isOption (Options _) = true
    isOption _           = false

    anySectionHeader :: P.Parser String String
    anySectionHeader = usageSectionHeader <|> optionsSectionHeader

    usageSectionHeader :: P.Parser String String
    usageSectionHeader = sectionHeader "usage"

    optionsSectionHeader :: P.Parser String String
    optionsSectionHeader = sectionHeader "options"

    sectionHeader :: String -> P.Parser String String
    sectionHeader s = (do
      col <- getCol
      guard (col == 1)
      string' s <* (P.try $ P.char ':')
      ) P.<?> "section header"

    emptyLine :: P.Parser String Unit
    emptyLine = (do
      col <- getCol
      guard (col == 1)
      many space *> eol
      ) P.<?> "empty line"

    extractSectionSource :: P.Parser String String
    extractSectionSource = do
      many space *> eol
      many $ P.try emptyLine

      -- The section block extends until the first empty line is
      -- encountered OR until a new section is found OR the EOF
      -- is encountered.

      source <- fromCharArray <<< fromList <$> P.manyTill
        P.anyChar
        (P.try $ P.lookAhead do
              emptyLine
          <|> void anySectionHeader
          <|> P.eof)

      P.eof <|> (void $ P.try $ do
        emptyLine
        P.manyTill P.anyChar $ P.try do
          P.eof <|> (void $ P.lookAhead anySectionHeader))

      pure source

    parseSection :: P.Parser String Section
    parseSection = P.choice
      [ Usage   <$> (usageSectionHeader   *> extractSectionSource)
      , Options <$> (optionsSectionHeader *> extractSectionSource)
      ]