Makes clauses more accessible from the FFI.

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

instance arrayToDBObject :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = toForeign <<< map toDBObject

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query datastore t          ->
		    Ref (Collection t)         ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query datastore t           ->
		    Ref (Collection t)          ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query datastore t          ->
		      Ref (Collection t)         ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query datastore t          ->
		       Ref (Collection t)         ->
		       Eff (db :: DATABASE, ref :: REF | e) b

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

instance arrayToDBObject :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = toForeign <<< map toDBObject

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy SortOrder
	    | Custom String -- ^ The name of the custom clause.
	    | Negate Clause

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          = "SortBy (" <> show s <> ")"
	show (Custom c)          = "Custom (" <> show c <> ")"
	show (Negate c)          = "Negate (" <> show c <> ")"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy desc
	, custom             : getClauseType $ Custom mempty
	, negate             : getClauseType $ Negate Equals
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy order
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy order
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom name
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom name
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query datastore t          ->
		    Ref (Collection t)         ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query datastore t           ->
		    Ref (Collection t)          ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query datastore t          ->
		      Ref (Collection t)         ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query datastore t          ->
		       Ref (Collection t)         ->
		       Eff (db :: DATABASE, ref :: REF | e) b


implemented Pattern Matching and Evaluation for Data Constructors

module Evaluator where

import Prelude hiding (apply)
import Data.List (List(Nil, Cons), null, singleton, concatMap, intersect, zipWith, zipWithA, length, (:), drop, concat)
import Data.List.Lazy (replicate)
import Data.StrMap (StrMap, delete)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (toChar)
import Data.String (singleton) as String
import Data.Char (fromCharCode)
import Data.Enum (fromEnum)
import Control.Comonad (extract)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Trans (StateT, get, modify, runStateT, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

-- import JSHelpers (unsafeUndef)

import AST (TypeTree, Tree(..), Atom(..), Binding(..), Definition(Def), Op(..), QualTree(..), TypeQual, MType, DataConstr (..))
import AST as AST

data EvalError =
    IndexError Int Int
  | DivByZero
  | EvalError TypeTree
  | BinaryOpError Op TypeTree TypeTree
  | UnaryOpError Op TypeTree
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | BindingError MatchingError
  | CannotEvaluate TypeTree
  | NoError
  | MoreErrors EvalError EvalError

instance semigroupEvalError :: Semigroup EvalError where
  append e1 e2 = MoreErrors e1 e2

instance monoidEvalError :: Monoid EvalError where
  mempty = NoError

instance showEvalError :: Show EvalError where
  show (IndexError i l)           = "IndexError " <> show i <> " " <> show l
  show DivByZero                  = "DivByZero"
  show (EvalError e)              = "EvalError " <> show e
  show (BinaryOpError o e1 e2)    = "BinaryOpError " <> show o <> " (" <> show e1 <> ") (" <> show e2 <> ")"
  show (UnaryOpError o e)         = "UnaryOpError " <> show o <> " " <> show e
  show (NameCaptureError ns)      = "NameCaptureError " <> show ns
  show (UnknownFunction n)        = "UnknownFunction " <> show n
  show (NoMatchingFunction n mes) = "NoMatchingFunction " <> show n <> " " <> show mes
  show (BindingError me)          = "BindingError " <> show me
  show (CannotEvaluate e)         = "CannotEvaluate " <> show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " <> show e1 <> " " <> show e2 <> ")"

data MatchingError =
    MatchingError (Binding MType) TypeTree
  | StrictnessError (Binding MType) TypeTree
  | TooFewArguments (List (Binding MType)) (List TypeTree)

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

type Evaluator = ExceptT EvalError Identity

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

type Matcher = ExceptT MatchingError Identity

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

type Env = StrMap (List (Tuple (List (Binding MType)) TypeTree))

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

envToDefs :: Env -> (List Definition)
envToDefs env = concat $ map tupleToDef $ Map.toList env
  where
    tupleToDef (Tuple name defs) = map
                                    (\(Tuple bin expr) -> Def name bin expr)
                                    defs

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

