Adapt to changes in ACE

Adapt to changes in ACE

module Main where

import Control.Monad.Eff.JQuery as J
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import Data.Foreign (unsafeFromForeign)
import Prelude

import Ace.Types (ACE())
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Range as  Range

import Data.Either
import Data.Maybe
import Data.List
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator (evalPath1, Env(), Path(), defsToEnv)
import AST
import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import JSHelpers

main :: DOMEff J.JQuery
main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

type EvalState = { env :: Env, expr :: Expr, history :: List Expr }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue

  case parseExpr input of
    Left err   -> showInfo "Expression" (show err)
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
          showInfo "Definitions" (show err)
          markText (line - 1) column
        Right env -> do
          clearInfo
          void $ runStateT showEvaluationState { env: env, expr: expr, history: Nil }

markText :: Int -> Int -> DOMEff Unit
markText line column = do
  editor <- Ace.edit "definitions" Ace.ace
  session <- Editor.getSession editor
  rang <- Range.create line column 100000 100000
  void $ Session.addMarker rang "syntaxError" "" false session

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list, .if" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: (List Expr) -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

(!!!) :: forall a. (List a) -> Int -> a
(!!!) xs i = case xs !! i of Just x -> x

showHistory :: Expr -> Int -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = maybe es.history id (deleteAt i es.history) }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = es.history !!! i }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

showInfo :: String -> String -> DOMEff Unit
showInfo origin msg = do
  info <- J.create "

"
    >>= J.addClass "info"
    >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
  clearInfo
  J.select "#info"
    >>= J.append info
  return unit

clearInfo :: DOMEff Unit
clearInfo = void $ J.select "#info" >>= J.clear

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ jqMap (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left err -> void $ J.setAttr "title" (show err) jq
      Right _  -> void $ J.addClass "clickable" jq *> J.setAttr "title" "" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    -- Left msg   -> liftEff $ showInfo "execution" msg
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import Control.Monad.Eff.JQuery as J
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import Data.Foreign (unsafeFromForeign)
import Prelude

import Ace.Types (ACE())
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Range as  Range

import Data.Either
import Data.Maybe
import Data.List
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator (evalPath1, Env(), Path(), defsToEnv)
import AST
import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import JSHelpers

main :: DOMEff J.JQuery
main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

type EvalState = { env :: Env, expr :: Expr, history :: List Expr }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue

  case parseExpr input of
    Left err   -> showInfo "Expression" (show err)
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
          showInfo "Definitions" (show err)
          markText (line - 1) column
        Right env -> do
          clearInfo
          void $ runStateT showEvaluationState { env: env, expr: expr, history: Nil }

markText :: Int -> Int -> DOMEff Unit
markText line column = do
  editor <- Ace.edit "definitions" Ace.ace
  session <- Editor.getSession editor
  rang <- Range.create line column 100000 100000
  Session.addMarker rang "syntaxError" "" false session

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list, .if" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: (List Expr) -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

(!!!) :: forall a. (List a) -> Int -> a
(!!!) xs i = case xs !! i of Just x -> x

showHistory :: Expr -> Int -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = maybe es.history id (deleteAt i es.history) }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = es.history !!! i }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

showInfo :: String -> String -> DOMEff Unit
showInfo origin msg = do
  info <- J.create "

"
    >>= J.addClass "info"
    >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
  clearInfo
  J.select "#info"
    >>= J.append info
  return unit

clearInfo :: DOMEff Unit
clearInfo = void $ J.select "#info" >>= J.clear

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ jqMap (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left err -> void $ J.setAttr "title" (show err) jq
      Right _  -> void $ J.addClass "clickable" jq *> J.setAttr "title" "" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    -- Left msg   -> liftEff $ showInfo "execution" msg
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq


rename renderEntry to viewEntry

rename renderEntry to viewEntry

module Main where

import App.Events (AppEffects)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array (filter, snoc)
import Data.Foldable (for_)
import Pux (CoreEffects, App, start, EffModel, noEffects)
import Pux.DOM.Events (DOMEvent, onClick, onChange, targetValue)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (div, button, input)
import Text.Smolder.HTML.Attributes (value)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

data Event = FieldChanged DOMEvent
           | AddEntry DOMEvent
           | DeleteEntry Int DOMEvent

newtype Entry = Entry { id :: Int
                      , title :: String
                      }

mkEntry :: Int -> String -> Entry
mkEntry id title = Entry { id, title }

newtype State = State { nextId :: Int
                      , editingField :: String
                      , entries :: Array Entry
                      }

init :: String -> State
init url = State { nextId: 0
                 , editingField: ""
                 , entries: []
                 }

foldp :: forall fx. Event -> State -> EffModel State Event (AppEffects fx)
foldp (FieldChanged ev) (State s) =
  noEffects $ State s { editingField = targetValue ev }

foldp (AddEntry ev) (State s) =
  noEffects $ State s { nextId = s.nextId + 1
                      , editingField = ""
                      , entries = snoc s.entries $ mkEntry s.nextId s.editingField
                      }

foldp (DeleteEntry id ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> en.id /= id) s.entries }

