module Colorless.Server.Expr
  ( Expr(..)
  , EvalConfig(..)
  --
  , Ref(..)
  , UnVal(..)
  , UnEnumeral(..)
  , UnWrap(..)
  , UnStruct(..)
  , If(..)
  , Get(..)
  , Define(..)
  , Lambda(..)
  , Fn(..)
  , List(..)
  , Do(..)
  , FnCall(..)
  , ApiUnCall(..)
  , HollowUnCall(..)
  , WrapUnCall(..)
  , StructUnCall(..)
  , EnumerationUnCall(..)
  , Val(..)
  , ApiVal(..)
  , Wrap(..)
  , Struct(..)
  , Enumeral(..)
  , ApiCall(..)
  --
  , jsonToExpr
  , apiCallName
  , fromAst
  --
  , ApiParser(..)
  , parseApiCall
  --
  , eval
  , forceVal
  , runEval
  , emptyEnv
  ) where

import qualified Data.Map as Map
import Control.Monad (when, join)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks, lift)
import Data.Map (Map)
import Data.Int
import Data.Word
import Data.Aeson (parseJSON, Value)
import Data.Aeson.Types (parseMaybe)
import Data.IORef (IORef, readIORef, newIORef, writeIORef)
import Data.Scientific (toBoundedInteger, Scientific)
import Data.Text (Text)

import qualified Colorless.Ast as Ast
import Colorless.Types
import Colorless.Ast (Ast(..))
import Colorless.Val
import Colorless.Prim
import Colorless.RuntimeThrower

data EvalConfig m = EvalConfig
  { options :: Options
  , apiCall :: ApiCall -> m Val
  }

jsonToExpr :: (Monad m) => Value -> Maybe (Expr m)
jsonToExpr = fmap fromAst . parseMaybe parseJSON

newtype Eval m a = Eval (ReaderT (EvalConfig m) m a)
  deriving (Functor, Applicative, Monad, MonadReader (EvalConfig m), MonadIO)

instance RuntimeThrower m => RuntimeThrower (Eval m) where
  runtimeThrow err = Eval (lift $ runtimeThrow err)

getOptions :: Monad m => Eval m Options
getOptions = asks options

type Env m = Map Symbol (IORef (Expr m))

runEval :: MonadIO m => Eval m a -> EvalConfig m -> m a
runEval (Eval r) = runReaderT r

data Expr m
  = Expr'Ref Ref
  | Expr'UnVal (UnVal m)
  | Expr'Val Val
  | Expr'If (If m)
  | Expr'Get (Get m)
  | Expr'Define (Define m)
  | Expr'Lambda (Lambda m)
  | Expr'List (List m)
  | Expr'Tuple (Tuple m)
  | Expr'Fn (Fn m)
  | Expr'FnCall (FnCall m)
  | Expr'Do (Do m)
  | Expr'ApiUnCall (ApiUnCall m)
  deriving (Show, Eq)

data UnVal m
  = UnVal'Const Const
  | UnVal'UnWrap (UnWrap m)
  | UnVal'UnStruct (UnStruct m)
  | UnVal'UnEnumeral (UnEnumeral m)
  deriving (Show, Eq)

data UnWrap m = UnWrap
  { w :: Expr m
  } deriving (Show, Eq)

data UnStruct m = UnStruct
  { m :: Map MemberName (Expr m)
  } deriving (Show, Eq)

data UnEnumeral m = UnEnumeral
  { tag :: EnumeralName
  , m :: Maybe (Map MemberName (Expr m))
  } deriving (Show, Eq)

data Ref = Ref
  { symbol :: Symbol
  } deriving (Show, Eq)

data If m = If
  { cond :: Expr m
  , true :: Expr m
  , false :: Expr m
  } deriving (Show, Eq)

data Get m = Get
  { path :: [Text]
  , expr :: Expr m
  } deriving (Show, Eq)

data Define m = Define
  { var :: Symbol
  , expr :: Expr m
  } deriving (Show, Eq)

data Lambda m = Lambda
  { params :: [(Symbol, Type)]
  , expr :: Expr m
  } deriving (Show, Eq)