-- | Evaluates an expression by one step in a given environment.
eval1 :: Env -> TypeTree -> Evaluator TypeTree
eval1 env expr = case expr of
  (Binary _ op e1 e2)                  -> binary env op e1 e2
  (Unary _ op e)                       -> unary env op e
  (Atom _ (Name name))                 -> apply env name Nil
  (IfExpr _ (Atom _ (Bool true)) te _)   -> pure te
  (IfExpr _ (Atom _ (Bool false)) _ ee)  -> pure ee
  (ArithmSeq _ start step end)         -> evalArithmSeq start step end
  -- (List _ (Cons e es))                      -> pure $ Binary Nothing Colon e (List Nothing es)
  (App _ (Binary _ (Tuple Composition _) f g) (Cons e Nil)) -> pure $ App Nothing f (singleton $ App Nothing g (Cons e Nil))
  (App _ (Lambda _ binds body) args)     -> tryAll env (singleton $ Tuple binds body) args "lambda" Nil
  (App _ (SectL _ e1 op) (Cons e2 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (SectR _ op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (PrefixOp _ op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (Atom _ (Name name)) args)      -> apply env name args
  (App _ (App _ func es) es')            -> pure $ App Nothing func (es <> es')
  (App _ (Atom _ (Constr _)) _)      -> pure expr
  (ListComp _ e qs)                    -> evalListComp env e qs
  (LetExpr _ binds exp)                -> evalLetTypeTree binds exp
  (Atom _ (Constr x))                -> pure $ Atom Nothing (Constr x)
  _                                  -> throwError $ CannotEvaluate expr

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

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

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

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

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

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

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

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

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

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

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

data Quat a = Quat a a a a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    evalArithmSeq' :: Evaluator TypeTree
    evalArithmSeq' = case (exprFromStepTo start step end) of
      Quat Nothing _ _ _          -> pure $ List Nothing Nil
      Quat (Just a) Nothing _ _   -> pure $ AST.binary Colon a (List Nothing Nil)
      Quat (Just a) (Just na) b c -> pure $ AST.binary Colon a (ArithmSeq Nothing na b c)

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

evalListComp :: Env -> TypeTree -> List TypeQual -> Evaluator TypeTree
evalListComp _   expr Nil         = pure $ List Nothing $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard _ (Atom _ (Bool false)) -> pure $ List Nothing Nil
  Guard _ (Atom _ (Bool true))  -> if null qs then pure (List Nothing (singleton expr)) else pure (ListComp Nothing expr qs)
  Gen _ _ (List _ Nil)          -> pure $ List Nothing Nil
  -- Gen _ b (List (Cons e Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (List _ (Cons e es))  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing b (List Nothing es)) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ Binary Nothing (Tuple Colon Nothing) x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  -- Gen _ b (Binary Colon e (List Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (Binary Nothing (Tuple Colon _) e es)  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing b es) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ AST.binary Colon x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  Gen _ b e -> pure $ ListComp Nothing expr (Cons (Gen Nothing b (evalToBinding env e (ConsLit Nothing b (Lit Nothing (Name "_"))))) qs)
  Let _ b e -> case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
    Right r -> do
      Tuple qs' r' <- runStateT (replaceQualifiers qs) r
      expr'        <- replace' r' expr
      case qs' of
          Nil -> pure $ List Nothing $ singleton expr'
          _   -> pure $ ListComp Nothing expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp Nothing expr (Cons q qs))

-- replaces expressions in List-Comprehension-Qualifiers and considers overlapping bindings
replaceQualifiers :: List TypeQual -> StateT (StrMap TypeTree) Evaluator (List TypeQual)
replaceQualifiers = traverse replaceQual
  where
    replaceQual :: TypeQual -> StateT (StrMap TypeTree) Evaluator TypeQual
    replaceQual qual = case qual of
      Gen _ b e -> scope b e >>= \e' -> pure $ Gen Nothing b e'
      Let _ b e -> scope b e >>= \e' -> pure $ Let Nothing b e'
      Guard _ e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard Nothing e'

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

------------------------------------------------------------------------------------------
-- Let TypeTreeessions
------------------------------------------------------------------------------------------

type Bindings = List (Tuple (Binding MType) TypeTree)

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

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

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

binary :: Env -> (Tuple Op MType) -> TypeTree -> TypeTree -> Evaluator TypeTree
binary env (Tuple operator mtype) = case operator of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List _ ls) -> pure $ List Nothing $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List _ ls1) (List _ ls2)) -> pure $ List Nothing $ ls1 <> ls2
    _                                 -> throwError $ BinaryOpError Append es1 es2
  Equ    -> ord Equ (==) (==) (==)
  Neq    -> ord Neq (/=) (/=) (/=)
  Leq    -> ord Leq (<=) (<=) (<=)
  Lt     -> ord Lt  (<)  (<)  (<)
  Geq    -> ord Geq (>=) (>=) (>=)
  Gt     -> ord Gt  (>)  (>)  (>)
  And    -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool false)) _                  )   -> pure $ Atom Nothing $ Bool false
    (Tuple _                     (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple (Atom _ (Bool true))  (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple _                   _                     )  -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool true))  _                   )  -> pure $ Atom Nothing $ Bool true
    (Tuple _                     (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple (Atom _ (Bool false)) (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple _                     _                   )  -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ App Nothing f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  InfixFunc name -> \e1 e2 -> apply env name (e1 : e2 : Nil)
  InfixConstr name -> \e1 e2 -> pure $ Binary Nothing (Tuple operator mtype) e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> TypeTree -> TypeTree -> Evaluator TypeTree
    aint _   f (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ AInt $ f i j
    aint op  _ e1                e2                = throwError $ BinaryOpError op e1 e2

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

unary :: Env -> Tuple Op MType -> TypeTree -> Evaluator TypeTree
unary env (Tuple Sub _) (Atom _ (AInt i)) = pure $ Atom Nothing $ AInt (-i)
unary env (Tuple op _) e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List TypeTree) -> Evaluator TypeTree
apply env "div" (Cons e1 (Cons e2 _)) = division e1 e2
apply env "mod" (Cons e1 (Cons e2 _)) = modulo e1 e2
apply env name args = case Map.lookup name env of
  Nothing    -> throwError $ UnknownFunction name
  Just cases -> tryAll env cases args name Nil

-- built-in div
division :: TypeTree -> TypeTree -> Evaluator TypeTree
division (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
division (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ AInt $ div i j
division e1 e2 = throwError $ BinaryOpError (InfixFunc "div") e1 e2

-- built-in mod
modulo :: TypeTree -> TypeTree -> Evaluator TypeTree
modulo (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
modulo (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List (Binding MType)) TypeTree)) -> (List TypeTree) -> String -> (List MatchingError) -> Evaluator TypeTree
tryAll _   Nil                        _    name errs = throwError $ NoMatchingFunction name errs
tryAll env (Cons (Tuple binds body) cases) args name errs | (length args) < (length binds) = tryAll env cases args name (errs <> (singleton $ TooFewArguments binds args))
tryAll env (Cons (Tuple binds body) cases) args name errs = case runMatcherM $ matchls' env binds args of
  Right replMap                 -> replace' replMap body >>= wrapLambda binds args
  Left se@(StrictnessError _ _) -> throwError $ NoMatchingFunction name (errs <> singleton se)
  Left err                      -> tryAll env cases args name (errs <> singleton err)

whnf :: TypeTree -> Boolean
whnf (Atom _ (Name _)) = false
whnf (Atom _ _)        = true
whnf (List _ _)        = true
whnf (NTuple _ _)      = true
whnf (Binary _ (Tuple (InfixConstr _) _) _ _) = true
whnf (App _ (Atom _ (Constr _)) _) = true
whnf _                 = false

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

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

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

match' (ConsLit _ b bs)    (Binary _ (Tuple Colon _) e es) = match' b e *> match' bs es
match' (ConsLit _ b bs)    (List _ (Cons e es))  = match' (ConsLit Nothing b bs) (AST.binary Colon e (List Nothing es))
match' (ConsLit _ b bs)    (List _ Nil)          = throwError $ MatchingError (ConsLit Nothing b bs) (List Nothing Nil)
match' (ConsLit _ b bs)    e                     = throwError $ checkStrictness (ConsLit Nothing b bs) e

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

match' (NTupleLit _ bs)    (NTuple _ es) = case length bs == length es of
                                           true  -> void $ zipWithA match' bs es
                                           false -> throwError $ MatchingError (NTupleLit Nothing bs) (NTuple Nothing es)
match' (NTupleLit _ bs)    e             = throwError $ checkStrictness (NTupleLit Nothing bs) e
-- TODO
match' b@(ConstrLit _ (PrefixDataConstr n a ps)) e@(App _ (Atom _ (Constr n')) ps')
  = case  n == n' && length ps == length ps' of
         true -> void $ zipWithA match' ps ps'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(Binary _ (Tuple (InfixConstr n') _) l' r')
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(App _ (PrefixOp _ (Tuple (InfixConstr n') _)) (Cons l' (Cons r' Nil)))
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e
match' b@(ConstrLit _ _) e = throwError $ checkStrictness b e

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

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

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

replace' :: StrMap TypeTree -> TypeTree -> Evaluator TypeTree
replace' subs = go
  where
  go tt = case tt of
    a@(Atom _ (Name name)) -> case Map.lookup name subs of
      Just subTypeTree -> pure subTypeTree
      Nothing      -> pure a
    (List _ exprs)         -> List Nothing <$> (traverse go exprs)
    (NTuple _ exprs)       -> NTuple Nothing <$> (traverse go exprs)
    (Binary _ op e1 e2)    -> Binary Nothing <$> pure op <*> go e1 <*> go e2
    (Unary _ op e)         -> Unary Nothing <$> pure op <*> go e
    (SectL _ e op)         -> SectL Nothing <$> go e <*> pure op
    (SectR _ op e)         -> SectR Nothing <$> pure op <*> go e
    (IfExpr _ ce te ee)    -> IfExpr Nothing <$> go ce <*> go te <*> go ee
    (ArithmSeq _ ce te ee) -> ArithmSeq Nothing <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda _ binds body)  -> (avoidCapture subs binds) *> (Lambda Nothing <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App _ func exprs)     -> App Nothing <$> go func <*> traverse go exprs
    (ListComp _ expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      pure $ ListComp Nothing expr' quals'
    (LetExpr _ binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr Nothing binds' expr'
    e                     -> pure e

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

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

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

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

module Evaluator where

import Prelude hiding (apply)
import Data.List (List(Nil, Cons), null, singleton, concatMap, intersect, zipWith, zipWithA, length, (:), drop, concat)
import Data.List.Lazy (replicate)
import Data.StrMap (StrMap, delete)
import Data.StrMap as Map
import Data.Tuple (Tuple(Tuple))
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Foldable (foldl, foldr, foldMap, product)
import Data.Traversable (traverse)
import Data.Identity (Identity)
import Data.Either (Either(..), either)
import Data.Monoid (class Monoid)
import Data.String (toChar)
import Data.String (singleton) as String
import Data.Char (fromCharCode)
import Data.Enum (fromEnum)
import Control.Comonad (extract)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State.Trans (StateT, get, modify, runStateT, execStateT)
import Control.Monad.Except.Trans (ExceptT, throwError, runExceptT)

-- import JSHelpers (unsafeUndef)

import AST (TypeTree, Tree(..), Atom(..), Binding(..), Definition(Def), Op(..), QualTree(..), TypeQual, MType, DataConstr (..))
import AST as AST

data EvalError =
    IndexError Int Int
  | DivByZero
  | EvalError TypeTree
  | BinaryOpError Op TypeTree TypeTree
  | UnaryOpError Op TypeTree
  | NameCaptureError (List String)
  | UnknownFunction String
  | NoMatchingFunction String (List MatchingError)
  | BindingError MatchingError
  | CannotEvaluate TypeTree
  | NoError
  | MoreErrors EvalError EvalError

instance semigroupEvalError :: Semigroup EvalError where
  append e1 e2 = MoreErrors e1 e2

instance monoidEvalError :: Monoid EvalError where
  mempty = NoError

instance showEvalError :: Show EvalError where
  show (IndexError i l)           = "IndexError " <> show i <> " " <> show l
  show DivByZero                  = "DivByZero"
  show (EvalError e)              = "EvalError " <> show e
  show (BinaryOpError o e1 e2)    = "BinaryOpError " <> show o <> " (" <> show e1 <> ") (" <> show e2 <> ")"
  show (UnaryOpError o e)         = "UnaryOpError " <> show o <> " " <> show e
  show (NameCaptureError ns)      = "NameCaptureError " <> show ns
  show (UnknownFunction n)        = "UnknownFunction " <> show n
  show (NoMatchingFunction n mes) = "NoMatchingFunction " <> show n <> " " <> show mes
  show (BindingError me)          = "BindingError " <> show me
  show (CannotEvaluate e)         = "CannotEvaluate " <> show e
  show NoError                    = "NoError"
  show (MoreErrors e1 e2)         = "(MoreErrors " <> show e1 <> " " <> show e2 <> ")"

data MatchingError =
    MatchingError (Binding MType) TypeTree
  | StrictnessError (Binding MType) TypeTree
  | TooFewArguments (List (Binding MType)) (List TypeTree)

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

type Evaluator = ExceptT EvalError Identity

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

type Matcher = ExceptT MatchingError Identity

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

type Env = StrMap (List (Tuple (List (Binding MType)) TypeTree))

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

envToDefs :: Env -> (List Definition)
envToDefs env = concat $ map tupleToDef $ Map.toList env
  where
    tupleToDef (Tuple name defs) = map
                                    (\(Tuple bin expr) -> Def name bin expr)
                                    defs

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

eval1 :: Env -> TypeTree -> Evaluator TypeTree
eval1 env expr = case expr of
  (Binary _ op e1 e2)                  -> binary env op e1 e2
  (Unary _ op e)                       -> unary env op e
  (Atom _ (Name name))                 -> apply env name Nil
  (IfExpr _ (Atom _ (Bool true)) te _)   -> pure te
  (IfExpr _ (Atom _ (Bool false)) _ ee)  -> pure ee
  (ArithmSeq _ start step end)         -> evalArithmSeq start step end
  -- (List _ (Cons e es))                      -> pure $ Binary Nothing Colon e (List Nothing es)
  (App _ (Binary _ (Tuple Composition _) f g) (Cons e Nil)) -> pure $ App Nothing f (singleton $ App Nothing g (Cons e Nil))
  (App _ (Lambda _ binds body) args)     -> tryAll env (singleton $ Tuple binds body) args "lambda" Nil
  (App _ (SectL _ e1 op) (Cons e2 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (SectR _ op e2) (Cons e1 Nil))           -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (PrefixOp _ op) (Cons e1 (Cons e2 Nil)))         -> {-binary env op e1 e2 <|>-} (pure $ Binary Nothing op e1 e2)
  (App _ (Atom _ (Name name)) args)      -> apply env name args
  (App _ (App _ func es) es')            -> pure $ App Nothing func (es <> es')
  (ListComp _ e qs)                    -> evalListComp env e qs
  (LetExpr _ binds exp)                -> evalLetTypeTree binds exp
  _                                  -> throwError $ CannotEvaluate expr

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

evalToBinding :: Env -> TypeTree -> Binding MType -> TypeTree
evalToBinding env expr bind = case bind of
  (Lit _ (Name "_|_")) -> recurse env expr bind
  (Lit _ (Name _))     -> expr
  (Lit _ _)            -> case expr of
    (Atom _ _) -> expr
    _          -> recurse env expr bind

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

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

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

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

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

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

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

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

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

data Quat a = Quat a a a a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    evalArithmSeq' :: Evaluator TypeTree
    evalArithmSeq' = case (exprFromStepTo start step end) of
      Quat Nothing _ _ _          -> pure $ List Nothing Nil
      Quat (Just a) Nothing _ _   -> pure $ AST.binary Colon a (List Nothing Nil)
      Quat (Just a) (Just na) b c -> pure $ AST.binary Colon a (ArithmSeq Nothing na b c)

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

evalListComp :: Env -> TypeTree -> List TypeQual -> Evaluator TypeTree
evalListComp _   expr Nil         = pure $ List Nothing $ singleton expr
evalListComp env expr (Cons q qs) = case q of
  Guard _ (Atom _ (Bool false)) -> pure $ List Nothing Nil
  Guard _ (Atom _ (Bool true))  -> if null qs then pure (List Nothing (singleton expr)) else pure (ListComp Nothing expr qs)
  Gen _ _ (List _ Nil)          -> pure $ List Nothing Nil
  -- Gen _ b (List (Cons e Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (List _ (Cons e es))  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing b (List Nothing es)) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ Binary Nothing (Tuple Colon Nothing) x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  -- Gen _ b (Binary Colon e (List Nil)) -> evalListComp env expr (Cons (Let Nothing b e) qs)
  Gen _ b (Binary Nothing (Tuple Colon _) e es)  -> do
    listcomp1 <- evalListComp env expr (Cons (Let Nothing b e) qs)
    listcomp2 <- pure $ ListComp Nothing expr (Cons (Gen Nothing b es) qs)
    case listcomp1 of
      List _ (Cons x Nil) -> pure $ AST.binary Colon x listcomp2
      _ -> pure $ AST.binary Append listcomp1 listcomp2
  Gen _ b e -> pure $ ListComp Nothing expr (Cons (Gen Nothing b (evalToBinding env e (ConsLit Nothing b (Lit Nothing (Name "_"))))) qs)
  Let _ b e -> case runMatcherM $ matchls' Map.empty (singleton b) (singleton e) of
    Right r -> do
      Tuple qs' r' <- runStateT (replaceQualifiers qs) r
      expr'        <- replace' r' expr
      case qs' of
          Nil -> pure $ List Nothing $ singleton expr'
          _   -> pure $ ListComp Nothing expr' qs'
    Left l  -> throwError $ BindingError $ MatchingError b e
  _ -> throwError $ CannotEvaluate (ListComp Nothing expr (Cons q qs))

-- replaces expressions in List-Comprehension-Qualifiers and considers overlapping bindings
replaceQualifiers :: List TypeQual -> StateT (StrMap TypeTree) Evaluator (List TypeQual)
replaceQualifiers = traverse replaceQual
  where
    replaceQual :: TypeQual -> StateT (StrMap TypeTree) Evaluator TypeQual
    replaceQual qual = case qual of
      Gen _ b e -> scope b e >>= \e' -> pure $ Gen Nothing b e'
      Let _ b e -> scope b e >>= \e' -> pure $ Let Nothing b e'
      Guard _ e -> do
        sub <- get
        e'  <- lift $ replace' sub e
        pure $ Guard Nothing e'

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

------------------------------------------------------------------------------------------
-- Let TypeTreeessions
------------------------------------------------------------------------------------------

type Bindings = List (Tuple (Binding MType) TypeTree)

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

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

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

binary :: Env -> (Tuple Op MType) -> TypeTree -> TypeTree -> Evaluator TypeTree
binary env (Tuple operator mtype) = case operator of
  Power  -> aint Power (\i j -> product $ replicate j i)
  Mul    -> aint Mul (*)
  Add    -> aint Add (+)
  Sub    -> aint Sub (-)
  Colon  -> \e es -> case es of
    (List _ ls) -> pure $ List Nothing $ e:ls
    _         -> throwError $ BinaryOpError Colon e es
  Append -> \es1 es2 -> case (Tuple es1 es2) of
    (Tuple (List _ ls1) (List _ ls2)) -> pure $ List Nothing $ ls1 <> ls2
    _                                 -> throwError $ BinaryOpError Append es1 es2
  Equ    -> ord Equ (==) (==) (==)
  Neq    -> ord Neq (/=) (/=) (/=)
  Leq    -> ord Leq (<=) (<=) (<=)
  Lt     -> ord Lt  (<)  (<)  (<)
  Geq    -> ord Geq (>=) (>=) (>=)
  Gt     -> ord Gt  (>)  (>)  (>)
  And    -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool false)) _                  )   -> pure $ Atom Nothing $ Bool false
    (Tuple _                     (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple (Atom _ (Bool true))  (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple _                   _                     )  -> throwError $ BinaryOpError And e1 e2
  Or     -> \e1 e2 -> case (Tuple e1 e2) of
    (Tuple (Atom _ (Bool true))  _                   )  -> pure $ Atom Nothing $ Bool true
    (Tuple _                     (Atom _ (Bool true)))  -> pure $ Atom Nothing $ Bool true
    (Tuple (Atom _ (Bool false)) (Atom _ (Bool false))) -> pure $ Atom Nothing $ Bool false
    (Tuple _                     _                   )  -> throwError $ BinaryOpError And e1 e2
  Dollar -> (\f e -> pure $ App Nothing f (singleton e))
  Composition -> \e1 e2 -> throwError $ BinaryOpError And e1 e2
  InfixFunc name -> \e1 e2 -> apply env name (e1 : e2 : Nil)
  InfixConstr name -> \e1 e2 -> pure $ Binary Nothing (Tuple operator mtype) e1 e2
  where
    aint :: Op -> (Int -> Int -> Int) -> TypeTree -> TypeTree -> Evaluator TypeTree
    aint _   f (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ AInt $ f i j
    aint op  _ e1                e2                = throwError $ BinaryOpError op e1 e2

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

unary :: Env -> Tuple Op MType -> TypeTree -> Evaluator TypeTree
unary env (Tuple Sub _) (Atom _ (AInt i)) = pure $ Atom Nothing $ AInt (-i)
unary env (Tuple op _) e = throwError $ UnaryOpError op e

apply :: Env -> String -> (List TypeTree) -> Evaluator TypeTree
apply env "div" (Cons e1 (Cons e2 _)) = division e1 e2
apply env "mod" (Cons e1 (Cons e2 _)) = modulo e1 e2
apply env name args = case Map.lookup name env of
  Nothing    -> throwError $ UnknownFunction name
  Just cases -> tryAll env cases args name Nil

-- built-in div
division :: TypeTree -> TypeTree -> Evaluator TypeTree
division (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
division (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ AInt $ div i j
division e1 e2 = throwError $ BinaryOpError (InfixFunc "div") e1 e2

-- built-in mod
modulo :: TypeTree -> TypeTree -> Evaluator TypeTree
modulo (Atom _ (AInt i)) (Atom _ (AInt 0)) = throwError DivByZero
modulo (Atom _ (AInt i)) (Atom _ (AInt j)) = pure $ Atom Nothing $ AInt $ mod i j
modulo e1 e2 = throwError $ BinaryOpError (InfixFunc "mod") e1 e2

tryAll :: Env -> (List (Tuple (List (Binding MType)) TypeTree)) -> (List TypeTree) -> String -> (List MatchingError) -> Evaluator TypeTree
tryAll _   Nil                        _    name errs = throwError $ NoMatchingFunction name errs
tryAll env (Cons (Tuple binds body) cases) args name errs | (length args) < (length binds) = tryAll env cases args name (errs <> (singleton $ TooFewArguments binds args))
tryAll env (Cons (Tuple binds body) cases) args name errs = case runMatcherM $ matchls' env binds args of
  Right replMap                 -> replace' replMap body >>= wrapLambda binds args
  Left se@(StrictnessError _ _) -> throwError $ NoMatchingFunction name (errs <> singleton se)
  Left err                      -> tryAll env cases args name (errs <> singleton err)

whnf :: TypeTree -> Boolean
whnf (Atom _ (Name _)) = false
whnf (Atom _ _)        = true
whnf (List _ _)        = true
whnf (NTuple _ _)      = true
whnf _                 = false

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

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

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

match' (ConsLit _ b bs)    (Binary _ (Tuple Colon _) e es) = match' b e *> match' bs es
match' (ConsLit _ b bs)    (List _ (Cons e es))  = match' (ConsLit Nothing b bs) (AST.binary Colon e (List Nothing es))
match' (ConsLit _ b bs)    (List _ Nil)          = throwError $ MatchingError (ConsLit Nothing b bs) (List Nothing Nil)
match' (ConsLit _ b bs)    e                     = throwError $ checkStrictness (ConsLit Nothing b bs) e

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

match' (NTupleLit _ bs)    (NTuple _ es) = case length bs == length es of
                                           true  -> void $ zipWithA match' bs es
                                           false -> throwError $ MatchingError (NTupleLit Nothing bs) (NTuple Nothing es)
match' (NTupleLit _ bs)    e             = throwError $ checkStrictness (NTupleLit Nothing bs) e
-- TODO
match' b@(ConstrLit _ (PrefixDataConstr n a ps)) e@(App _ (Atom _ (Constr n')) ps')
  = case  n == n' && length ps == length ps' of
         true -> void $ zipWithA match' ps ps'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(Binary _ (Tuple (InfixConstr n') _) l' r')
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e

match' b@(ConstrLit _ (InfixDataConstr n _ _ l r)) e@(App _ (PrefixOp _ (Tuple (InfixConstr n') _)) (Cons l' (Cons r' Nil)))
  = case n == n' of
         true -> match' l l' *> match' r r'
         false -> throwError $ MatchingError b e
match' b@(ConstrLit _ _) e = throwError $ checkStrictness b e

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

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

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

replace' :: StrMap TypeTree -> TypeTree -> Evaluator TypeTree
replace' subs = go
  where
  go tt = case tt of
    a@(Atom _ (Name name)) -> case Map.lookup name subs of
      Just subTypeTree -> pure subTypeTree
      Nothing      -> pure a
    (List _ exprs)         -> List Nothing <$> (traverse go exprs)
    (NTuple _ exprs)       -> NTuple Nothing <$> (traverse go exprs)
    (Binary _ op e1 e2)    -> Binary Nothing <$> pure op <*> go e1 <*> go e2
    (Unary _ op e)         -> Unary Nothing <$> pure op <*> go e
    (SectL _ e op)         -> SectL Nothing <$> go e <*> pure op
    (SectR _ op e)         -> SectR Nothing <$> pure op <*> go e
    (IfExpr _ ce te ee)    -> IfExpr Nothing <$> go ce <*> go te <*> go ee
    (ArithmSeq _ ce te ee) -> ArithmSeq Nothing <$> go ce <*> (mapM' go te) <*> (mapM' go ee)
    (Lambda _ binds body)  -> (avoidCapture subs binds) *> (Lambda Nothing <$> pure binds <*> replace' (foldr Map.delete subs (boundNames' binds)) body)
    (App _ func exprs)     -> App Nothing <$> go func <*> traverse go exprs
    (ListComp _ expr quals) -> do
      Tuple quals' subs' <- runStateT (replaceQualifiers quals) subs
      expr'              <- replace' subs' expr
      pure $ ListComp Nothing expr' quals'
    (LetExpr _ binds expr)  -> do
      Tuple binds' subs' <- runStateT (replaceBindings binds) subs
      expr'              <- replace' subs' expr
      pure $ LetExpr Nothing binds' expr'
    e                     -> pure e

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

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

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

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