viewEntry :: Entry -> HTML Event
viewEntry (Entry { id, title }) = div do
  text title
  button #! onClick (DeleteEntry id) $ text "x"

view :: State -> HTML Event
view (State st) = div do
  div $ text $ "nextId = " <> show st.nextId
  div $ text $ "editingField = " <> show st.editingField
  div do
    for_ st.entries $ viewEntry
  div do
    input #! onChange FieldChanged ! value st.editingField
    button #! onClick AddEntry $ text "Add"

--------------------
-- infrastructure --
--------------------

type WebApp = App (DOMEvent -> Event) Event State

type ClientEffects = CoreEffects (AppEffects (dom :: DOM))

main :: String -> State -> Eff ClientEffects WebApp
main url state = do
  -- | Start the app.
  app <- start
    { initialState: state
    , view
    , foldp
    , inputs: [] }

  -- | Render to the DOM
  renderToDOM "#app" app.markup app.input

  -- | Return app to be used for hot reloading logic in support/client.entry.js
  pure app

initialState :: State
initialState = init "/"

module Main where

import Prelude hiding (div)
import App.Events (AppEffects)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Pux (CoreEffects, App, start, EffModel, noEffects)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (DOMEvent, onClick, onChange, targetValue)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (div, input, button)
import Text.Smolder.HTML.Attributes (value)
import Text.Smolder.Markup (text, (!), (#!))
import Data.Foldable (for_)
import Data.Array (snoc, filter)

data Event = FieldChanged DOMEvent
           | AddEntry DOMEvent
           | DeleteEntry Int DOMEvent

newtype Entry = Entry { id :: Int
                      , title :: String
                      }

mkEntry :: Int -> String -> Entry
mkEntry id title = Entry { id, title }

newtype State = State { nextId :: Int
                      , editingField :: String
                      , entries :: Array Entry
                      }

init :: String -> State
init url = State { nextId: 0
                 , editingField: ""
                 , entries: []
                 }

foldp :: forall fx. Event -> State -> EffModel State Event (AppEffects fx)
foldp (FieldChanged ev) (State s) =
  noEffects $ State s { editingField = targetValue ev }

foldp (AddEntry ev) (State s) =
  noEffects $ State s { nextId = s.nextId + 1
                      , editingField = ""
                      , entries = snoc s.entries $ mkEntry s.nextId s.editingField
                      }

foldp (DeleteEntry id ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> en.id /= id) s.entries }

renderEntry :: Entry -> HTML Event
renderEntry (Entry { id, title }) = div do
  text title
  button #! onClick (DeleteEntry id) $ text "x"

view :: State -> HTML Event
view (State st) = div do
  div $ text $ "nextId = " <> show st.nextId
  div $ text $ "editingField = " <> show st.editingField
  div do
    for_ st.entries renderEntry
  div do
    input #! onChange FieldChanged ! value st.editingField
    button #! onClick AddEntry $ text "Add"

--------------------
-- infrastructure --
--------------------

type WebApp = App (DOMEvent -> Event) Event State

type ClientEffects = CoreEffects (AppEffects (dom :: DOM))

main :: String -> State -> Eff ClientEffects WebApp
main url state = do
  -- | Start the app.
  app <- start
    { initialState: state
    , view
    , foldp
    , inputs: [] }

  -- | Render to the DOM
  renderToDOM "#app" app.markup app.input

  -- | Return app to be used for hot reloading logic in support/client.entry.js
  pure app

initialState :: State
initialState = init "/"


Use "C-family" rather than "C-deriving" rendering

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` becaue no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
-- |
-- | This should not be confused with the word, `void,` that commonly appears in
-- | C-family languages, such as Java:
-- | ```
-- | public class Foo {
-- |   void doSomething() { System.out.println("hello world!"); }
-- | }
-- | ```
-- |
-- | In PureScript, one often uses `Unit` to achieve similar effects as
-- | the lowercased `void` above.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

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

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` becaue no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
-- |
-- | This should not be confused with the word, `void,` that commonly appears in
-- | C-deriving languages, such as Java:
-- | ```
-- | public class Foo {
-- |   void doSomething() { System.out.println("hello world!"); }
-- | }
-- | ```
-- |
-- | In PureScript, one often uses `Unit` to achieve similar effects as
-- | the lowercased `void` above.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

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


Eval list comps without let and prefer (:) over (++)

module Evaluator where

import Prelude (class Show, top, bottom, class Semigroup, class Functor, class Monad, Unit, Ordering(..), (<>), ($), (||), (&&), unit, (<*>), (<$>), 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, (:), drop, updateAt, (!!), concat)
import Data.List.Lazy (replicate)
import Data.StrMap (StrMap, delete)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (toChar)
import Data.String (singleton) as String
import Data.Char (fromCharCode)
import Data.Enum (fromEnum)
import Control.Applicative (pure)
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Control.Comonad (extract)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Trans (StateT, get, modify, runStateT, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

import 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 = extract <<< runExceptT

type Matcher = ExceptT MatchingError Identity

runMatcherM :: forall a. Matcher a -> Either MatchingError a
runMatcherM = extract <<< 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
    LetExpr (Cons (Tuple bin ex) bins) expr -> do
      ex'   <- go p ex
      bin'  <- pure bin
      bins' <- pure bins
      expr' <- pure expr
      pure $ LetExpr (Cons (Tuple bin' ex') bins') expr'
    _               -> 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' -> pure 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' -> pure 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 (pure <<< 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 $ Map.toList env
  where
    tupleToDef (Tuple name defs) = map
                                    (\(Tuple bin expr) -> Def name bin expr)
                                    defs

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

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 _)   -> pure te
  (IfExpr (Atom (Bool false)) _ ee)  -> pure ee
  (ArithmSeq start step end)         -> evalArithmSeq start step end
--  (List (e:es))                      -> pure $ Binary Cons e (List es)
  (App (Binary Composition f g) (Cons e Nil)) -> pure $ 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 <|>-} (pure $ Binary op e1 e2)
  (App (SectR op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary op e1 e2)
  (App (PrefixOp op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> pure $ App func (es <> es')
  (ListComp e qs)                    -> evalListComp e qs
  (LetExpr binds exp)                -> evalLetExpr binds exp
  _                                  -> 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 -> pure body
    GT -> pure $ Lambda (drop (length args) binds) body
    LT -> pure $ App body (drop (length binds) args)

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

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

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

data Quat a = Quat a a a a

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

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

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

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

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

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

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

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

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

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

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

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

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

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
      Quat Nothing _ _ _          -> pure $ List Nil
      Quat (Just a) Nothing _ _   -> pure $ Binary Colon a (List Nil)
      Quat (Just a) (Just na) b c -> pure $ Binary Colon a (ArithmSeq na b c)

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

evalListComp :: Expr -> List ExprQual -> Evaluator Expr
evalListComp expr Nil         = pure $ List $ singleton expr
evalListComp expr (Cons q qs) = case q of
  Guard (Atom (Bool false)) -> pure $ List Nil
  Guard (Atom (Bool true))  -> if null qs then pure (List (singleton expr)) else pure (ListComp expr qs)
  Gen _ (List Nil)          -> pure $ List Nil
  -- Gen b (List (Cons e Nil)) -> evalListComp expr (Cons (Let b e) qs)
  Gen b (List (Cons e es))  -> do
    listcomp1 <- evalListComp expr (Cons (Let b e) qs)
    listcomp2 <- pure $ ListComp expr (Cons (Gen b (List es)) qs)
    case listcomp1 of
      List (Cons x Nil) -> pure $ Binary Colon x listcomp2
      _ -> pure $ Binary Append listcomp1 listcomp2
  -- Gen b (Binary Colon e (List Nil)) -> evalListComp expr (Cons (Let b e) qs)
  Gen b (Binary Colon e es)  -> do
    listcomp1 <- evalListComp expr (Cons (Let b e) qs)
    listcomp2 <- pure $ ListComp expr (Cons (Gen b es) qs)
    case listcomp1 of
      List (Cons x Nil) -> pure $ Binary Colon x listcomp2
      _ -> pure $ 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 -> pure $ List $ singleton expr'
          _   -> pure $ ListComp expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp expr (Cons q qs))

-- 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' -> pure $ Gen b e'
      Let b e -> scope b e >>= \e' -> pure $ Let b e'
      Guard e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard e'

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

------------------------------------------------------------------------------------------
-- Let Expressions
------------------------------------------------------------------------------------------

type Bindings = List (Tuple Binding Expr)

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

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

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

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) -> pure $ List $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List ls1) (List ls2)) -> pure $ 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)) _                  ) -> pure $ Atom $ Bool false
    (Tuple _                   (Atom (Bool false))) -> pure $ Atom $ Bool false
    (Tuple (Atom (Bool true))  (Atom (Bool true)) ) -> pure $ Atom $ Bool true
    (Tuple _                   _                  ) -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom (Bool true))  _                   ) -> pure $ Atom $ Bool true
    (Tuple _                   (Atom (Bool true))  ) -> pure $ Atom $ Bool true
    (Tuple (Atom (Bool false))  (Atom (Bool false))) -> pure $ Atom $ Bool false
    (Tuple _                   _                   ) -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ 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)) = pure $ 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))  = pure $ Atom $ Bool $ fi i j
    ord _  _  fs _  (Atom (Char s1)) (Atom (Char s2)) = pure $ Atom $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom (Bool b1)) (Atom (Bool b2)) = pure $ 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)) = pure $ 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)) = pure $ 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)) = pure $ 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  -> pure 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)

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