newtype Fn m = Fn ([Expr m] -> Eval m (Expr m))

instance Show (Fn m) where
  show _ = "<Fn>"

instance Eq (Fn m) where
  (==) _ _ = False

data List m = List
  { list :: [Expr m]
  } deriving (Show, Eq)

data Tuple m = Tuple
  { tuple :: [Expr m]
  } deriving (Show, Eq)

data Do m = Do
  { exprs :: [Expr m]
  } deriving (Show, Eq)

data FnCall m = FnCall
  { fn :: Expr m
  , args :: [Expr m]
  } deriving (Show, Eq)

data ApiUnCall m
  = ApiUnCall'HollowUnCall HollowUnCall
  | ApiUnCall'WrapUnCall (WrapUnCall m)
  | ApiUnCall'StructUnCall (StructUnCall m)
  | ApiUnCall'EnumerationUnCall (EnumerationUnCall m)
  deriving (Show, Eq)

data HollowUnCall = HollowUnCall
  { n :: TypeName
  } deriving (Show, Eq)

data WrapUnCall m = WrapUnCall
  { n :: TypeName
  , w :: Expr m
  } deriving (Show, Eq)

data StructUnCall m = StructUnCall
  { n :: TypeName
  , m :: Expr m
  } deriving (Show, Eq)

data EnumerationUnCall m = EnumerationUnCall
  { n :: TypeName
  , e :: Expr m
  } deriving (Show, Eq)

data ApiCall
  = ApiCall'Hollow TypeName
  | ApiCall'Struct TypeName Struct
  | ApiCall'Enumeration TypeName Enumeral
  | ApiCall'Wrap TypeName Wrap
  deriving (Show, Eq)

apiCallName :: ApiCall -> TypeName
apiCallName = \case
  ApiCall'Hollow n -> n
  ApiCall'Struct n _ -> n
  ApiCall'Enumeration n _ -> n
  ApiCall'Wrap n _ -> n

--

fromAst :: Monad m => Ast -> Expr m
fromAst = \case
  Ast'Ref Ast.Ref{symbol} -> Expr'Ref $ Ref symbol
  Ast'If Ast.If{cond,true,false} -> Expr'If $ If (fromAst cond) (fromAst true) (fromAst false)
  Ast'Get Ast.Get{path,val} -> Expr'Get $ Get path (fromAst val)
  Ast'Define Ast.Define{var,expr} -> Expr'Define $ Define var (fromAst expr)
  Ast'Lambda Ast.Lambda{args,expr} -> Expr'Lambda $ Lambda args (fromAst expr)
  Ast'List Ast.List{list} -> Expr'List $ List $ map fromAst list
  Ast'Tuple Ast.Tuple{tuple} -> Expr'Tuple $ Tuple $ map fromAst tuple
  Ast'Do Ast.Do{vals} -> Expr'Do $ Do $ map fromAst vals
  Ast'FnCall Ast.FnCall{fn,args} -> Expr'FnCall $ FnCall (fromAst fn) (map fromAst args)
  Ast'WrapCall Ast.WrapCall{n,w} -> Expr'ApiUnCall $ ApiUnCall'WrapUnCall $ WrapUnCall n (fromAst w)
  Ast'HollowCall Ast.HollowCall{n} -> Expr'ApiUnCall $ ApiUnCall'HollowUnCall $ HollowUnCall n
  Ast'StructCall Ast.StructCall{n,m} -> Expr'ApiUnCall $ ApiUnCall'StructUnCall $ StructUnCall n (fromAst m)
  Ast'EnumerationCall Ast.EnumerationCall{n,e} -> Expr'ApiUnCall $ ApiUnCall'EnumerationUnCall $ EnumerationUnCall n (fromAst e)
  Ast'Enumeral Ast.Enumeral{tag,m} -> Expr'UnVal $ UnVal'UnEnumeral $ UnEnumeral tag (fmap fromAst <$> m)
  Ast'Struct Ast.Struct{m} -> Expr'UnVal $ UnVal'UnStruct $ UnStruct (fromAst <$> m)
  Ast'Wrap Ast.Wrap{w} -> Expr'UnVal $ UnVal'UnWrap $ UnWrap (fromAst w)
  Ast'Const c -> Expr'UnVal $ UnVal'Const c

