|
|
|
@ -9,6 +9,7 @@ module Lish.Eval
|
|
|
|
|
where
|
|
|
|
|
|
|
|
|
|
import qualified Control.Exception as Exception
|
|
|
|
|
import Data.Fix
|
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
|
import Protolude
|
|
|
|
|
import System.Process hiding (env)
|
|
|
|
@ -23,10 +24,10 @@ infer _ Void = return LVoid
|
|
|
|
|
infer _ (Num _) = return LNum
|
|
|
|
|
infer _ (Bool _) = return LBool
|
|
|
|
|
infer _ (Str _) = return LStr
|
|
|
|
|
infer ctx (List (expr:exprs)) = do
|
|
|
|
|
infer ctx (List ((Fix expr):exprs)) = do
|
|
|
|
|
case infer ctx expr of
|
|
|
|
|
Left terr -> Left terr
|
|
|
|
|
Right t -> case mapM (\e -> checkType ctx e t) exprs of
|
|
|
|
|
Right t -> case mapM (\e -> checkType ctx e t) (map unFix exprs) of
|
|
|
|
|
Left terror -> Left terror
|
|
|
|
|
Right _ -> return $ LList t
|
|
|
|
|
infer ctx (Atom a) = case Map.lookup a ctx of
|
|
|
|
@ -34,13 +35,13 @@ infer ctx (Atom a) = case Map.lookup a ctx of
|
|
|
|
|
Nothing -> Left . TypeError $ "Undefined atom: " <> toS a
|
|
|
|
|
infer ctx (Fn parameters fnbody _ (ptypes,retType)) = do
|
|
|
|
|
let newCtx = Map.union ctx (Map.fromList (zip parameters ptypes))
|
|
|
|
|
checkType newCtx fnbody retType
|
|
|
|
|
checkType newCtx (unFix fnbody) retType
|
|
|
|
|
return $ LFn ptypes retType
|
|
|
|
|
infer ctx (Lambda ((Fn fnparams _ _ (ptypes,retType)):exprs)) =
|
|
|
|
|
infer ctx (Lambda ((Fix (Fn fnparams _ _ (ptypes,retType))):exprs)) =
|
|
|
|
|
if length fnparams /= length exprs
|
|
|
|
|
then Left (TypeError "Fn applied to the wrong number of parameters")
|
|
|
|
|
else do
|
|
|
|
|
inferedTypes <- mapM (infer ctx) exprs
|
|
|
|
|
inferedTypes <- mapM (infer ctx) (map unFix exprs)
|
|
|
|
|
if inferedTypes /= ptypes
|
|
|
|
|
then Left . TypeError $ "Expected " <> show ptypes
|
|
|
|
|
<> " bug got " <> show inferedTypes
|
|
|
|
@ -60,11 +61,12 @@ checkType ctx expr ty = infer ctx expr >>= \ inferedType ->
|
|
|
|
|
-- its real type should be something isomorphic to
|
|
|
|
|
-- (SExp,Environment) -> IO (SExp, Environment)
|
|
|
|
|
reduceLambda :: SExp -> StateT Env IO SExp
|
|
|
|
|
reduceLambda (Lambda (expr:exprs)) = do
|
|
|
|
|
reduceLambda (Lambda (Fix expr:fexprs)) = do
|
|
|
|
|
let exprs = map unFix fexprs
|
|
|
|
|
reduced <- reduceLambda expr
|
|
|
|
|
redred <- reduceLambda reduced
|
|
|
|
|
if redred /= reduced
|
|
|
|
|
then reduceLambda (Lambda (reduced:exprs))
|
|
|
|
|
then reduceLambda (Lambda . map Fix $ (reduced:exprs))
|
|
|
|
|
else do
|
|
|
|
|
-- DEBUG --env <- get
|
|
|
|
|
-- DEBUG --liftIO $ do
|
|
|
|
@ -85,11 +87,11 @@ reduceLambda (Lambda (expr:exprs)) = do
|
|
|
|
|
Just x -> return x
|
|
|
|
|
Nothing -> do
|
|
|
|
|
reducedArgs <- mapM reduceLambda exprs
|
|
|
|
|
executeShell (Lambda ((Atom f):reducedArgs))
|
|
|
|
|
executeShell (Lambda . map Fix $ ((Atom f):reducedArgs))
|
|
|
|
|
f@(Fn _ _ _ _) -> applyFn f exprs
|
|
|
|
|
s -> do
|
|
|
|
|
reducedArgs <- mapM reduceLambda exprs
|
|
|
|
|
executeShell (Lambda (s:reducedArgs))
|
|
|
|
|
executeShell (Lambda . map Fix $ (s:reducedArgs))
|
|
|
|
|
reduceLambda (Atom x) = do
|
|
|
|
|
env <- get
|
|
|
|
|
case Map.lookup x env of
|
|
|
|
@ -106,7 +108,7 @@ applyFn (Fn par bod clos _) args =
|
|
|
|
|
currentEnv <- get
|
|
|
|
|
-- Run the function in its own closure
|
|
|
|
|
fmap fst $ liftIO $
|
|
|
|
|
runStateT (reduceLambda bod) (Map.union currentEnv localClosure)
|
|
|
|
|
runStateT (reduceLambda (unFix bod)) (Map.union currentEnv localClosure)
|
|
|
|
|
where
|
|
|
|
|
bindVars oldenv newvars = Map.union oldenv (Map.fromList newvars)
|
|
|
|
|
applyFn x _ = return x
|
|
|
|
@ -138,8 +140,8 @@ shellErr errmsg = do
|
|
|
|
|
-- | Execute a shell command
|
|
|
|
|
executeShell :: SExp -> StateT Env IO SExp
|
|
|
|
|
executeShell (Lambda args) = do
|
|
|
|
|
res <- (mapM toArg args) >>= return . catMaybes
|
|
|
|
|
let argsHandle = (filter isJust (map toStdIn args))
|
|
|
|
|
res <- (mapM toArg (map unFix args)) >>= return . catMaybes
|
|
|
|
|
let argsHandle = (filter isJust (map toStdIn (map unFix args)))
|
|
|
|
|
stdinhandle = case argsHandle of
|
|
|
|
|
(Just h:_) -> UseHandle h
|
|
|
|
|
_ -> Inherit
|
|
|
|
|