shentong-0.3.2: Shentong/Environment.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Environment ( initEnv, evalKL ) where

import Control.Applicative
import Control.Monad.Except
import qualified Data.HashMap as HM
import Data.IORef
import Data.Traversable hiding (mapM)
import qualified Data.Vector as V
import Interpreter.Interpreter
import Core.Primitives
import System.IO
import Core.Types
import Core.Utils
import Wrap

valueToTopLevel :: KLValue -> KLContext Env TopLevel
valueToTopLevel (Cons (Atom (UnboundSym "defun"))
                      (Cons (Atom (UnboundSym name))
                            (Cons args (Cons e (Atom Nil))))) =
    Defun name <$> toParamList args <*> valueToSExpr e
    where toParamList (Cons (Atom (UnboundSym a)) as) = (a :) <$> toParamList as
          toParamList (Atom Nil) = pure []
          toParamList _  = throwError "defun form contains invalid lambda list"
valueToTopLevel se = SE <$> valueToSExpr se

valueToSExpr :: KLValue -> KLContext Env SExpr
valueToSExpr (ApplC (PL name _)) = return (Sym name)
valueToSExpr (ApplC (Func name _)) = return (Sym name)
valueToSExpr (Atom (UnboundSym sym)) = return (Sym sym)
valueToSExpr (Atom Nil) = return EmptyList
valueToSExpr (Atom a) = return (Lit a)
valueToSExpr (Cons v vs) = applToSExpr v (consToList vs)
    where consToList (Cons v vs) = v : consToList vs
          consToList (Atom Nil)  = []
          consToList v = [v]
valueToSExpr (Vec v)
  | V.null v  = pure emptyVec
  | otherwise = vecToSExprList (V.tail v)
    where emptyVec = Appl [Lit (UnboundSym "vector"), Lit (N (KI 0))]
          
          vecToSExprList vec 
            | V.null vec = pure emptyVec
            | otherwise  = do
                se <- valueToSExpr (V.head vec)
                ss <- vecToSExprList (V.tail vec)
                return (Appl [Lit (UnboundSym "@v"), se , ss])
valueToSExpr v = throwError "cannot evaluate list containing non-literal values"

applToSExpr :: KLValue -> [KLValue] -> KLContext Env SExpr
applToSExpr (Atom (UnboundSym "cond")) l = Cond <$> listOfConds l
    where listOfConds (Cons cond (Cons clause (Atom Nil)) : cs) =
              (:) <$> ((,) <$> valueToSExpr cond <*> valueToSExpr clause)
                  <*> listOfConds cs
          listOfConds [] = pure []
          listOfConds _  = throwError "improperly formed cond clause list"
applToSExpr (Atom (UnboundSym "if")) [c,t,f] =
    If <$> valueToSExpr c <*> valueToSExpr t <*> valueToSExpr f
applToSExpr (Atom (UnboundSym "let")) [Atom (UnboundSym s),b,e] =
    Let s <$> valueToSExpr b <*> valueToSExpr e
applToSExpr (Atom (UnboundSym "lambda")) [Atom (UnboundSym s), e] =
    Lambda s <$> valueToSExpr e
applToSExpr (Atom (UnboundSym "and")) [c1,c2] =
    And <$> valueToSExpr c1 <*> valueToSExpr c2
applToSExpr (Atom (UnboundSym "or")) [c1,c2] =
    Or <$> valueToSExpr c1 <*> valueToSExpr c2
applToSExpr (Atom (UnboundSym "freeze")) [e] =
    Freeze <$> valueToSExpr e
applToSExpr (Atom (UnboundSym "trap-error")) [e, h] =
    TrapError <$> valueToSExpr e <*> valueToSExpr h
applToSExpr l ls =
    Appl <$> liftA2 (:) (valueToSExpr l) (traverse valueToSExpr ls)

evalKL :: KLValue -> KLContext Env KLValue
evalKL = valueToTopLevel >=> evalTopLevel

primitives :: [(Symbol, Function)]
primitives = [("intern", wrap intern),
              ("pos", wrap pos),
              ("tlstr", wrap tlstr),
              ("cn", wrap cn),
              ("str", wrap str),
              ("string?", wrap stringP),
              ("n->string", wrap nToString),
              ("string->n", wrap stringToN),
              ("set", wrap klSet),
              ("value", wrap value),
              ("simple-error", wrap simpleError),
              ("error-to-string", wrap errorToString),
              ("cons", wrap klCons),
              ("hd", wrap hd),
              ("tl", wrap tl),
              ("cons?", wrap consP),
              ("=", wrap eq),
              ("type", wrap typeA),
              ("absvector", wrap absvector),
              ("address->", wrap addressTo),
              ("<-address", wrap addressFrom),
              ("absvector?", wrap absvectorP),
              ("write-byte", wrap writeByte),
              ("read-byte", wrap readByte),
              ("open", wrap openStream),
              ("close", wrap closeStream),
              ("get-time", wrap getTime),
              ("+", wrap add),
              ("-", wrap Core.Primitives.subtract),
              ("*", wrap multiply),
              ("/", wrap divide),
              (">", wrap greaterThan),
              ("<", wrap lessThan),
              (">=", wrap greaterThanOrEqualTo),
              ("<=", wrap lessThanOrEqualTo),   
              ("number?", wrap numberP),
              ("eval-kl", wrap evalKL)]

initEnv :: (Applicative m, MonadIO m) => m Env
initEnv = Env initSymbolTable <$> HM.fromList <$> mapM update primitives
    where update (n, f) = (n,) <$> liftIO (newIORef $! Func n f)

initSymbolTable :: HM.Map Symbol KLValue
initSymbolTable = HM.fromList [("*stoutput*", OutStream stdout),
                               ("*stinput*", InStream stdin)]