--

addEnvToEnv :: (RuntimeThrower m, Ord k, MonadIO m) => Maybe Int -> Map k a -> IORef (Map k a) -> m (IORef (Map k a))
addEnvToEnv maybeVariableLimit vars envRef = do
  env <- liftIO $ readIORef envRef
  let env' = Map.union vars env
  case maybeVariableLimit of
    Nothing -> return ()
    Just limit -> when (Map.size env' > limit) $ runtimeThrow RuntimeError'VariableLimit
  liftIO $ newIORef env'

addVarToEnv :: (Ord k, MonadIO m, RuntimeThrower m) => Maybe Int -> IORef (Map k a) -> k -> a -> Map k a -> m ()
addVarToEnv maybeVariableLimit envRef var ref env = do
  let env' = Map.insert var ref env
  case maybeVariableLimit of
    Nothing -> return ()
    Just limit -> when (Map.size env' > limit) $ runtimeThrow RuntimeError'VariableLimit
  liftIO $ writeIORef envRef env'

varLookup :: (MonadIO m, RuntimeThrower m) => Map Symbol (IORef a) -> Symbol -> m a
varLookup env symbol@(Symbol s) = case Map.lookup symbol env of
  Nothing -> runtimeThrow $ RuntimeError'UnknownVariable s
  Just var -> liftIO $ readIORef $ var

--

eval :: (MonadIO m, RuntimeThrower m) => Expr m -> IORef (Env m) -> Eval m (Expr m)
eval expr envRef = case expr of
  Expr'Ref atom -> evalRef atom envRef
  Expr'If if' -> evalIf if' envRef
  Expr'UnVal unVal -> evalUnVal unVal envRef
  Expr'Val val -> return $ Expr'Val val
  Expr'Get get -> evalGet get envRef
  Expr'Define define -> evalDefine define envRef
  Expr'Lambda lambda -> evalLambda lambda envRef
  Expr'Fn _ -> return expr -- throw error?
  Expr'List list -> evalList list envRef
  Expr'Tuple tuple -> evalTuple tuple envRef
  Expr'FnCall call -> evalFnCall call envRef
  Expr'Do dO -> evalDo dO envRef
  Expr'ApiUnCall apiUnCall -> evalApiUnCall apiUnCall envRef

forceVal :: (RuntimeThrower m) => Expr m -> Eval m Val
forceVal (Expr'Val v) = return v
forceVal (Expr'List (List l)) = Val'List <$> mapM forceVal l
forceVal (Expr'Tuple (Tuple t)) = Val'List <$> mapM forceVal t
forceVal _ = runtimeThrow RuntimeError'IncompatibleType

evalRef :: (MonadIO m, RuntimeThrower m) => Ref -> IORef (Env m) -> Eval m (Expr m)
evalRef Ref{symbol} envRef = do
  env <- liftIO $ readIORef envRef
  varLookup env symbol

evalUnVal :: (MonadIO m, RuntimeThrower m) => UnVal m -> IORef (Env m) -> Eval m (Expr m)
evalUnVal unVal envRef = case unVal of
  UnVal'Const c -> return $ Expr'Val $ Val'Const c

  UnVal'UnStruct UnStruct{m} -> do
    members <- mapM (\(name,expr) -> (name,) <$> (forceVal =<< eval expr envRef)) (Map.toList m)
    return $ Expr'Val $ Val'ApiVal $ ApiVal'Struct $ Struct (Map.fromList members)

  UnVal'UnWrap UnWrap{w} -> do
    w' <- eval w envRef
    case w' of
      Expr'Val (Val'Const c) -> return $ Expr'Val $ Val'Const c
      _ -> runtimeThrow RuntimeError'IncompatibleType

  UnVal'UnEnumeral UnEnumeral{tag,m} -> do
    case m of
      Nothing -> return $ Expr'Val $ Val'ApiVal $ ApiVal'Enumeral $ Enumeral tag Nothing
      Just members' -> do
        members <- mapM (\(name,expr) -> (name,) <$> (forceVal =<< eval expr envRef)) (Map.toList members')
        return $ Expr'Val $ Val'ApiVal $ ApiVal'Enumeral $ Enumeral tag (Just $ Map.fromList members)

evalIf :: (MonadIO m, RuntimeThrower m) => If m -> IORef (Env m) -> Eval m (Expr m)
evalIf If{cond, true, false} envRef = do
  envRef' <- liftIO $ newIORef =<< readIORef envRef
  v <- eval cond envRef'
  case v of
    Expr'Val (Val'Const (Const'Bool cond')) -> do
      envRef'' <- liftIO $ newIORef =<< readIORef envRef
      eval (if cond' then true else false) envRef''
    _ -> runtimeThrow RuntimeError'IncompatibleType

evalGet :: (MonadIO m, RuntimeThrower m) => Get m -> IORef (Env m) -> Eval m (Expr m)
evalGet Get{path,expr} envRef = getter path =<< eval expr envRef

getter :: (MonadIO m, RuntimeThrower m) => [Text] -> Expr m -> Eval m (Expr m)
getter [] expr = return expr
getter path expr =
  case expr of
    Expr'Val val -> case val of
      Val'ApiVal apiVal -> getterApiVal path apiVal
      _ -> runtimeThrow RuntimeError'IncompatibleType
    _ -> runtimeThrow RuntimeError'IncompatibleType

getterApiVal :: (MonadIO m, RuntimeThrower m) => [Text] -> ApiVal -> Eval m (Expr m)
getterApiVal (mName:path) (ApiVal'Struct Struct{m}) =
  case Map.lookup (MemberName mName) m of
    Nothing -> runtimeThrow RuntimeError'IncompatibleType
    Just member -> getter path (Expr'Val member)
getterApiVal (mName:path) (ApiVal'Enumeral Enumeral{m})
  | mName == "tag" = runtimeThrow RuntimeError'IncompatibleType
  | otherwise = case m >>= Map.lookup (MemberName mName) of
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
      Just member -> getter path (Expr'Val member)
getterApiVal _ _ = runtimeThrow RuntimeError'IncompatibleType

evalDefine :: (MonadIO m, RuntimeThrower m) => Define m -> IORef (Env m) -> Eval m (Expr m)
evalDefine Define{var, expr} envRef = do
  expr' <- eval expr envRef
  env <- liftIO $ readIORef envRef
  ref <- liftIO $ newIORef expr'
  limit <- hardVariableLimit <$> getOptions
  addVarToEnv limit envRef var ref env
  return expr'

evalLambda :: (MonadIO m, RuntimeThrower m) => Lambda m -> IORef (Env m) -> Eval m (Expr m)
evalLambda Lambda{params, expr} envRef = do
  disabled <- hardDisableLambdas <$> getOptions
  if disabled
    then runtimeThrow $ RuntimeError'LambdaNotPermitted
    else
      return . Expr'Fn . Fn $ \vals -> do
        let keys = map fst params
        let args = zip keys vals
        let keysLen = length keys
        let argsLen = length args
        if keysLen /= argsLen
          then runtimeThrow $ if keysLen < argsLen
            then RuntimeError'TooManyArguments
            else RuntimeError'TooFewArguments
          else do
            args' <- liftIO $ mapM newIORef (Map.fromList args)
            limit <- hardVariableLimit <$> getOptions
            envRef' <- addEnvToEnv limit args' envRef
            eval expr envRef'

evalList :: (MonadIO m, RuntimeThrower m) => List m -> IORef (Env m)-> Eval m (Expr m)
evalList List{list} envRef = do
  list' <- mapM (\item -> eval item envRef) list
  return . Expr'List $ List list'

evalTuple :: (MonadIO m, RuntimeThrower m) => Tuple m -> IORef (Env m)-> Eval m (Expr m)
evalTuple Tuple{tuple} envRef = do
  tuple' <- mapM (\item -> eval item envRef) tuple
  return . Expr'Tuple $ Tuple tuple'

evalDo :: (MonadIO m, RuntimeThrower m) => Do m -> IORef (Env m) -> Eval m (Expr m)
evalDo Do{exprs} envRef = case exprs of
  [] -> return $ Expr'Val $ Val'Const $ Const'Null
  _ -> last <$> mapM (\expr -> eval expr envRef) exprs

evalFnCall :: (MonadIO m, RuntimeThrower m) => FnCall m -> IORef (Env m) -> Eval m (Expr m)
evalFnCall FnCall{fn, args} envRef = do
  val <- eval fn envRef
  case val of
    Expr'Fn (Fn fn') -> do
      args' <- mapM (\arg -> eval arg envRef) args
      fn' args'
    Expr'Ref Ref{symbol} -> do
      env <- liftIO $ readIORef envRef
      v <- varLookup env symbol
      case v of
        Expr'Fn (Fn fn') -> do
          args' <- mapM (\arg -> eval arg envRef) args
          fn' args'
        _ -> runtimeThrow $ RuntimeError'IncompatibleType
    _ -> runtimeThrow RuntimeError'IncompatibleType

evalApiUnCall :: (MonadIO m, RuntimeThrower m) => ApiUnCall m -> IORef (Env m) -> Eval m (Expr m)
evalApiUnCall apiUnCall envRef = Expr'Val <$> case apiUnCall of
  ApiUnCall'HollowUnCall c -> evalHollowUnCall c
  ApiUnCall'WrapUnCall c -> evalWrapUnCall c envRef
  ApiUnCall'StructUnCall c -> evalStructUnCall c envRef
  ApiUnCall'EnumerationUnCall c -> evalEnumerationUnCall c envRef

evalHollowUnCall :: (MonadIO m, RuntimeThrower m) => HollowUnCall -> Eval m Val
evalHollowUnCall HollowUnCall{n} =
  Eval . ReaderT $ \cfg ->
    apiCall cfg $ ApiCall'Hollow n

evalWrapUnCall :: (MonadIO m, RuntimeThrower m) => WrapUnCall m -> IORef (Env m) -> Eval m Val
evalWrapUnCall WrapUnCall{n,w} envRef = do
  expr <- eval w envRef
  case expr of
    Expr'Val (Val'Const c) -> Eval . ReaderT $ \cfg ->
      apiCall cfg $ ApiCall'Wrap n (Wrap c)
    _ -> runtimeThrow RuntimeError'IncompatibleType

evalStructUnCall :: (MonadIO m, RuntimeThrower m) => StructUnCall m -> IORef (Env m) -> Eval m Val
evalStructUnCall StructUnCall{n,m} envRef = do
  expr <- eval m envRef
  case expr of
    Expr'Val (Val'ApiVal (ApiVal'Struct m')) -> Eval . ReaderT $ \cfg ->
      apiCall cfg $ ApiCall'Struct n m'
    _ -> runtimeThrow RuntimeError'IncompatibleType

evalEnumerationUnCall :: (MonadIO m, RuntimeThrower m) => EnumerationUnCall m -> IORef (Env m) -> Eval m Val
evalEnumerationUnCall EnumerationUnCall{n,e} envRef = do
  expr <- eval e envRef
  case expr of
    Expr'Val (Val'ApiVal (ApiVal'Enumeral e')) -> Eval . ReaderT $ \cfg ->
      apiCall cfg $ ApiCall'Enumeration n e'
    _ -> runtimeThrow RuntimeError'IncompatibleType

emptyEnv :: RuntimeThrower m => IO (IORef (Env m))
emptyEnv = do
  eq <- newIORef eqExpr
  neq <- newIORef neqExpr
  concat' <- newIORef concatExpr
  add <- newIORef addExpr
  sub <- newIORef subExpr
  mul <- newIORef mulExpr
  div' <- newIORef divExpr
  tuple <- newIORef tupleExpr
  newIORef $ Map.fromList
    [ ("==", eq)
    , ("!=", neq)
    , ("+", add)
    , ("-", sub)
    , ("*", mul)
    , ("/", div')
    , ("concat", concat')
    , ("tuple", tuple)
    ]

numExpr :: RuntimeThrower m
  => (Scientific -> Scientific -> Scientific)
  -> (Int8 -> Int8 -> Int8)
  -> (Int16 -> Int16 -> Int16)
  -> (Int32 -> Int32 -> Int32)
  -> (Int64 -> Int64 -> Int64)
  -> (Word8 -> Word8 -> Word8)
  -> (Word16 -> Word16 -> Word16)
  -> (Word32 -> Word32 -> Word32)
  -> (Word64 -> Word64 -> Word64)
  -> Expr m
numExpr num i8 i16 i32 i64 u8 u16 u32 u64 = Expr'Fn . Fn $ \args ->
  case args of
    (_:[]) -> runtimeThrow RuntimeError'TooFewArguments
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Const (Const'Number y))] -> return $
      Expr'Val $ Val'Const $ Const'Number $ x `num` y

    [Expr'Val (Val'Prim (Prim'I8 x)), Expr'Val (Val'Prim (Prim'I8 y))] -> toExpr $ x `i8` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I8 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i8` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I8 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i8` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'I16 x)), Expr'Val (Val'Prim (Prim'I16 y))] -> toExpr $ x `i16` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I16 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i16` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I16 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i16` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'I32 x)), Expr'Val (Val'Prim (Prim'I32 y))] -> toExpr $ x `i32` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I32 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i32` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I32 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i32` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'I64 x)), Expr'Val (Val'Prim (Prim'I64 y))] -> toExpr $ x `i64` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I64 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i64` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I64 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i64` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U8 x)), Expr'Val (Val'Prim (Prim'U8 y))] -> toExpr $ x `u8` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U8 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u8` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U8 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u8` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U16 x)), Expr'Val (Val'Prim (Prim'U16 y))] -> toExpr $ x `u16` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U16 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u16` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U16 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u16` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U32 x)), Expr'Val (Val'Prim (Prim'U32 y))] -> toExpr $ x `u32` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U32 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u32` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U32 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u32` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U64 x)), Expr'Val (Val'Prim (Prim'U64 y))] -> toExpr $ x `u64` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U64 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u64` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U64 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u64` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    (_:_:[]) -> runtimeThrow RuntimeError'IncompatibleType
    _ -> runtimeThrow RuntimeError'TooManyArguments
    where
      toExpr v = return $ Expr'Val (toVal v)

