packages feed

colorless 2.0.0 → 2.1.0

raw patch · 14 files changed

+1321/−1279 lines, 14 files

Files

colorless.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           colorless-version:        2.0.0+version:        2.1.0 synopsis:       Colorless description:    Colorless category:       Web@@ -40,10 +40,10 @@     , vector   exposed-modules:       Colorless.Endpoint-      Colorless.Runtime.Ast-      Colorless.Runtime.Expr-      Colorless.Runtime.Types-      Colorless.Runtime.Val+      Colorless.Server.Ast+      Colorless.Server.Expr+      Colorless.Server.Types+      Colorless.Server.Val       Colorless.Types   default-language: Haskell2010
− library/Colorless/Runtime/Ast.hs 
@@ -1,212 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Colorless.Runtime.Ast-  ( Ast(..)-  , Ref(..)-  , If(..)-  , Get(..)-  , Define(..)-  , Lambda(..)-  , List(..)-  , Begin(..)-  , FnCall(..)-  , Enumeral(..)-  , Struct(..)-  , Wrap(..)-  , StructCall(..)-  , WrapCall(..)-  , EnumerationCall(..)-  , HollowCall(..)-  , Const(..)-  ) where--import qualified Data.HashMap.Lazy as HML-import qualified Data.Vector as V-import Control.Monad (mzero)-import Control.Applicative ((<|>))-import Data.Text (Text)-import Data.Aeson-import Data.Map (Map)-import GHC.Generics (Generic)--import Colorless.Runtime.Types--data Ast-  = Ast'Ref Ref-  | Ast'If If-  | Ast'Get Get-  | Ast'Define Define-  | Ast'Lambda Lambda-  | Ast'List List-  | Ast'Begin Begin-  | Ast'FnCall FnCall-  | Ast'WrapCall WrapCall-  | Ast'StructCall StructCall-  | Ast'EnumerationCall EnumerationCall-  | Ast'HollowCall HollowCall-  | Ast'Enumeral Enumeral-  | Ast'Struct Struct-  | Ast'Wrap Wrap-  | Ast'Const Const-  deriving (Show, Eq)--instance FromJSON Ast where-  parseJSON v-    =   (Ast'Ref <$> parseJSON v)-    <|> (Ast'If <$> parseJSON v)-    <|> (Ast'Get <$> parseJSON v)-    <|> (Ast'Define <$> parseJSON v)-    <|> (Ast'Lambda <$> parseJSON v)-    <|> (Ast'List <$> parseJSON v)-    <|> (Ast'Begin <$> parseJSON v)-    <|> (Ast'FnCall <$> parseJSON v)-    <|> (Ast'EnumerationCall <$> parseJSON v)-    <|> (Ast'WrapCall <$> parseJSON v)-    <|> (Ast'StructCall <$> parseJSON v)-    <|> (Ast'HollowCall <$> parseJSON v)-    <|> (Ast'Enumeral <$> parseJSON v)-    <|> (Ast'Struct <$> parseJSON v)-    <|> (Ast'Wrap <$> parseJSON v)-    <|> (Ast'Const <$> parseJSON v)--data Ref = Ref-  { symbol :: Symbol-  } deriving (Show, Eq)--instance FromJSON Ref where-  parseJSON (Object o) = Ref <$> o .: "@"-  parseJSON _ = mzero--data If = If-  { cond :: Ast-  , true :: Ast-  , false :: Ast-  } deriving (Show, Eq)--instance FromJSON If where-  parseJSON (Array arr) = case V.toList arr of-    ["if", cond, true, false] -> If <$> parseJSON cond <*> parseJSON true <*> parseJSON false-    _ -> mzero-  parseJSON _ = mzero--data Get = Get-  { path :: [Text]-  , val :: Ast-  } deriving (Show, Eq)--instance FromJSON Get where-  parseJSON (Array arr) = case V.toList arr of-    ["get", path, val] -> Get <$> parseJSON path <*> parseJSON val-    _ -> mzero-  parseJSON _ = mzero--data Define = Define-  { var :: Symbol-  , expr :: Ast-  } deriving (Show, Eq)--instance FromJSON Define where-  parseJSON (Array arr) = case V.toList arr of-    ["def", var, expr] -> Define <$> parseJSON var <*> parseJSON expr-    _ -> mzero-  parseJSON _ = mzero--data Lambda = Lambda-  { args :: [(Symbol, Type)]-  , expr :: Ast-  } deriving (Show, Eq)--instance FromJSON Lambda where-  parseJSON (Array arr) = case V.toList arr of-    ["fn", Array params, expr] -> Lambda <$> mapM parseParam (V.toList params) <*> parseJSON expr-    _ -> mzero-    where-      parseParam = \case-        Object o -> case HML.toList o of-          [(key,val)] -> (Symbol key,) <$> parseJSON val-          _ -> mzero-        _ -> mzero-  parseJSON _ = mzero--data List = List-  { list :: [Ast]-  } deriving (Show, Eq)--instance FromJSON List where-  parseJSON (Object o) = List <$> o .: "List"-  parseJSON _ = mzero--data Begin = Begin-  { vals :: [Ast]-  } deriving (Show, Eq)--instance FromJSON Begin where-  parseJSON (Array arr) = case V.toList arr of-    "begin":xs -> Begin <$> mapM parseJSON xs-    _ -> mzero-  parseJSON _ = mzero--data FnCall = FnCall-  { fn :: Ast-  , args :: [Ast]-  } deriving (Show, Eq)--instance FromJSON FnCall where-  parseJSON (Array arr) = case V.toList arr of-    ((String x):xs) -> FnCall <$> pure (Ast'Ref $ Ref $ Symbol x) <*> mapM parseJSON xs-    (x:xs) -> FnCall <$> parseJSON x <*> mapM parseJSON xs-    _ -> mzero-  parseJSON _ = mzero--data EnumerationCall = EnumerationCall-  { n :: TypeName-  , e :: Ast-  } deriving (Show, Eq, Generic)--instance FromJSON EnumerationCall--data WrapCall = WrapCall-  { n :: TypeName-  , w :: Ast-  } deriving (Show, Eq, Generic)--instance FromJSON WrapCall--data StructCall = StructCall-  { n :: TypeName-  , m :: Map MemberName Ast-  } deriving (Show, Eq, Generic)--instance FromJSON StructCall--data HollowCall = HollowCall-  { n :: TypeName-  } deriving (Show, Eq, Generic)--instance FromJSON HollowCall--data Enumeral = Enumeral-  { tag :: EnumeralName-  , m :: Maybe (Map MemberName Ast)-  } deriving (Show, Eq, Generic)--instance FromJSON Enumeral where-  parseJSON (Object o) = do-    tag <- o .: "tag"-    let tagless = HML.delete "tag" o-    if HML.size o == 1-      then pure $ Enumeral tag Nothing-      else Enumeral tag <$> (Just <$> parseJSON (Object tagless))-  parseJSON _ = mzero--data Struct = Struct-  { m :: Map MemberName Ast-  } deriving (Show, Eq, Generic)--instance FromJSON Struct where-  parseJSON v = Struct <$> parseJSON v--data Wrap = Wrap-  { w :: Ast-  } deriving (Show, Eq, Generic)--instance FromJSON Wrap
− library/Colorless/Runtime/Expr.hs 
@@ -1,658 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Colorless.Runtime.Expr-  ( Expr(..)-  , EvalConfig(..)-  ---  , Ref(..)-  , UnVal(..)-  , UnEnumeral(..)-  , UnWrap(..)-  , UnStruct(..)-  , If(..)-  , Get(..)-  , Define(..)-  , Lambda(..)-  , Fn(..)-  , List(..)-  , Begin(..)-  , 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.Runtime.Ast as Ast-import Colorless.Types-import Colorless.Runtime.Types-import Colorless.Runtime.Val-import Colorless.Runtime.Ast (Ast(..))--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'Fn (Fn m)-  | Expr'FnCall (FnCall m)-  | Expr'Begin (Begin 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 Begin m = Begin-  { 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 :: Map MemberName (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'Begin Ast.Begin{vals} -> Expr'Begin $ Begin $ 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'FnCall call -> evalFnCall call envRef-  Expr'Begin begin -> evalBegin begin envRef-  Expr'ApiUnCall apiUnCall -> evalApiUnCall apiUnCall envRef--forceVal :: (RuntimeThrower m) => Expr m -> Eval m Val-forceVal (Expr'Val v) = return v-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'ApiVal $ ApiVal'Wrap $ Wrap 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 ("w":path) (ApiVal'Wrap (Wrap w)) = getter path (Expr'Val (Val'Const w))-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 <- variableLimit <$> 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-  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 <- variableLimit <$> 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'--evalBegin :: (MonadIO m, RuntimeThrower m) => Begin m -> IORef (Env m) -> Eval m (Expr m)-evalBegin Begin{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-  m' <- mapM eval' m-  Eval . ReaderT $ \cfg ->-    apiCall cfg $ ApiCall'Struct n (Struct m')-  where-    eval' expr = do-      expr' <- eval expr envRef-      case expr' of-        Expr'Val v -> return v-        _ -> 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-  newIORef $ Map.fromList-    [ ("==", eq)-    , ("/=", neq)-    , ("+", add)-    , ("-", sub)-    , ("*", mul)-    , ("/", div')-    , ("concat", concat')-    ]--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)-  -> Expr m-boolExpr num i8 i16 i32 i64 u8 u16 u32 u64 = 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--    (_:_:[]) -> runtimeThrow RuntimeError'IncompatibleType-    _ -> runtimeThrow RuntimeError'TooFewArguments-    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------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 w -> join $ ($ Val'ApiVal (ApiVal'Wrap w)) <$> Map.lookup n wrap
− library/Colorless/Runtime/Types.hs 
@@ -1,116 +0,0 @@-module Colorless.Runtime.Types-  ( Symbol(..)-  , Type(..)-  , TypeName(..)-  , MemberName(..)-  , EnumeralName(..)-  , EnumeralType(..)-  , EnumerationType(..)-  , StructType(..)-  , HollowType(..)-  , Prim(..)-  , Const(..)-  ) where--import qualified Data.HashMap.Lazy as HML-import Control.Monad (mzero)-import Data.Aeson (FromJSON(..), FromJSONKey, ToJSONKey, Value(..), (.:), ToJSON(..))-import Data.Text (Text)-import Data.Map (Map)-import Data.Int-import Data.Word-import Data.Scientific-import Data.String (IsString)--newtype Symbol = Symbol Text-  deriving (Show, Eq, Ord, FromJSON, IsString)--data Type = Type-  { n :: TypeName-  , p :: Maybe Type-  } deriving (Show, Eq)--instance FromJSON Type where-  parseJSON = \case-    String s -> pure $ Type (TypeName s) Nothing-    Object o -> do-      n <- o .: "n"-      case HML.lookup "p" o of-        Nothing -> pure $ Type n Nothing-        Just p -> Type n <$> fmap Just (parseJSON p)-    _ -> mzero--newtype TypeName = TypeName Text-  deriving (Show, Eq, Ord, FromJSON, IsString)--newtype EnumeralName = EnumeralName Text-  deriving (Show, Eq, Ord, FromJSON, ToJSON, IsString)--newtype MemberName = MemberName Text-  deriving (Show, Eq, Ord, FromJSON, ToJSON, ToJSONKey, FromJSONKey, IsString)--data EnumeralType = EnumeralType-  { m :: Maybe (Map MemberName Type)-  } deriving (Show, Eq)--data EnumerationType = EnumerationType-  { e :: Map EnumeralName EnumeralType-  , o :: Type-  } deriving (Show, Eq)--data StructType = StructType-  { m :: Map MemberName Type-  , o :: Type-  } deriving (Show, Eq)--data HollowType = HollowType-  { o :: Type-  } deriving (Show, Eq)--data Prim-  = Prim'Bool Bool-  | Prim'I8 Int8-  | Prim'I16 Int16-  | Prim'I32 Int32-  | Prim'I64 Int64-  | Prim'U8 Word8-  | Prim'U16 Word16-  | Prim'U32 Word32-  | Prim'U64 Word64-  | Prim'String Text-  deriving (Show, Eq)--instance ToJSON Prim where-  toJSON = \case-    Prim'Bool b -> toJSON b-    Prim'I8 i -> toJSON i-    Prim'I16 i -> toJSON i-    Prim'I32 i -> toJSON i-    Prim'I64 i -> toJSON i-    Prim'U8 u -> toJSON u-    Prim'U16 u -> toJSON u-    Prim'U32 u -> toJSON u-    Prim'U64 u -> toJSON u-    Prim'String s -> toJSON s--data Const-  = Const'Null-  | Const'Bool Bool-  | Const'String Text-  | Const'Number Scientific-  deriving (Show, Eq)--instance ToJSON Const where-  toJSON = \case-    Const'Null -> Null-    Const'Bool b -> Bool b-    Const'String s -> String s-    Const'Number n -> Number n--instance FromJSON Const where-  parseJSON = \case-    Null -> pure $ Const'Null-    Bool b -> pure $ Const'Bool b-    String s -> pure $ Const'String s-    Number n -> pure $ Const'Number n-    _ -> mzero
− library/Colorless/Runtime/Val.hs 
@@ -1,280 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Colorless.Runtime.Val-  ( Val(..)-  , ApiVal(..)-  , Wrap(..)-  , Struct(..)-  , Enumeral(..)-  ---  , FromVal(..)-  , ToVal(..)-  , getMember-  , fromValFromJson-  , combineObjects-  ) where--import qualified Data.HashMap.Lazy as HML-import qualified Data.Map as Map-import qualified Data.Vector as V-import Control.Monad (mzero)-import Control.Applicative ((<|>))-import Data.Aeson-import Data.Aeson.Types (parseMaybe)-import Data.Map (Map)-import Data.Text (Text)-import Data.Int-import Data.Word-import Data.Scientific-import GHC.Generics (Generic)--import Colorless.Runtime.Types--data Val-  = Val'Const Const-  | Val'Prim Prim-  | Val'ApiVal ApiVal-  | Val'List [Val]-  deriving (Show, Eq)--instance ToJSON Val where-  toJSON = \case-    Val'Const c -> toJSON c-    Val'ApiVal v -> toJSON v-    Val'List l -> toJSON l-    Val'Prim p -> toJSON p--instance FromJSON Val where-  parseJSON = \case-    Null -> return $ Val'Const Const'Null-    Number n -> return $ Val'Const $ Const'Number n-    String s -> return $ Val'Const $ Const'String s-    Bool b -> return $ Val'Const $ Const'Bool b-    Array arr -> Val'List <$> (mapM parseJSON $ V.toList arr)-    v@Object{} -> Val'ApiVal <$> parseJSON v--data ApiVal-  = ApiVal'Wrap Wrap-  | ApiVal'Struct Struct-  | ApiVal'Enumeral Enumeral-  deriving (Show, Eq)--instance ToJSON ApiVal where-  toJSON = \case-    ApiVal'Wrap w -> toJSON w-    ApiVal'Struct s -> toJSON s-    ApiVal'Enumeral e -> toJSON e--instance FromJSON ApiVal where-  parseJSON v =-    (ApiVal'Wrap <$> parseJSON v) <|>-    (ApiVal'Enumeral <$> parseJSON v) <|>-    (ApiVal'Struct <$> parseJSON v)--data Wrap = Wrap-  { w :: Const-  } deriving (Show, Eq, Generic)--instance ToJSON Wrap-instance FromJSON Wrap--data Struct = Struct-  { m :: Map MemberName Val-  } deriving (Show, Eq, Generic)--instance ToJSON Struct where-  toJSON Struct{m} = toJSON m--instance FromJSON Struct where-  parseJSON v = Struct <$> parseJSON v--data Enumeral = Enumeral-  { tag :: EnumeralName-  , m :: Maybe (Map MemberName Val)-  } deriving (Show, Eq, Generic)--instance ToJSON Enumeral where-  toJSON Enumeral{tag,m} = object $ [ "tag" .= tag ] ++ case m of-    Nothing -> []-    Just m' -> concatMap (\(MemberName k,v) -> [ k .= v ]) (Map.toList m')--instance FromJSON Enumeral where-  parseJSON (Object o) = do-    tag <- o .: "tag"-    let tagless = HML.delete "tag" o-    if HML.size o == 1-      then pure $ Enumeral tag Nothing-      else Enumeral tag <$> (Just <$> parseJSON (Object tagless))-  parseJSON _ = mzero------class ToVal a where-  toVal :: a -> Val--instance ToVal () where-  toVal () = Val'Const Const'Null--instance ToVal Bool where-  toVal b = Val'Const $ Const'Bool b--instance ToVal Text where-  toVal s = Val'Const $ Const'String s--intToVal :: Integral a => a -> Val-intToVal n = Val'Const $ Const'Number (fromInteger $ toInteger n)--instance ToVal Int where-  toVal = intToVal--instance ToVal Int8 where-  toVal i = Val'Prim $ Prim'I8 i--instance ToVal Int16 where-  toVal i = Val'Prim $ Prim'I16 i--instance ToVal Int32 where-  toVal i = Val'Prim $ Prim'I32 i--instance ToVal Int64 where-  toVal i = Val'Prim $ Prim'I64 i--instance ToVal Word where-  toVal = intToVal--instance ToVal Word8 where-  toVal u = Val'Prim $ Prim'U8 u--instance ToVal Word16 where-  toVal u = Val'Prim $ Prim'U16 u--instance ToVal Word32 where-  toVal u = Val'Prim $ Prim'U32 u--instance ToVal Word64 where-  toVal u = Val'Prim $ Prim'U64 u--instance ToVal Float where-    toVal f = Val'Const $ Const'Number $ fromFloatDigits f--instance ToVal Double where-    toVal d = Val'Const $ Const'Number $ fromFloatDigits d--instance ToVal a => ToVal (Maybe a) where-  toVal Nothing = Val'Const Const'Null-  toVal (Just v) = toVal v--instance (ToVal a, ToVal b) => ToVal (Either a b) where-  toVal m = Val'ApiVal $ ApiVal'Enumeral $ case m of-    Left l -> Enumeral "Left" (Just $ Map.singleton "left" (toVal l))-    Right r -> Enumeral "Right" (Just $ Map.singleton "right" (toVal r))--instance ToVal a => ToVal [a] where-  toVal list = Val'List $ map toVal list------class FromVal a where-  fromVal :: Val -> Maybe a--instance FromVal () where-  fromVal (Val'Const Const'Null) = Just ()-  fromVal _ = Nothing--instance FromVal Bool where-  fromVal (Val'Const (Const'Bool b)) = Just b-  fromVal _ = Nothing--instance FromVal Text where-  fromVal (Val'Const (Const'String s)) = Just s-  fromVal _ = Nothing--intFromVal :: (Bounded i, Integral i) => Val -> Maybe i-intFromVal (Val'Const (Const'Number n)) = toBoundedInteger n-intFromVal _ = Nothing--instance FromVal Int where-  fromVal = intFromVal--instance FromVal Int8 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'I8 i) -> Just i-    _ -> Nothing--instance FromVal Int16 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'I16 i) -> Just i-    _ -> Nothing--instance FromVal Int32 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'I32 i) -> Just i-    _ -> Nothing--instance FromVal Int64 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'I64 i) -> Just i-    _ -> Nothing--instance FromVal Word where-  fromVal = intFromVal--instance FromVal Word8 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'U8 u) -> Just u-    _ -> Nothing--instance FromVal Word16 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'U16 u) -> Just u-    _ -> Nothing--instance FromVal Word32 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'U32 u) -> Just u-    _ -> Nothing--instance FromVal Word64 where-  fromVal = \case-    Val'Const (Const'Number n) -> toBoundedInteger n-    Val'Prim (Prim'U64 u) -> Just u-    _ -> Nothing--instance FromVal Float where-  fromVal (Val'Const (Const'Number n)) = Just $ toRealFloat n-  fromVal _ = Nothing--instance FromVal Double where-  fromVal (Val'Const (Const'Number n)) = Just $ toRealFloat n-  fromVal _ = Nothing--instance FromVal a => FromVal (Maybe a) where-  fromVal (Val'Const Const'Null) = Just Nothing-  fromVal v = Just <$> fromVal v--instance (FromVal a, FromVal b) => FromVal (Either a b) where-  fromVal (Val'ApiVal (ApiVal'Enumeral (Enumeral tag m))) = case (tag,m) of-    ("Left",Just m') -> Map.lookup "left" m' >>= \l -> Left <$> fromVal l-    ("Right",Just m') -> Map.lookup "right" m' >>= \r -> Right <$> fromVal r-    _ -> Nothing-  fromVal _ = Nothing--instance FromVal a => FromVal [a] where-  fromVal (Val'List list) = mapM fromVal list-  fromVal _ = Nothing--getMember :: FromVal a => Map MemberName Val -> MemberName -> Maybe a-getMember m n = fromVal =<< Map.lookup n m--fromValFromJson :: (FromVal b) => Value -> Maybe b-fromValFromJson x = fromVal =<< parseMaybe parseJSON x--combineObjects :: Value -> Value -> Value-combineObjects (Object x) (Object y) = Object $ HML.union x y-combineObjects _ _ = error "not objects"
+ library/Colorless/Server/Ast.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE DeriveGeneric #-}+module Colorless.Server.Ast+  ( Ast(..)+  , Ref(..)+  , If(..)+  , Get(..)+  , Define(..)+  , Lambda(..)+  , List(..)+  , Tuple(..)+  , Begin(..)+  , FnCall(..)+  , Enumeral(..)+  , Struct(..)+  , Wrap(..)+  , StructCall(..)+  , WrapCall(..)+  , EnumerationCall(..)+  , HollowCall(..)+  , Const(..)+  ) where++import qualified Data.HashMap.Lazy as HML+import qualified Data.Vector as V+import Control.Monad (mzero)+import Control.Applicative ((<|>))+import Data.Text (Text)+import Data.Aeson+import Data.Map (Map)+import GHC.Generics (Generic)++import Colorless.Server.Types++data Ast+  = Ast'Ref Ref+  | Ast'If If+  | Ast'Get Get+  | Ast'Define Define+  | Ast'Lambda Lambda+  | Ast'List List+  | Ast'Tuple Tuple+  | Ast'Begin Begin+  | Ast'FnCall FnCall+  | Ast'WrapCall WrapCall+  | Ast'StructCall StructCall+  | Ast'EnumerationCall EnumerationCall+  | Ast'HollowCall HollowCall+  | Ast'Enumeral Enumeral+  | Ast'Struct Struct+  | Ast'Wrap Wrap+  | Ast'Const Const+  deriving (Show, Eq)++instance FromJSON Ast where+  parseJSON v+    =   (Ast'Ref <$> parseJSON v)+    <|> (Ast'If <$> parseJSON v)+    <|> (Ast'Get <$> parseJSON v)+    <|> (Ast'Define <$> parseJSON v)+    <|> (Ast'Lambda <$> parseJSON v)+    <|> (Ast'List <$> parseJSON v)+    <|> (Ast'Tuple <$> parseJSON v)+    <|> (Ast'Begin <$> parseJSON v)+    <|> (Ast'FnCall <$> parseJSON v)+    <|> (Ast'EnumerationCall <$> parseJSON v)+    <|> (Ast'WrapCall <$> parseJSON v)+    <|> (Ast'StructCall <$> parseJSON v)+    <|> (Ast'HollowCall <$> parseJSON v)+    <|> (Ast'Enumeral <$> parseJSON v)+    <|> (Ast'Struct <$> parseJSON v)+    <|> (Ast'Wrap <$> parseJSON v)+    <|> (Ast'Const <$> parseJSON v)++data Ref = Ref+  { symbol :: Symbol+  } deriving (Show, Eq)++instance FromJSON Ref where+  parseJSON (Object o) = Ref <$> o .: "@"+  parseJSON _ = mzero++data If = If+  { cond :: Ast+  , true :: Ast+  , false :: Ast+  } deriving (Show, Eq)++instance FromJSON If where+  parseJSON (Array arr) = case V.toList arr of+    ["if", cond, true, false] -> If <$> parseJSON cond <*> parseJSON true <*> parseJSON false+    _ -> mzero+  parseJSON _ = mzero++data Get = Get+  { path :: [Text]+  , val :: Ast+  } deriving (Show, Eq)++instance FromJSON Get where+  parseJSON (Array arr) = case V.toList arr of+    ["get", path, val] -> Get <$> parseJSON path <*> parseJSON val+    _ -> mzero+  parseJSON _ = mzero++data Define = Define+  { var :: Symbol+  , expr :: Ast+  } deriving (Show, Eq)++instance FromJSON Define where+  parseJSON (Array arr) = case V.toList arr of+    ["def", var, expr] -> Define <$> parseJSON var <*> parseJSON expr+    _ -> mzero+  parseJSON _ = mzero++data Lambda = Lambda+  { args :: [(Symbol, Type)]+  , expr :: Ast+  } deriving (Show, Eq)++instance FromJSON Lambda where+  parseJSON (Array arr) = case V.toList arr of+    ["fn", Array params, expr] -> Lambda <$> mapM parseParam (V.toList params) <*> parseJSON expr+    _ -> mzero+    where+      parseParam = \case+        Object o -> case HML.toList o of+          [(key,val)] -> (Symbol key,) <$> parseJSON val+          _ -> mzero+        _ -> mzero+  parseJSON _ = mzero++data List = List+  { list :: [Ast]+  } deriving (Show, Eq)++instance FromJSON List where+  parseJSON (Object o) = List <$> o .: "List"+  parseJSON _ = mzero++data Tuple = Tuple+  { tuple :: [Ast]+  } deriving (Show, Eq)++instance FromJSON Tuple where+  parseJSON (Object o) = Tuple <$> o .: "Tuple"+  parseJSON _ = mzero++data Begin = Begin+  { vals :: [Ast]+  } deriving (Show, Eq)++instance FromJSON Begin where+  parseJSON (Array arr) = case V.toList arr of+    "begin":xs -> Begin <$> mapM parseJSON xs+    _ -> mzero+  parseJSON _ = mzero++data FnCall = FnCall+  { fn :: Ast+  , args :: [Ast]+  } deriving (Show, Eq)++instance FromJSON FnCall where+  parseJSON (Array arr) = case V.toList arr of+    ((String x):xs) -> FnCall <$> pure (Ast'Ref $ Ref $ Symbol x) <*> mapM parseJSON xs+    (x:xs) -> FnCall <$> parseJSON x <*> mapM parseJSON xs+    _ -> mzero+  parseJSON _ = mzero++data EnumerationCall = EnumerationCall+  { n :: TypeName+  , e :: Ast+  } deriving (Show, Eq, Generic)++instance FromJSON EnumerationCall++data WrapCall = WrapCall+  { n :: TypeName+  , w :: Ast+  } deriving (Show, Eq, Generic)++instance FromJSON WrapCall++data StructCall = StructCall+  { n :: TypeName+  , m :: Map MemberName Ast+  } deriving (Show, Eq, Generic)++instance FromJSON StructCall++data HollowCall = HollowCall+  { n :: TypeName+  } deriving (Show, Eq, Generic)++instance FromJSON HollowCall++data Enumeral = Enumeral+  { tag :: EnumeralName+  , m :: Maybe (Map MemberName Ast)+  } deriving (Show, Eq, Generic)++instance FromJSON Enumeral where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    let tagless = HML.delete "tag" o+    if HML.size o == 1+      then pure $ Enumeral tag Nothing+      else Enumeral tag <$> (Just <$> parseJSON (Object tagless))+  parseJSON _ = mzero++data Struct = Struct+  { m :: Map MemberName Ast+  } deriving (Show, Eq, Generic)++instance FromJSON Struct where+  parseJSON v = Struct <$> parseJSON v++data Wrap = Wrap+  { w :: Ast+  } deriving (Show, Eq, Generic)++instance FromJSON Wrap
+ library/Colorless/Server/Expr.hs view
@@ -0,0 +1,680 @@+{-# LANGUAGE RankNTypes #-}+module Colorless.Server.Expr+  ( Expr(..)+  , EvalConfig(..)+  --+  , Ref(..)+  , UnVal(..)+  , UnEnumeral(..)+  , UnWrap(..)+  , UnStruct(..)+  , If(..)+  , Get(..)+  , Define(..)+  , Lambda(..)+  , Fn(..)+  , List(..)+  , Begin(..)+  , 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.Server.Ast as Ast+import Colorless.Types+import Colorless.Server.Types+import Colorless.Server.Val+import Colorless.Server.Ast (Ast(..))++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'Begin (Begin 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 Begin m = Begin+  { 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 :: Map MemberName (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'Begin Ast.Begin{vals} -> Expr'Begin $ Begin $ 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'Begin begin -> evalBegin begin 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'ApiVal $ ApiVal'Wrap $ Wrap 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 ("w":path) (ApiVal'Wrap (Wrap w)) = getter path (Expr'Val (Val'Const w))+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 <- variableLimit <$> 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+  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 <- variableLimit <$> 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'++evalBegin :: (MonadIO m, RuntimeThrower m) => Begin m -> IORef (Env m) -> Eval m (Expr m)+evalBegin Begin{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+  m' <- mapM eval' m+  Eval . ReaderT $ \cfg ->+    apiCall cfg $ ApiCall'Struct n (Struct m')+  where+    eval' expr = do+      expr' <- eval expr envRef+      case expr' of+        Expr'Val v -> return v+        _ -> 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)+  -> Expr m+boolExpr num i8 i16 i32 i64 u8 u16 u32 u64 = 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++    (_:_:[]) -> 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 w -> join $ ($ Val'ApiVal (ApiVal'Wrap w)) <$> Map.lookup n wrap
+ library/Colorless/Server/Types.hs view
@@ -0,0 +1,116 @@+module Colorless.Server.Types+  ( Symbol(..)+  , Type(..)+  , TypeName(..)+  , MemberName(..)+  , EnumeralName(..)+  , EnumeralType(..)+  , EnumerationType(..)+  , StructType(..)+  , HollowType(..)+  , Prim(..)+  , Const(..)+  ) where++import qualified Data.HashMap.Lazy as HML+import Control.Monad (mzero)+import Data.Aeson (FromJSON(..), FromJSONKey, ToJSONKey, Value(..), (.:), ToJSON(..))+import Data.Text (Text)+import Data.Map (Map)+import Data.Int+import Data.Word+import Data.Scientific+import Data.String (IsString)++newtype Symbol = Symbol Text+  deriving (Show, Eq, Ord, FromJSON, IsString)++data Type = Type+  { n :: TypeName+  , p :: Maybe Type+  } deriving (Show, Eq)++instance FromJSON Type where+  parseJSON = \case+    String s -> pure $ Type (TypeName s) Nothing+    Object o -> do+      n <- o .: "n"+      case HML.lookup "p" o of+        Nothing -> pure $ Type n Nothing+        Just p -> Type n <$> fmap Just (parseJSON p)+    _ -> mzero++newtype TypeName = TypeName Text+  deriving (Show, Eq, Ord, FromJSON, IsString)++newtype EnumeralName = EnumeralName Text+  deriving (Show, Eq, Ord, FromJSON, ToJSON, IsString)++newtype MemberName = MemberName Text+  deriving (Show, Eq, Ord, FromJSON, ToJSON, ToJSONKey, FromJSONKey, IsString)++data EnumeralType = EnumeralType+  { m :: Maybe (Map MemberName Type)+  } deriving (Show, Eq)++data EnumerationType = EnumerationType+  { e :: Map EnumeralName EnumeralType+  , o :: Type+  } deriving (Show, Eq)++data StructType = StructType+  { m :: Map MemberName Type+  , o :: Type+  } deriving (Show, Eq)++data HollowType = HollowType+  { o :: Type+  } deriving (Show, Eq)++data Prim+  = Prim'Bool Bool+  | Prim'I8 Int8+  | Prim'I16 Int16+  | Prim'I32 Int32+  | Prim'I64 Int64+  | Prim'U8 Word8+  | Prim'U16 Word16+  | Prim'U32 Word32+  | Prim'U64 Word64+  | Prim'String Text+  deriving (Show, Eq)++instance ToJSON Prim where+  toJSON = \case+    Prim'Bool b -> toJSON b+    Prim'I8 i -> toJSON i+    Prim'I16 i -> toJSON i+    Prim'I32 i -> toJSON i+    Prim'I64 i -> toJSON i+    Prim'U8 u -> toJSON u+    Prim'U16 u -> toJSON u+    Prim'U32 u -> toJSON u+    Prim'U64 u -> toJSON u+    Prim'String s -> toJSON s++data Const+  = Const'Null+  | Const'Bool Bool+  | Const'String Text+  | Const'Number Scientific+  deriving (Show, Eq)++instance ToJSON Const where+  toJSON = \case+    Const'Null -> Null+    Const'Bool b -> Bool b+    Const'String s -> String s+    Const'Number n -> Number n++instance FromJSON Const where+  parseJSON = \case+    Null -> pure $ Const'Null+    Bool b -> pure $ Const'Bool b+    String s -> pure $ Const'String s+    Number n -> pure $ Const'Number n+    _ -> mzero
+ library/Colorless/Server/Val.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE DeriveGeneric #-}+module Colorless.Server.Val+  ( Val(..)+  , ApiVal(..)+  , Wrap(..)+  , Struct(..)+  , Enumeral(..)+  --+  , FromVal(..)+  , ToVal(..)+  , getMember+  , fromValFromJson+  , combineObjects+  ) where++import qualified Data.HashMap.Lazy as HML+import qualified Data.Map as Map+import qualified Data.Vector as V+import Control.Monad (mzero)+import Control.Applicative ((<|>))+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import Data.Map (Map)+import Data.Text (Text)+import Data.Int+import Data.Word+import Data.Scientific+import GHC.Generics (Generic)++import Colorless.Server.Types++data Val+  = Val'Const Const+  | Val'Prim Prim+  | Val'ApiVal ApiVal+  | Val'List [Val]+  deriving (Show, Eq)++instance ToJSON Val where+  toJSON = \case+    Val'Const c -> toJSON c+    Val'ApiVal v -> toJSON v+    Val'List l -> toJSON l+    Val'Prim p -> toJSON p++instance FromJSON Val where+  parseJSON = \case+    Null -> return $ Val'Const Const'Null+    Number n -> return $ Val'Const $ Const'Number n+    String s -> return $ Val'Const $ Const'String s+    Bool b -> return $ Val'Const $ Const'Bool b+    Array arr -> Val'List <$> (mapM parseJSON $ V.toList arr)+    v@Object{} -> Val'ApiVal <$> parseJSON v++data ApiVal+  = ApiVal'Wrap Wrap+  | ApiVal'Struct Struct+  | ApiVal'Enumeral Enumeral+  deriving (Show, Eq)++instance ToJSON ApiVal where+  toJSON = \case+    ApiVal'Wrap w -> toJSON w+    ApiVal'Struct s -> toJSON s+    ApiVal'Enumeral e -> toJSON e++instance FromJSON ApiVal where+  parseJSON v =+    (ApiVal'Wrap <$> parseJSON v) <|>+    (ApiVal'Enumeral <$> parseJSON v) <|>+    (ApiVal'Struct <$> parseJSON v)++data Wrap = Wrap+  { w :: Const+  } deriving (Show, Eq, Generic)++instance ToJSON Wrap+instance FromJSON Wrap++data Struct = Struct+  { m :: Map MemberName Val+  } deriving (Show, Eq, Generic)++instance ToJSON Struct where+  toJSON Struct{m} = toJSON m++instance FromJSON Struct where+  parseJSON v = Struct <$> parseJSON v++data Enumeral = Enumeral+  { tag :: EnumeralName+  , m :: Maybe (Map MemberName Val)+  } deriving (Show, Eq, Generic)++instance ToJSON Enumeral where+  toJSON Enumeral{tag,m} = object $ [ "tag" .= tag ] ++ case m of+    Nothing -> []+    Just m' -> concatMap (\(MemberName k,v) -> [ k .= v ]) (Map.toList m')++instance FromJSON Enumeral where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    let tagless = HML.delete "tag" o+    if HML.size o == 1+      then pure $ Enumeral tag Nothing+      else Enumeral tag <$> (Just <$> parseJSON (Object tagless))+  parseJSON _ = mzero++--++class ToVal a where+  toVal :: a -> Val++instance ToVal () where+  toVal () = Val'Const Const'Null++instance ToVal Bool where+  toVal b = Val'Const $ Const'Bool b++instance ToVal Text where+  toVal s = Val'Const $ Const'String s++intToVal :: Integral a => a -> Val+intToVal n = Val'Const $ Const'Number (fromInteger $ toInteger n)++instance ToVal Int where+  toVal = intToVal++instance ToVal Int8 where+  toVal i = Val'Prim $ Prim'I8 i++instance ToVal Int16 where+  toVal i = Val'Prim $ Prim'I16 i++instance ToVal Int32 where+  toVal i = Val'Prim $ Prim'I32 i++instance ToVal Int64 where+  toVal i = Val'Prim $ Prim'I64 i++instance ToVal Word where+  toVal = intToVal++instance ToVal Word8 where+  toVal u = Val'Prim $ Prim'U8 u++instance ToVal Word16 where+  toVal u = Val'Prim $ Prim'U16 u++instance ToVal Word32 where+  toVal u = Val'Prim $ Prim'U32 u++instance ToVal Word64 where+  toVal u = Val'Prim $ Prim'U64 u++instance ToVal Float where+    toVal f = Val'Const $ Const'Number $ fromFloatDigits f++instance ToVal Double where+    toVal d = Val'Const $ Const'Number $ fromFloatDigits d++instance ToVal a => ToVal (Maybe a) where+  toVal Nothing = Val'Const Const'Null+  toVal (Just v) = toVal v++instance (ToVal a, ToVal b) => ToVal (Either a b) where+  toVal m = Val'ApiVal $ ApiVal'Enumeral $ case m of+    Left l -> Enumeral "Left" (Just $ Map.singleton "left" (toVal l))+    Right r -> Enumeral "Right" (Just $ Map.singleton "right" (toVal r))++instance ToVal a => ToVal [a] where+  toVal list = Val'List $ map toVal list++--++class FromVal a where+  fromVal :: Val -> Maybe a++instance FromVal () where+  fromVal (Val'Const Const'Null) = Just ()+  fromVal _ = Nothing++instance FromVal Bool where+  fromVal (Val'Const (Const'Bool b)) = Just b+  fromVal _ = Nothing++instance FromVal Text where+  fromVal (Val'Const (Const'String s)) = Just s+  fromVal _ = Nothing++intFromVal :: (Bounded i, Integral i) => Val -> Maybe i+intFromVal (Val'Const (Const'Number n)) = toBoundedInteger n+intFromVal _ = Nothing++instance FromVal Int where+  fromVal = intFromVal++instance FromVal Int8 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'I8 i) -> Just i+    _ -> Nothing++instance FromVal Int16 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'I16 i) -> Just i+    _ -> Nothing++instance FromVal Int32 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'I32 i) -> Just i+    _ -> Nothing++instance FromVal Int64 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'I64 i) -> Just i+    _ -> Nothing++instance FromVal Word where+  fromVal = intFromVal++instance FromVal Word8 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'U8 u) -> Just u+    _ -> Nothing++instance FromVal Word16 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'U16 u) -> Just u+    _ -> Nothing++instance FromVal Word32 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'U32 u) -> Just u+    _ -> Nothing++instance FromVal Word64 where+  fromVal = \case+    Val'Const (Const'Number n) -> toBoundedInteger n+    Val'Prim (Prim'U64 u) -> Just u+    _ -> Nothing++instance FromVal Float where+  fromVal (Val'Const (Const'Number n)) = Just $ toRealFloat n+  fromVal _ = Nothing++instance FromVal Double where+  fromVal (Val'Const (Const'Number n)) = Just $ toRealFloat n+  fromVal _ = Nothing++instance FromVal a => FromVal (Maybe a) where+  fromVal (Val'Const Const'Null) = Just Nothing+  fromVal v = Just <$> fromVal v++instance (FromVal a, FromVal b) => FromVal (Either a b) where+  fromVal (Val'ApiVal (ApiVal'Enumeral (Enumeral tag m))) = case (tag,m) of+    ("Left",Just m') -> Map.lookup "left" m' >>= \l -> Left <$> fromVal l+    ("Right",Just m') -> Map.lookup "right" m' >>= \r -> Right <$> fromVal r+    _ -> Nothing+  fromVal _ = Nothing++instance FromVal a => FromVal [a] where+  fromVal (Val'List list) = mapM fromVal list+  fromVal _ = Nothing++getMember :: FromVal a => Map MemberName Val -> MemberName -> Maybe a+getMember m n = fromVal =<< Map.lookup n m++fromValFromJson :: (FromVal b) => Value -> Maybe b+fromValFromJson x = fromVal =<< parseMaybe parseJSON x++combineObjects :: Value -> Value -> Value+combineObjects (Object x) (Object y) = Object $ HML.union x y+combineObjects _ _ = error "not objects"
library/Colorless/Types.hs view
@@ -38,7 +38,7 @@  data Request = Request   { meta :: Value-  , query :: [Value]+  , query :: Value   } deriving (Show, Eq)  instance FromJSON Request where
package.yaml view
@@ -1,5 +1,5 @@ name: colorless-version: '2.0.0'+version: '2.1.0' category: Web synopsis: Colorless description: Colorless
tests/AstSpec.hs view
@@ -6,8 +6,8 @@ import Data.Aeson import Data.Aeson.Types -import Colorless.Runtime.Types-import Colorless.Runtime.Ast+import Colorless.Server.Types+import Colorless.Server.Ast  parseAst :: Value -> Maybe Ast parseAst = parseMaybe parseJSON@@ -68,6 +68,15 @@       it "simple" $ shouldBe         (parseAst $ object [ "List" .= [String "hello"] ])         (Just $ Ast'List $ List [Ast'Const $ Const'String "hello"])++    context "Tuple" $ do+      it "one element (sematically too small)" $ shouldBe+        (parseAst $ object [ "Tuple" .= [String "hello"] ])+        (Just $ Ast'Tuple $ Tuple [Ast'Const $ Const'String "hello"])++      it "more than one elements" $ shouldBe+        (parseAst $ object [ "Tuple" .= [String "hello", String "world"] ])+        (Just $ Ast'Tuple $ Tuple [Ast'Const $ Const'String "hello", Ast'Const $ Const'String "world"])      context "Begin" $ do       it "simple" $ shouldBe
tests/ExprSpec.hs view
@@ -3,8 +3,8 @@ import Test.Hspec  -- import Colorless.Types--- import Colorless.Runtime.Types--- import Colorless.Runtime.Expr+-- import Colorless.Server.Types+-- import Colorless.Server.Expr  spec :: Spec spec = do
tests/ValSpec.hs view
@@ -6,8 +6,8 @@ import Data.Aeson.Types import Data.Text (Text) -import Colorless.Runtime.Types-import Colorless.Runtime.Val+import Colorless.Server.Types+import Colorless.Server.Val  spec :: Spec spec = do