-- removes every entry in StrMap that is inside the binding
removeOverlapping :: Binding -> 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 -> pure subExpr
      Nothing      -> pure 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
      pure $ ListComp expr' quals'
    (LetExpr binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr binds' expr'
    e                     -> pure e

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

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

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

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

module Evaluator where

import Prelude (class Show, top, bottom, class Semigroup, class Functor, class Monad, Unit, Ordering(..), (<>), ($), (||), (&&), unit, (<*>), (<$>), 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, (:), drop, updateAt, (!!), concat)
import Data.List.Lazy (replicate)
import Data.StrMap (StrMap, delete)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (toChar)
import Data.String (singleton) as String
import Data.Char (fromCharCode)
import Data.Enum (fromEnum)
import Control.Applicative (pure)
import Control.Apply ((*>))
import Control.Alt ((<|>))
import Control.Comonad (extract)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Trans (StateT, get, modify, runStateT, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

import 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 = extract <<< runExceptT

type Matcher = ExceptT MatchingError Identity

runMatcherM :: forall a. Matcher a -> Either MatchingError a
runMatcherM = extract <<< 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
    LetExpr (Cons (Tuple bin ex) bins) expr -> do
      ex'   <- go p ex
      bin'  <- pure bin
      bins' <- pure bins
      expr' <- pure expr
      pure $ LetExpr (Cons (Tuple bin' ex') bins') expr'
    _               -> 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' -> pure 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' -> pure 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 (pure <<< 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 $ Map.toList env
  where
    tupleToDef (Tuple name defs) = map
                                    (\(Tuple bin expr) -> Def name bin expr)
                                    defs

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

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 _)   -> pure te
  (IfExpr (Atom (Bool false)) _ ee)  -> pure ee
  (ArithmSeq start step end)         -> evalArithmSeq start step end
--  (List (e:es))                      -> pure $ Binary Cons e (List es)
  (App (Binary Composition f g) (Cons e Nil)) -> pure $ 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 <|>-} (pure $ Binary op e1 e2)
  (App (SectR op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary op e1 e2)
  (App (PrefixOp op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> pure $ App func (es <> es')
  (ListComp e qs)                    -> evalListComp e qs
  (LetExpr binds exp)                -> evalLetExpr binds exp
  _                                  -> 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 -> pure body
    GT -> pure $ Lambda (drop (length args) binds) body
    LT -> pure $ App body (drop (length binds) args)

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

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

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

data Quat a = Quat a a a a

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

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

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

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

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

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

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

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

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

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

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

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

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

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
      Quat Nothing _ _ _          -> pure $ List Nil
      Quat (Just a) Nothing _ _   -> pure $ Binary Colon a (List Nil)
      Quat (Just a) (Just na) b c -> pure $ Binary Colon a (ArithmSeq na b c)

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

evalListComp :: Expr -> List ExprQual -> Evaluator Expr
evalListComp expr Nil         = pure $ List $ singleton expr
evalListComp expr (Cons q qs) = case q of
  Guard (Atom (Bool false)) -> pure $ List Nil
  Guard (Atom (Bool true))  -> if null qs then pure (List (singleton expr)) else pure (ListComp expr qs)
  Gen _ (List Nil)          -> pure $ List Nil
  Gen b (List (Cons e Nil)) -> pure $ ListComp expr (Cons (Let b e) qs)
  Gen b (List (Cons e es))  -> do
    listcomp1 <- pure $ ListComp expr (Cons (Let b e) qs)
    listcomp2 <- pure $ ListComp expr (Cons (Gen b (List es)) qs)
    pure $ Binary Append listcomp1 listcomp2
  Gen b (Binary Colon e (List Nil)) -> pure $ ListComp expr (Cons (Let b e) qs)
  Gen b (Binary Colon e es)  -> do
    listcomp1 <- pure $ ListComp expr (Cons (Let b e) qs)
    listcomp2 <- pure $ ListComp expr (Cons (Gen b es) qs)
    pure $ 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 -> pure $ List $ singleton expr'
          _   -> pure $ ListComp expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp expr (Cons q qs))

-- 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' -> pure $ Gen b e'
      Let b e -> scope b e >>= \e' -> pure $ Let b e'
      Guard e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard e'

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

------------------------------------------------------------------------------------------
-- Let Expressions
------------------------------------------------------------------------------------------

type Bindings = List (Tuple Binding Expr)

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

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

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

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) -> pure $ List $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List ls1) (List ls2)) -> pure $ 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)) _                  ) -> pure $ Atom $ Bool false
    (Tuple _                   (Atom (Bool false))) -> pure $ Atom $ Bool false
    (Tuple (Atom (Bool true))  (Atom (Bool true)) ) -> pure $ Atom $ Bool true
    (Tuple _                   _                  ) -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom (Bool true))  _                   ) -> pure $ Atom $ Bool true
    (Tuple _                   (Atom (Bool true))  ) -> pure $ Atom $ Bool true
    (Tuple (Atom (Bool false))  (Atom (Bool false))) -> pure $ Atom $ Bool false
    (Tuple _                   _                   ) -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ 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)) = pure $ 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))  = pure $ Atom $ Bool $ fi i j
    ord _  _  fs _  (Atom (Char s1)) (Atom (Char s2)) = pure $ Atom $ Bool $ fs s1 s2
    ord _  _  _  fb (Atom (Bool b1)) (Atom (Bool b2)) = pure $ 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)) = pure $ 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)) = pure $ 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)) = pure $ 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  -> pure 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)

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