boolExpr :: RuntimeThrower m
  => (Scientific -> Scientific -> Bool)
  -> (Int8 -> Int8 -> Bool)
  -> (Int16 -> Int16 -> Bool)
  -> (Int32 -> Int32 -> Bool)
  -> (Int64 -> Int64 -> Bool)
  -> (Word8 -> Word8 -> Bool)
  -> (Word16 -> Word16 -> Bool)
  -> (Word32 -> Word32 -> Bool)
  -> (Word64 -> Word64 -> Bool)
  -> (Val -> Val -> Bool)
  -> Expr m
boolExpr num i8 i16 i32 i64 u8 u16 u32 u64 val = Expr'Fn . Fn $ \args ->
  case args of
    (_:[]) -> runtimeThrow RuntimeError'TooManyArguments
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Const (Const'Number y))] -> toExpr $ x `num` y

    [Expr'Val (Val'Prim (Prim'I8 x)), Expr'Val (Val'Prim (Prim'I8 y))] -> toExpr $ x `i8` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I8 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i8` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I8 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i8` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'I16 x)), Expr'Val (Val'Prim (Prim'I16 y))] -> toExpr $ x `i16` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I16 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i16` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I16 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i16` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'I32 x)), Expr'Val (Val'Prim (Prim'I32 y))] -> toExpr $ x `i32` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I32 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i32` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I32 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i32` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'I64 x)), Expr'Val (Val'Prim (Prim'I64 y))] -> toExpr $ x `i64` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'I64 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `i64` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'I64 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `i64` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U8 x)), Expr'Val (Val'Prim (Prim'U8 y))] -> toExpr $ x `u8` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U8 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u8` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U8 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u8` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U16 x)), Expr'Val (Val'Prim (Prim'U16 y))] -> toExpr $ x `u16` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U16 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u16` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U16 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u16` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U32 x)), Expr'Val (Val'Prim (Prim'U32 y))] -> toExpr $ x `u32` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U32 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u32` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U32 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u32` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val (Val'Prim (Prim'U64 x)), Expr'Val (Val'Prim (Prim'U64 y))] -> toExpr $ x `u64` y
    [Expr'Val (Val'Const (Const'Number x)), Expr'Val (Val'Prim (Prim'U64 y))] -> case toBoundedInteger x of
      Just x' -> toExpr $ x' `u64` y
      Nothing -> runtimeThrow RuntimeError'IncompatibleType
    [Expr'Val (Val'Prim (Prim'U64 x)), Expr'Val (Val'Const (Const'Number y))] -> case toBoundedInteger y of
      Just y' -> toExpr $ x `u64` y'
      Nothing -> runtimeThrow RuntimeError'IncompatibleType

    [Expr'Val x, Expr'Val y] -> toExpr $ x `val` y

    (_:_:[]) -> runtimeThrow RuntimeError'IncompatibleType
    _ -> runtimeThrow RuntimeError'TooManyArguments
    where
      toExpr v = return $ Expr'Val (toVal v)

