packages feed

colorless 0.0.0 → 0.0.1

raw patch · 16 files changed

+1822/−232 lines, 16 filesdep +aesondep +bytestringdep +colorlessdep −megaparsecdep −pregamesetup-changed

Dependencies added: aeson, bytestring, colorless, containers, errors, exceptions, hspec, lifted-async, monad-control, monad-logger, mtl, random, scientific, text, unordered-containers, vector

Dependencies removed: megaparsec, pregame

Files

LICENSE view
@@ -1,30 +1,29 @@-Copyright Joe Vargas (c) 2016+BSD 3-Clause License +Copyright (c) 2017, Joe Vargas All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer. -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution. -    * Neither the name of Joe Vargas nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# colorless-haskell
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
colorless.cabal view
@@ -1,60 +1,70 @@-name:-  colorless-version:-  0.0.0-synopsis:-  Yet another IDL for RPC-description:-  Please see README.md-homepage:-  http://github.com/jxv/colorless#readme-license:-  BSD3-license-file:-  LICENSE-author:-  Joe Vargas-maintainer:-  http://github.com/jxv-copyright:-  2016 Joe Vargas-category:-  Web-build-type:-  Simple--- extra-source-files:-cabal-version:-  >=1.10+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack +name:           colorless+version:        0.0.1+synopsis:       Colorless+description:    Colorless+category:       Web+maintainer:     Joe Vargas+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    package.yaml+    README.md+ library   hs-source-dirs:-    src-  exposed-modules:-    Colorless.CodeGen.Types+      library+  default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeOperators+  ghc-options: -Wall   build-depends:-      base >= 4.7 && < 5-    , pregame == 1.0.3.0-    , megaparsec-  default-language:-    Haskell2010-  default-extensions:-    NoImplicitPrelude-    OverloadedStrings-    TypeSynonymInstances-    FlexibleInstances-    FlexibleContexts-    GeneralizedNewtypeDeriving-    LambdaCase-    ScopedTypeVariables-    NamedFieldPuns-    MultiParamTypeClasses-    TypeFamilies-    TupleSections-    DuplicateRecordFields-    OverloadedLists+      aeson+    , base >= 4.7 && < 5+    , bytestring+    , containers+    , errors+    , exceptions+    , lifted-async+    , monad-control+    , monad-logger+    , mtl+    , random+    , scientific+    , text+    , unordered-containers+    , vector+  exposed-modules:+      Colorless.Endpoint+      Colorless.Runtime.Ast+      Colorless.Runtime.Expr+      Colorless.Runtime.Types+      Colorless.Runtime.Val+      Colorless.Types+  default-language: Haskell2010 -source-repository head-  type:-    git-  location:-    https://github.com/jxv/colorless+test-suite colorless-suite+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      tests+  default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      aeson+    , base >= 4.7 && < 5+    , colorless+    , containers+    , hspec+    , scientific+    , text+    , vector+  other-modules:+      AstSpec+      ExprSpec+      ValSpec+  default-language: Haskell2010
+ library/Colorless/Endpoint.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds #-}+module Colorless.Endpoint+  ( runColorless+  , runColorlessSingleton+  ) where++import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as HML+import Control.Monad.IO.Class (MonadIO(..))+import Control.Concurrent.Async.Lifted ()+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import Data.Text (Text)+import Data.Map (Map)++import Colorless.Types++runColorlessSingleton+  :: (MonadIO m, RuntimeThrower m)+  => Version+  -> (Request -> m Response)+  -> Value+  -> m Value+runColorlessSingleton Version{major,minor} handleRequest = runColorless (Map.singleton major (minor, handleRequest))++runColorless+  :: (MonadIO m, RuntimeThrower m)+  => Map Major (Minor, Request -> m Response)+  -> Value+  -> m Value+runColorless handleRequestMap v = do+  colorlessVersion <- getColorlessVersion v+  assertColorlessVersionCompatiability colorlessVersion+  apiVersion <- getApiVersion v+  let apiMajor = major apiVersion+  case Map.lookup apiMajor handleRequestMap of+    Nothing -> case leastAndGreatest (Map.keys handleRequestMap) of+      Nothing -> runtimeThrow RuntimeError'NoImplementation+      Just (minMajor, maxMajor) ->+        if minMajor > apiMajor+          then runtimeThrow RuntimeError'ApiMajorVersionTooLow+          else if maxMajor < apiMajor+            then runtimeThrow RuntimeError'ApiMajorVersionTooHigh+            else runtimeThrow RuntimeError'NoImplementation+    Just (maxMinor, handleRequest) -> if minor apiVersion > maxMinor+      then runtimeThrow RuntimeError'ApiMinorVersionTooHigh+      else case parseRequest v of+        Nothing -> runtimeThrow RuntimeError'UnparsableFormat+        Just req -> toJSON <$> handleRequest req++leastAndGreatest :: Ord a => [a] -> Maybe (a,a)+leastAndGreatest [] = Nothing+leastAndGreatest xs = Just (minimum xs, maximum xs)++assertColorlessVersionCompatiability :: RuntimeThrower m => Version -> m ()+assertColorlessVersionCompatiability Version{major,minor}+  | major > mustMajor = runtimeThrow RuntimeError'ColorlessMajorVersionTooHigh+  | major < mustMajor = runtimeThrow RuntimeError'ColorlessMajorVersionTooLow+  | minor > maxMinor = runtimeThrow RuntimeError'ColorlessMinorVersionTooHigh+  | otherwise = return ()+  where+    mustMajor = 0+    maxMinor = 0++getApiVersion :: RuntimeThrower m => Value -> m Version+getApiVersion = getVersion "version" RuntimeError'NoApiVersion++getColorlessVersion :: RuntimeThrower m => Value -> m Version+getColorlessVersion = getVersion "colorless" RuntimeError'NoColorlessVersion++getVersion :: RuntimeThrower m => Text -> RuntimeError -> Value -> m Version+getVersion name err (Object o) = case HML.lookup name o of+  Just x -> maybe (runtimeThrow err) return (parseMaybe parseJSON x)+  Nothing -> runtimeThrow err+getVersion _ err _ = runtimeThrow err++parseRequest :: Value -> Maybe Request+parseRequest = parseMaybe parseJSON
+ library/Colorless/Runtime/Ast.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DeriveGeneric #-}+module Colorless.Runtime.Ast+  ( Ast(..)+  , Ref(..)+  , If(..)+  , Set(..)+  , Get(..)+  , Define(..)+  , Lambda(..)+  , List(..)+  , Begin(..)+  , FnCall(..)+  , Enumerator(..)+  , 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'Set Set+  | 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'Enumerator Enumerator+  | 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'Set <$> 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'Enumerator <$> 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 Set = Set+  { var :: Symbol+  , expr :: Ast+  } deriving (Show, Eq)++instance FromJSON Set where+  parseJSON (Array arr) = case V.toList arr of+    ["set", var, expr] -> Set <$> parseJSON var <*> parseJSON expr+    _ -> 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 Enumerator = Enumerator+  { tag :: EnumeratorName+  , m :: Maybe (Map MemberName Ast)+  } deriving (Show, Eq, Generic)++instance FromJSON Enumerator where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    let tagless = HML.delete "tag" o+    if HML.size o == 1+      then pure $ Enumerator tag Nothing+      else Enumerator 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 view
@@ -0,0 +1,677 @@+{-# LANGUAGE RankNTypes #-}+module Colorless.Runtime.Expr+  ( Expr(..)+  , EvalConfig(..)+  --+  , Ref(..)+  , UnVal(..)+  , UnEnumerator(..)+  , UnWrap(..)+  , UnStruct(..)+  , If(..)+  , Set(..)+  , Get(..)+  , Define(..)+  , Lambda(..)+  , Fn(..)+  , List(..)+  , Begin(..)+  , FnCall(..)+  , ApiUnCall(..)+  , HollowUnCall(..)+  , WrapUnCall(..)+  , StructUnCall(..)+  , EnumerationUnCall(..)+  , Val(..)+  , ApiVal(..)+  , Wrap(..)+  , Struct(..)+  , Enumerator(..)+  , 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'Set (Set 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'UnEnumerator (UnEnumerator 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 UnEnumerator m = UnEnumerator+  { tag :: EnumeratorName+  , 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 Set m = Set+  { var :: Symbol+  , expr :: 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 Enumerator+  | 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'Set Ast.Set{var,expr} -> Expr'Set $ Set var (fromAst expr)+  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'Enumerator Ast.Enumerator{tag,m} -> Expr'UnVal $ UnVal'UnEnumerator $ UnEnumerator 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'Set set -> evalSet set envRef+  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'UnEnumerator UnEnumerator{tag,m} -> do+    case m of+      Nothing -> return $ Expr'Val $ Val'ApiVal $ ApiVal'Enumerator $ Enumerator tag Nothing+      Just members' -> do+        members <- mapM (\(name,expr) -> (name,) <$> (forceVal =<< eval expr envRef)) (Map.toList members')+        return $ Expr'Val $ Val'ApiVal $ ApiVal'Enumerator $ Enumerator 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++evalSet :: (MonadIO m, RuntimeThrower m) => Set m -> IORef (Env m) -> Eval m (Expr m)+evalSet Set{var = var@(Symbol var'), expr} envRef = do+  expr' <- eval expr envRef+  env <- liftIO $ readIORef envRef+  case Map.lookup var env of+    Nothing -> runtimeThrow $ RuntimeError'UnknownVariable var'+    Just v -> do+      liftIO $ writeIORef v expr'+      return expr'++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'Enumerator Enumerator{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'Enumerator 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'Enumerator e)) <$> Map.lookup n enumeration+  ApiCall'Wrap n w -> join $ ($ Val'ApiVal (ApiVal'Wrap w)) <$> Map.lookup n wrap
+ library/Colorless/Runtime/Types.hs view
@@ -0,0 +1,116 @@+module Colorless.Runtime.Types+  ( Symbol(..)+  , Type(..)+  , TypeName(..)+  , MemberName(..)+  , EnumeratorName(..)+  , EnumeratorType(..)+  , 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 EnumeratorName = EnumeratorName Text+  deriving (Show, Eq, Ord, FromJSON, ToJSON, IsString)++newtype MemberName = MemberName Text+  deriving (Show, Eq, Ord, FromJSON, ToJSON, ToJSONKey, FromJSONKey, IsString)++data EnumeratorType = EnumeratorType+  { m :: Maybe (Map MemberName Type)+  } deriving (Show, Eq)++data EnumerationType = EnumerationType+  { e :: Map EnumeratorName EnumeratorType+  , 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 view
@@ -0,0 +1,284 @@+{-# LANGUAGE DeriveGeneric #-}+module Colorless.Runtime.Val+  ( Val(..)+  , ApiVal(..)+  , Wrap(..)+  , Struct(..)+  , Enumerator(..)+  --+  , 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'Enumerator Enumerator+  deriving (Show, Eq)++instance ToJSON ApiVal where+  toJSON = \case+    ApiVal'Wrap w -> toJSON w+    ApiVal'Struct s -> toJSON s+    ApiVal'Enumerator e -> toJSON e++instance FromJSON ApiVal where+  parseJSON v =+    (ApiVal'Wrap <$> parseJSON v) <|>+    (ApiVal'Enumerator <$> 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 Enumerator = Enumerator+  { tag :: EnumeratorName+  , m :: Maybe (Map MemberName Val)+  } deriving (Show, Eq, Generic)++instance ToJSON Enumerator where+  toJSON Enumerator{tag,m} = object $ [ "tag" .= tag ] ++ case m of+    Nothing -> []+    Just m' -> concatMap (\(MemberName k,v) -> [ k .= v ]) (Map.toList m')++instance FromJSON Enumerator where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    let tagless = HML.delete "tag" o+    if HML.size o == 1+      then pure $ Enumerator tag Nothing+      else Enumerator 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 m = Val'ApiVal $ ApiVal'Enumerator $ case m of+    Nothing -> Enumerator "None" Nothing+    Just s -> Enumerator "Some" (Just $ Map.singleton "some" (toVal s))++instance (ToVal a, ToVal b) => ToVal (Either a b) where+  toVal m = Val'ApiVal $ ApiVal'Enumerator $ case m of+    Left l -> Enumerator "Left" (Just $ Map.singleton "left" (toVal l))+    Right r -> Enumerator "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'ApiVal (ApiVal'Enumerator (Enumerator tag m))) = case (tag,m) of+    ("Some",Just m') -> fromVal <$> Map.lookup "some" m'+    ("None",Nothing) -> Just Nothing+    _ -> Nothing+  fromVal _ = Nothing++instance (FromVal a, FromVal b) => FromVal (Either a b) where+  fromVal (Val'ApiVal (ApiVal'Enumerator (Enumerator 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
@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveGeneric #-}+module Colorless.Types+  ( Version(..)+  , Major(..)+  , Minor(..)+  , Request(..)+  , Response(..)+  , ResponseError(..)+  , RuntimeError(..)+  , RuntimeThrower(..)+  , Options(..)+  ) where++import Control.Monad (mzero)+import Data.Aeson+import Data.Text (Text)+import GHC.Generics++newtype Major = Major Int+  deriving (Show, Eq, Generic, Num, Ord, Real, Integral, Enum)++instance FromJSON Major+instance ToJSON Major++newtype Minor = Minor Int+  deriving (Show, Eq, Generic, Num, Ord, Real, Integral, Enum)++instance FromJSON Minor+instance ToJSON Minor++data Version = Version+  { major :: Major+  , minor :: Minor+  } deriving (Show, Eq, Generic)++instance ToJSON Version+instance FromJSON Version++data Request = Request+  { meta :: Value+  , calls :: [Value]+  } deriving (Show, Eq)++instance FromJSON Request where+  parseJSON (Object o) = Request+    <$> o .: "meta"+    <*> o .: "calls"+  parseJSON _ = mzero++data RuntimeError+  = RuntimeError'UnparsableFormat+  | RuntimeError'UnrecognizedCall+  | RuntimeError'VariableLimit+  | RuntimeError'UnknownVariable Text+  | RuntimeError'IncompatibleType+  | RuntimeError'TooFewArguments+  | RuntimeError'TooManyArguments+  | RuntimeError'NoApiVersion+  | RuntimeError'NoColorlessVersion+  | RuntimeError'ApiMajorVersionTooLow+  | RuntimeError'ApiMajorVersionTooHigh+  | RuntimeError'ApiMinorVersionTooHigh+  | RuntimeError'ColorlessMajorVersionTooLow+  | RuntimeError'ColorlessMajorVersionTooHigh+  | RuntimeError'ColorlessMinorVersionTooHigh+  | RuntimeError'UnparsableMeta+  | RuntimeError'UnparsableCalls+  | RuntimeError'NoImplementation+  | RuntimeError'NotMember+  deriving (Show, Eq)++instance ToJSON RuntimeError where+  toJSON = \case+    RuntimeError'UnparsableFormat -> e "UnparsableFormat"+    RuntimeError'UnrecognizedCall -> object [ "tag" .= String "UnrecognizedCall" ]+    RuntimeError'VariableLimit -> e "VariableLimit"+    RuntimeError'UnknownVariable m -> object [ "tag" .= String "UnknownVariable", "name" .= m ]+    RuntimeError'IncompatibleType -> e "IncompatibleType"+    RuntimeError'TooFewArguments -> e "TooFewArguments"+    RuntimeError'TooManyArguments -> e "TooManyArguments"+    RuntimeError'NoApiVersion -> e "NoApiVersion"+    RuntimeError'NoColorlessVersion -> e "NoColorlessVersion"+    RuntimeError'ApiMajorVersionTooHigh -> e "ApiMajorVersionTooHigh"+    RuntimeError'ApiMajorVersionTooLow -> e "ApiMajorVersionTooLow"+    RuntimeError'ApiMinorVersionTooHigh -> e "ApiMinorVersionTooHigh"+    RuntimeError'ColorlessMajorVersionTooHigh -> e "ColorlessMajorVersionTooHigh"+    RuntimeError'ColorlessMajorVersionTooLow -> e "ColorlessMajorVersionTooLow"+    RuntimeError'ColorlessMinorVersionTooHigh -> e "ColorlessMinorVersionTooHigh"+    RuntimeError'UnparsableMeta -> e "UnparsableMeta"+    RuntimeError'UnparsableCalls -> e "UnparsableCalls"+    RuntimeError'NoImplementation -> e "NoImplementation"+    RuntimeError'NotMember -> e "NotMember"+    where+      e s = object [ "tag" .= String s ]++data ResponseError+  = ResponseError'Service Value+  | ResponseError'Runtime RuntimeError+  deriving (Eq, Show)++instance ToJSON ResponseError where+  toJSON = \case+    ResponseError'Service m -> object [ "tag" .= String "Service", "service" .= m ]+    ResponseError'Runtime m -> object [ "tag" .= String "Runtime", "runtime" .= m ]++data Response+  = Response'Error ResponseError+  | Response'Success Value+  deriving (Show, Eq)++instance ToJSON Response where+  toJSON (Response'Error m) = object [ "tag" .= String "Error", "error" .= m ]+  toJSON (Response'Success m) = object [ "tag" .= String "Success", "success" .= m ]++class Monad m => RuntimeThrower m where+  runtimeThrow :: RuntimeError -> m a++instance RuntimeThrower IO where+  runtimeThrow err = error $ "Runtime error - " ++ show err++data Options = Options+  { variableLimit :: Maybe Int+  } deriving (Show, Eq)
+ package.yaml view
@@ -0,0 +1,64 @@+name: colorless+version: '0.0.1'+category: Web+synopsis: Colorless+description: Colorless+maintainer: Joe Vargas+license: BSD3+extra-source-files:+- package.yaml+- README.md+ghc-options: -Wall+default-extensions:+- ConstraintKinds+- DeriveGeneric+- DuplicateRecordFields+- FlexibleContexts+- FlexibleInstances+- GADTs+- GeneralizedNewtypeDeriving+- KindSignatures+- LambdaCase+- MultiParamTypeClasses+- NamedFieldPuns+- OverloadedStrings+- RankNTypes+- ScopedTypeVariables+- TupleSections+- TypeApplications+- TypeOperators+library:+  dependencies:+  - aeson+  - base >= 4.7 && < 5+  - bytestring+  - containers+  - errors+  - exceptions+  - lifted-async+  - monad-control+  - monad-logger+  - mtl+  - random+  - scientific+  - text+  - unordered-containers+  - vector+  source-dirs: library+tests:+  colorless-suite:+    dependencies:+    - aeson+    - base >= 4.7 && < 5+    - colorless+    - containers+    - hspec+    - scientific+    - text+    - vector+    ghc-options:+    - -rtsopts+    - -threaded+    - -with-rtsopts=-N+    main: Spec.hs+    source-dirs: tests
− src/Colorless/CodeGen/Types.hs 
@@ -1,155 +0,0 @@-module Colorless.CodeGen.Types-  (-  ) where--import Pregame--newtype FuncName = FuncName Text deriving (Show, Eq, Ord, IsString)-newtype ArgName = ArgName Text deriving (Show, Eq, Ord, IsString)-newtype Tag = Tag Text deriving (Show, Eq, Ord, IsString)-newtype SumName = SumName Text deriving (Show, Eq, Ord, IsString)-newtype SubtypeName = SubtypeName Text deriving (Show, Eq, Ord, IsString)-newtype FieldName = FieldName Text deriving (Show, Eq, Ord, IsString)-newtype OpaqueName = OpaqueName Text deriving (Show, Eq, Ord, IsString)-newtype TypeParamName = TypeParamName Text deriving (Show, Eq, Ord, IsString)-newtype Negative = Negative Integer deriving (Show, Eq, Num)-newtype Positive = Positive Integer deriving (Show, Eq, Num)-newtype Natural = Natural Integer deriving (Show, Eq, Num)-newtype Rational = Rational (Integer, Integer) deriving (Show, Eq)-newtype Version = Version (Integer, Integer, Integer) deriving (Show, Eq, Ord)-newtype HttpDirectory = HttpDirectory [Text] deriving (Show, Eq, Monoid)-newtype HttpPort = HttpPort Int deriving (Show, Eq)-newtype SpecName = SpecName Text deriving (Show, Eq, IsString)-newtype DomainName = DomainName Text deriving (Show, Eq, IsString)--data PrimType-  = PrimTypeUnit-  | PrimTypeU8-  | PrimTypeU16-  | PrimTypeU32-  | PrimTypeU64-  | PrimTypeI8-  | PrimTypeI16-  | PrimTypeI32-  | PrimTypeI64-  | PrimTypeF32-  | PrimTypeF64-  | PrimTypeBool-  | PrimTypeChar-  | PrimTypeStr-  | PrimTypeInt-  | PrimTypeNeg-  | PrimTypePos-  | PrimTypeNat-  | PrimTypeRat-  deriving (Show, Eq)--data PrimRef-  = PrimRefUnit-  | PrimRefU8 Word8-  | PrimRefU16 Word16-  | PrimRefU32 Word32-  | PrimRefU64 Word64-  | PrimRefI8 Int8-  | PrimRefI16 Int16-  | PrimRefI32 Int32-  | PrimRefI64 Int64-  | PrimRefF32 Float-  | PrimRefF64 Double-  | PrimRefBool Bool-  | PrimRefChar Char-  | PrimRefStr Text-  | PrimRefInt Integer-  | PrimRefNeg Negative-  | PrimRefPos Positive-  | PrimRefNat Natural-  | PrimRefRat Rational-  deriving (Show, Eq)--data Type-  = TypePrim PrimType-  | TypeOpaque OpaqueName-  deriving (Show, Eq)--data TypeRef-  = TypeRefPrimType PrimType-  | TypeRefOpaque OpaqueRef-  deriving (Show, Eq)--data TypeParamRef-  = TypeParamRefPrimRef PrimRef-  | TypeParamRefPrimType PrimType-  | TypeParamRefOpaqueRef OpaqueRef-  deriving (Show, Eq)--data TypeParam = TypeParam-  { _name :: TypeParamName-  , _ref :: TypeParamRef-  } deriving (Show, Eq)--data OpaqueRef = OpaqueRef-  { _name :: OpaqueName-  , _params :: [TypeParamRef]-  } deriving (Show, Eq)--data FuncDef = FuncDef-  { _args :: [(ArgName, TypeRef)]-  , _tags :: Set Tag-  } deriving (Show, Eq)--data SumDef = SumDef-  { _params :: [TypeParamRef]-  , _subtypes :: Map SubtypeName [TypeRef]-  , _tags :: Set Tag-  } deriving (Show, Eq)--data ProductDef = ProductDef-  { _params :: [TypeParamRef]-  , _fields :: Map FieldName TypeRef-  , _tags :: Set Tag-  } deriving (Show, Eq)--data OpaqueDef-  = OpaqueDefSum SumDef-  | OpaqueDefProduct ProductDef-  deriving (Show, Eq)--data ServiceDef = ServiceDef-  { _opaques :: Map OpaqueName OpaqueDef-  , _funcs :: Map FuncName FuncDef-  , _tags :: Set Tag-  } deriving (Show, Eq)--data HttpFormat-  = HttpFormatJson-  deriving (Show, Eq)--data HttpMeta-  = HttpMetaHeader-  deriving (Show, Eq)--data HttpImpl = HttpImpl-  { _directory :: HttpDirectory-  , _port :: HttpPort-  , _meta :: HttpMeta-  , _format :: HttpFormat-  } deriving (Show, Eq)--data Impl-  = ImplHttp HttpImpl-  deriving (Show, Eq)--data Domain = Domain-  { _name :: DomainName-  , _service :: ServiceDef-  , _impl :: Impl-  } deriving (Show, Eq)--data SpecDef = SpecDef-  { _name :: SpecName-  , _domains :: [Domain]-  } deriving (Show, Eq)--data Specs = Specs-  { _defs :: Map Version SpecDef-  } deriving (Show, Eq)
+ tests/AstSpec.hs view
@@ -0,0 +1,124 @@+module AstSpec (spec) where++import qualified Data.Vector as V+import qualified Data.Map as Map+import Test.Hspec+import Data.Aeson+import Data.Aeson.Types++import Colorless.Runtime.Types+import Colorless.Runtime.Ast++parseAst :: Value -> Maybe Ast+parseAst = parseMaybe parseJSON++spec :: Spec+spec = do+  describe "parse basic types" $ do+    it "TypeName" $ shouldBe+      (parseMaybe parseJSON (String "MyName"))+      (Just $ TypeName "MyName")++    it "MemberName" $ shouldBe+      (parseMaybe parseJSON (String "MyName"))+      (Just $ MemberName "MyName")++    context "Type" $ do+      it "string only" $ shouldBe+        (parseMaybe parseJSON (String "MyType"))+        (Just $ Type "MyType" Nothing)++      it "object with no param" $ shouldBe+        (parseMaybe parseJSON $ object ["n" .= String "MyType"])+        (Just $ Type "MyType" Nothing)++      it "object with param" $ shouldBe+        (parseMaybe parseJSON $ object ["n" .= String "MyType", "p" .= String "MyParam"])+        (Just $ Type "MyType" (Just $ Type "MyParam" Nothing))++  describe "parse Ast" $ do+    it "Ref" $ shouldBe+      (parseAst $ object ["@" .= String "myRef"])+      (Just $ Ast'Ref $ Ref "myRef")++    context "If" $ do+      it "simple" $ shouldBe+        (parseAst $ Array $ V.fromList ["if", Bool True, "true", "false"])+        (Just $ Ast'If $ If+          (Ast'Const $ Const'Bool True)+          (Ast'Const $ Const'String "true")+          (Ast'Const $ Const'String "false"))++    context "Set" $ do+      it "simple" $ shouldBe+        (parseAst $ Array $ V.fromList ["set", "myVar", Bool False])+        (Just $ Ast'Set $ Set "myVar" (Ast'Const $ Const'Bool False))++    context "Get" $ do+      it "simple yet not semantically correct" $ shouldBe+        (parseAst $ Array $ V.fromList ["get", Array $ V.fromList ["a","b","c"], Bool False])+        (Just $ Ast'Get $ Get ["a","b","c"] (Ast'Const $ Const'Bool False))++    context "Define" $ do+      it "simple" $ shouldBe+        (parseAst $ Array $ V.fromList ["def", "myVar", Bool True])+        (Just $ Ast'Define $ Define "myVar" (Ast'Const $ Const'Bool True))++    context "Lambda" $ do+      it "simple" $ shouldBe+        (parseAst $ Array $ V.fromList ["fn", Array $ V.fromList [ object [ "myVar" .= String "Int64" ] ], Bool True])+        (Just $ Ast'Lambda $ Lambda [("myVar", Type "Int64" Nothing)] (Ast'Const $ Const'Bool True))++    context "List" $ do+      it "simple" $ shouldBe+        (parseAst $ object [ "List" .= [String "hello"] ])+        (Just $ Ast'List $ List [Ast'Const $ Const'String "hello"])++    context "Begin" $ do+      it "simple" $ shouldBe+        (parseAst $ Array $ V.fromList ["begin", Bool True])+        (Just $ Ast'Begin $ Begin [Ast'Const $ Const'Bool True])++    context "FnCall" $ do+      it "simple" $ shouldBe+        (parseAst $ Array $ V.fromList ["someFn", "one", Bool False])+        (Just $ Ast'FnCall $ FnCall (Ast'Ref $ Ref "someFn") [Ast'Const $ Const'String "one", Ast'Const $ Const'Bool False])++    context "EnumerationCall" $ do+      it "simple" $ shouldBe+        (parseAst $ object [ "n" .= String "MyEnum", "e" .= object [ "tag" .= String "MyTag" ] ])+        (Just $ Ast'EnumerationCall $ EnumerationCall "MyEnum" (Ast'Enumerator $ Enumerator "MyTag" Nothing))++    context "StructCall" $ do+      it "simple" $ shouldBe+        (parseAst $ object [ "n" .= String "MyStruct", "m" .= object [ "x" .= Bool True ] ])+        (Just $ Ast'StructCall $ StructCall "MyStruct" (Map.fromList [("x", Ast'Const $ Const'Bool True)]))++    context "HollowCall" $ do+      it "simple" $ shouldBe+        (parseAst $ object [ "n" .= String "MyCall" ])+        (Just $ Ast'HollowCall $ HollowCall "MyCall")++    context "Enumerator" $ do+      it "simple without members" $ shouldBe+        (parseAst $ object [ "tag" .= String "MyTag" ])+        (Just $ Ast'Enumerator $ Enumerator "MyTag" Nothing)+      it "simple with members" $ shouldBe+        (parseAst $ object [ "tag" .= String "MyTag", "x" .= Bool True ])+        (Just $ Ast'Enumerator $ Enumerator "MyTag" (Just $ Map.fromList [("x", Ast'Const $ Const'Bool True)]))++    context "Struct" $ do+      it "simple" $ shouldBe+        (parseAst $ object [ "key0" .= Bool True ])+        (Just $ Ast'Struct $ Struct $ Map.fromList [("key0", Ast'Const $ Const'Bool True)])++    context "Const" $ do+      it "Bool" $ shouldBe+        (parseAst $ Bool True)+        (Just $ Ast'Const $ Const'Bool True)+      it "String" $ shouldBe+        (parseAst $ String "Hello")+        (Just $ Ast'Const $ Const'String "Hello")+      it "Number" $ shouldBe+        (parseAst $ Number 12345)+        (Just $ Ast'Const $ Const'Number 12345)
+ tests/ExprSpec.hs view
@@ -0,0 +1,13 @@+module ExprSpec where++import Test.Hspec++-- import Colorless.Types+-- import Colorless.Runtime.Types+-- import Colorless.Runtime.Expr++spec :: Spec+spec = do+  describe "expr" $ do+    it "" $ do+      True `shouldBe` True
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/ValSpec.hs view
@@ -0,0 +1,31 @@+module ValSpec (spec) where++import qualified Data.Map as Map+import Test.Hspec+import Data.Aeson+import Data.Aeson.Types+import Data.Text (Text)++import Colorless.Runtime.Types+import Colorless.Runtime.Val++spec :: Spec+spec = do+  describe "parse basic types from json" $ do+    it "Enumerator" $ shouldBe+      (parseMaybe parseJSON $ object [ "tag" .= ("None" :: Text) ])+      (Just $ Val'ApiVal $ ApiVal'Enumerator $ Enumerator "None" Nothing)+    it "Struct" $ shouldBe+      (parseMaybe parseJSON $ object [ "x" .= True ])+      (Just $ Val'ApiVal $ ApiVal'Struct $ Struct $ Map.fromList [("x", Val'Const $ Const'Bool True)] )+    it "Struct" $ shouldBe+      (parseMaybe parseJSON $ object [ "x" .= object [ "tag" .= ("None" :: Text) ] ])+      (Just $ Val'ApiVal $ ApiVal'Struct $ Struct $ Map.fromList [("x", Val'ApiVal $ ApiVal'Enumerator $ Enumerator "None" Nothing)] )+  describe "parse types from val" $ do+    context "Option" $ do+      it "None" $ shouldBe+        (fromVal $ Val'ApiVal $ ApiVal'Enumerator $ Enumerator "None" Nothing)+        (Just Nothing :: Maybe (Maybe Bool))+      it "Some" $ shouldBe+        (fromVal $ Val'ApiVal $ ApiVal'Enumerator $ Enumerator "Some" $ Just $ Map.fromList [("some", Val'Const $ Const'Bool $ True)])+        (Just (Just True) :: Maybe (Maybe Bool))