-- removes every entry in StrMap that is inside the binding
removeOverlapping :: Binding -> 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 -> pure subExpr
      Nothing      -> pure 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
      pure $ ListComp expr' quals'
    (LetExpr binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr binds' expr'
    e                     -> pure e

avoidCapture :: StrMap Expr -> (List Binding) -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ Map.values subs) (boundNames' binds) of
  Nil       -> pure 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


Allow oversupplying of functions with arguments

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

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length, concat, concatMap, nub, (\\), intersect, drop)
import Data.StrMap   (StrMap(), empty, lookup, insert, delete, values)
import Data.Tuple    (Tuple(Tuple), fst, snd)
import Data.Maybe
import Data.Foldable (foldl, foldr, foldMap, any)
import Data.Traversable (zipWithA, traverse)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import qualified Control.Plus as P
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

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

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

import Control.Monad.Trans

import AST

type Matching = Tuple Atom Expr

type Evaluator = ErrorT String Identity

runEvalM :: forall a. Evaluator a -> Either String a
runEvalM = runIdentity <<< runErrorT

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

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

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
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ "Cannot match " ++ show (Thrd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

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

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

type Env = StrMap [Tuple [Binding] Expr]

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

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

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name []
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> return $ App f [App g [e]]
  (App (Lambda binds body) args)     -> matchls' binds args >>= flip replace' body >>= wrapLambda binds args
  (App (SectL e1 op) [e2])           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) [e1])           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Prefix op) [e1, e2])         -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _ -> throwError $ "Cannot evaluate " ++ show expr