eqExpr :: RuntimeThrower m => Expr m
eqExpr = boolExpr (==) (==) (==) (==) (==) (==) (==) (==) (==) (==)

neqExpr :: RuntimeThrower m => Expr m
neqExpr = boolExpr (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=) (/=)

concatExpr :: RuntimeThrower m => Expr m
concatExpr = Expr'Fn . Fn $ \args ->
  case args of
    (_:[]) -> runtimeThrow RuntimeError'TooFewArguments
    [x, y] -> case (x,y) of
      (Expr'Val (Val'Const (Const'String x')), Expr'Val (Val'Const (Const'String y'))) -> return $
        Expr'Val . Val'Const . Const'String $ x' `mappend` y'
      _ -> runtimeThrow RuntimeError'IncompatibleType
    _ -> runtimeThrow RuntimeError'TooManyArguments

addExpr :: RuntimeThrower m => Expr m
addExpr = numExpr (+) (+) (+) (+) (+) (+) (+) (+) (+)

subExpr :: RuntimeThrower m => Expr m
subExpr = numExpr (-) (-) (-) (-) (-) (-) (-) (-) (-)

mulExpr :: RuntimeThrower m => Expr m
mulExpr = numExpr (*) (*) (*) (*) (*) (*) (*) (*) (*)

divExpr :: RuntimeThrower m => Expr m
divExpr = numExpr (/) div div div div div div div div

tupleExpr :: RuntimeThrower m => Expr m
tupleExpr = Expr'Fn . Fn $ \args ->
  case args of
    (_:[]) -> runtimeThrow RuntimeError'TooFewArguments
    xs -> return $ Expr'Tuple $ Tuple xs

--

data ApiParser api = ApiParser
  { hollow :: Map TypeName api
  , struct :: Map TypeName (Val -> Maybe api)
  , enumeration :: Map TypeName (Val -> Maybe api)
  , wrap :: Map TypeName (Val -> Maybe api)
  }

parseApiCall :: ApiParser api -> ApiCall -> Maybe api
parseApiCall ApiParser{hollow, struct, enumeration, wrap} = \case
  ApiCall'Hollow n -> Map.lookup n hollow
  ApiCall'Struct n s -> join $ ($ Val'ApiVal (ApiVal'Struct s)) <$> Map.lookup n struct
  ApiCall'Enumeration n e -> join $ ($ Val'ApiVal (ApiVal'Enumeral e)) <$> Map.lookup n enumeration
  ApiCall'Wrap n (Wrap w) -> join $ ($ Val'Const w) <$> Map.lookup n wrap