Skip to content
Permalink
54d7571f16
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
 
 
Cannot retrieve contributors at this time
80 lines (66 sloc) 2.42 KB
module Eval (call, eval1, def2let) where
import Prelude.Extra
import Data.List (sortOn)
import qualified Data.Map.Strict as Map
import Syntax
isExpr :: Stmt -> Bool
isExpr = \case
Expr _ -> True
Def _ _ -> False
TypeDecl _ -> False
def2let :: [Stmt] -> Either Text (Typed Expr)
def2let exprs = go [] $ sortOn isExpr exprs
where
go pairs = \case
[] -> Left "need at least one expr"
[Expr e] -> let (t, _) = extractType e in Right $ mkTyped t $ LetRec pairs e
(Expr _) : _ -> Left $ "can only have one expr" <> tshow exprs
(Def n1 e1) : e -> go ((n1, e1):pairs) e
(TypeDecl _) : e -> go pairs e
eval1 :: Env -> Expr -> Either Text Val
eval1 env@(Env syms) = elimThunk <=< \case
Val x -> Right x
Var x -> case Map.lookup x syms of
Nothing -> Left $ "no such var: " <> tshow x
Just v -> Right v
Let [] expr -> eval1 env (rmType expr)
Let ((n, e):bs) expr -> do
v <- eval1 env (rmType e)
eval1 (Env $ Map.insert (rmType n) v syms) (Let bs expr)
LetRec bindings expr -> do
let thunks = flip map bindings $
\(n, e) -> (rmType n, Thunk newenv (rmType e))
newenv = Env $ Map.union (Map.fromList thunks) syms
eval1 newenv (rmType expr)
Lam name expr -> Right $ Clos env (rmType name) (rmType expr)
Call f arg -> do
vf <- eval1 env (rmType f)
varg <- eval1 env (rmType arg)
call vf varg
IfMatch inE pat thenE elseE -> do
inV <- eval1 env (rmType inE)
case patternMatch (rmType pat) inV of
Nothing -> eval1 env (rmType elseE)
Just bindings -> eval1 (Env $ Map.union (Map.fromList bindings) syms) (rmType thenE)
where
elimThunk :: Val -> Either Text Val
elimThunk (Thunk newenv e) = elimThunk =<< eval1 newenv e
elimThunk x = Right x
-- | If `val` matches `pat`, return Just a list of bound variables.
patternMatch :: Pattern -> Val -> Maybe [(Name, Val)]
patternMatch pat val = case pat of
PatLiteral l -> case val of
Literal l' | l == l' -> Just []
_ -> Nothing
PatVal n -> Just [(n, val)]
PatConstr conName pats -> case val of
Tag tName vals
| tName == conName && length vals == length pats
-> fmap concat $ sequence $ zipWith (patternMatch . rmType) pats vals
_ -> Nothing
call :: Val -> Val -> Either Text Val
call (Builtin (Builtin' _ b)) a = b a
call (Clos (Env syms) param body) a = do
let syms2 = Map.insert param a syms
eval1 (Env syms2) body
call val _ = error $ "attempted to call non-closure " ++ show val