wrapLambda :: [Binding] -> [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)

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

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

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

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

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

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

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

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

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

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (Num i)) = return $ Atom $ Num (-i)
unary op e = throwError $ "Cannot apply unary operator " ++ show op ++ " to " ++ show e

apply :: Env -> String -> [Expr] -> Evaluator Expr
apply env name args = case lookup name env of
  Nothing    -> throwError $ "Unknown function: " ++ name
  Just cases -> case runEvalM $ foldl (<|>) P.empty (app <$> cases) of
    Right expr -> return expr
    Left msg   -> throwError $ "No matching funnction found for " ++ name ++ "(last reason: " ++ msg ++ ")"
  where
  app :: Tuple [Binding] Expr -> Evaluator Expr
  app (Tuple binds body) | length binds <= length args = matchls' binds args >>= flip replace' body >>= wrapLambda binds args
                         | otherwise                   = throwError $ "Wrong number of arguments!"

matchls' :: [Binding] -> [Expr] -> Evaluator (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Unit
match' (Lit (Name name)) e                             = modify (insert name e)
match' (Lit ba)          (Atom ea)          | ba == ea = return unit
match' (ConsLit b bs)    (Binary Cons e es)            = match' b e *> match' bs es
match' (ConsLit b bs)    (List (e:es))                 = match' (ConsLit b bs) (Binary Cons e (List es))
match' (ListLit bs)      (List es)          | length bs == length es = void $ zipWithA match' bs es
match' (ListLit bs)      (Binary Cons e (List es))     = match' (ListLit bs) (List (e:es))
match' (NTupleLit bs)    (NTuple es)        | length bs == length es = void $ zipWithA match' bs es
match' b                 e                             = throwError $ "Cannot match " ++ show b ++ " with " ++ show e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case 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
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> [Binding] -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ values subs) (boundNames' binds) of
  []       -> return unit
  captures -> throwError $ "Some variables have been captured: " ++ show captures

freeVariables :: Expr -> [String]
freeVariables = nub <<< foldExpr
  (\a -> case a of
    Name name -> [name]
    _         -> [])
  concat
  concat
  (\_ f1 f2 -> f1 ++ f2)
  (\_ f -> f)
  (\f _ -> f)
  (\_ f -> f)
  (\_ -> [])
  (\f1 f2 f3 -> f1 ++ f2 ++ f3)
  (\bs f -> nub f \\ boundNames' bs)
  (\f fs -> f ++ concat fs)

boundNames' :: [Binding] -> [String]
boundNames' = concatMap boundNames

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

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

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex, length, concat, concatMap, nub, (\\), intersect, drop)
import Data.StrMap   (StrMap(), empty, lookup, insert, delete, values)
import Data.Tuple    (Tuple(Tuple), fst, snd)
import Data.Maybe
import Data.Foldable (foldl, foldr, foldMap, any)
import Data.Traversable (zipWithA, traverse)
import Data.Identity
import Data.Either

import Math (pow)

import Control.Apply ((*>))
import Control.Alt ((<|>))
import qualified Control.Plus as P
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

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

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

import Control.Monad.Trans

import AST

type Matching = Tuple Atom Expr

type Evaluator = ErrorT String Identity

runEvalM :: forall a. Evaluator a -> Either String a
runEvalM = runIdentity <<< runErrorT

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

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

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
    Lambda bs body  -> Lambda bs <$> go p body
    App e es        -> App       <$> go p e <*> pure es
    _               -> throwError $ "Cannot match " ++ show (Fst p) ++ " with " ++ show e
  go (Snd p) e = case e of
    Binary op e1 e2 -> Binary op e1 <$> go p e2
    SectR op e      -> SectR op     <$> go p e
    IfExpr ce te ee -> IfExpr <$> pure ce <*> go p te <*> pure ee
    _               -> throwError $ "Cannot match " ++ show (Snd p) ++ " with " ++ show e
  go (Thrd p) e = case e of
    IfExpr ce te ee -> IfExpr <$> pure ce <*> pure te <*> go p ee
    _               -> throwError $ "Cannot match " ++ show (Thrd p) ++ " with " ++ show e
  go (Nth n p) e = case e of
    List es  -> List  <$> mapIndex n (go p) es
    NTuple es -> NTuple <$> mapIndex n (go p) es
    App e es -> App e <$> mapIndex n (go p) es
    _        -> throwError $ "Cannot match " ++ show (Nth n p) ++ " with " ++ show e

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

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

type Env = StrMap [Tuple [Binding] Expr]

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

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

eval1 :: Env -> Expr -> Evaluator Expr
eval1 env expr = case expr of
  (Binary op e1 e2)                  -> binary op e1 e2
  (Unary op e)                       -> unary op e
  (Atom (Name name))                 -> apply env name []
  (IfExpr (Atom (Bool true)) te _)   -> return te
  (IfExpr (Atom (Bool false)) _ ee)  -> return ee
--  (List (e:es))                      -> return $ Binary Cons e (List es)
  (App (Binary Composition f g) [e]) -> return $ App f [App g [e]]
  (App (Lambda binds body) args)     -> matchls' binds args >>= flip replace' body >>= wrapLambda binds args
  (App (SectL e1 op) [e2])           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (SectR op e2) [e1])           -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Prefix op) [e1, e2])         -> binary op e1 e2 <|> (return $ Binary op e1 e2)
  (App (Atom (Name name)) args)      -> apply env name args
  (App (App func es) es')            -> return $ App func (es ++ es')
  _ -> throwError $ "Cannot evaluate " ++ show expr

wrapLambda :: [Binding] -> [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)

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

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

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

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

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

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

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

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

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

unary :: Op -> Expr -> Evaluator Expr
unary Sub (Atom (Num i)) = return $ Atom $ Num (-i)
unary op e = throwError $ "Cannot apply unary operator " ++ show op ++ " to " ++ show e

apply :: Env -> String -> [Expr] -> Evaluator Expr
apply env name args = case lookup name env of
  Nothing    -> throwError $ "Unknown function: " ++ name
  Just cases -> case runEvalM $ foldl (<|>) P.empty (app <$> cases) of
    Right expr -> return expr
    Left msg   -> throwError $ "No matching funnction found for " ++ name ++ "(last reason: " ++ msg ++ ")"
  where
  app :: Tuple [Binding] Expr -> Evaluator Expr
  app (Tuple binds body) | length binds == length args = matchls' binds args >>= flip replace' body
                         | otherwise                   = throwError $ "Wrong number of arguments!"

matchls' :: [Binding] -> [Expr] -> Evaluator (StrMap Expr)
matchls' bs es = execStateT (zipWithA match' bs es) empty

match' :: Binding -> Expr -> StateT (StrMap Expr) Evaluator Unit
match' (Lit (Name name)) e                             = modify (insert name e)
match' (Lit ba)          (Atom ea)          | ba == ea = return unit
match' (ConsLit b bs)    (Binary Cons e es)            = match' b e *> match' bs es
match' (ConsLit b bs)    (List (e:es))                 = match' (ConsLit b bs) (Binary Cons e (List es))
match' (ListLit bs)      (List es)          | length bs == length es = void $ zipWithA match' bs es
match' (ListLit bs)      (Binary Cons e (List es))     = match' (ListLit bs) (List (e:es))
match' (NTupleLit bs)    (NTuple es)        | length bs == length es = void $ zipWithA match' bs es
match' b                 e                             = throwError $ "Cannot match " ++ show b ++ " with " ++ show e

replace' :: StrMap Expr -> Expr -> Evaluator Expr
replace' subs = go
  where
  go expr = case expr of
    a@(Atom (Name name)) -> case 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
    (Lambda binds body)  -> (avoidCapture subs binds) *> (Lambda <$> pure binds <*> replace' (foldr delete subs (boundNames' binds)) body)
    (App func exprs)     -> App <$> go func <*> traverse go exprs
    e                    -> return e

avoidCapture :: StrMap Expr -> [Binding] -> Evaluator Unit
avoidCapture subs binds = case intersect (concatMap freeVariables $ values subs) (boundNames' binds) of
  []       -> return unit
  captures -> throwError $ "Some variables have been captured: " ++ show captures

freeVariables :: Expr -> [String]
freeVariables = nub <<< foldExpr
  (\a -> case a of
    Name name -> [name]
    _         -> [])
  concat
  concat
  (\_ f1 f2 -> f1 ++ f2)
  (\_ f -> f)
  (\f _ -> f)
  (\_ f -> f)
  (\_ -> [])
  (\f1 f2 f3 -> f1 ++ f2 ++ f3)
  (\bs f -> nub f \\ boundNames' bs)
  (\f fs -> f ++ concat fs)

boundNames' :: [Binding] -> [String]
boundNames' = concatMap boundNames

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