module Ntha.Runtime.Eval where import Ntha.Core.Ast import Ntha.Runtime.Value import Data.Maybe (fromMaybe) import Prelude hiding (lookup) import qualified Data.Map as M import qualified Data.Set as S type Exclude = S.Set EName evalFn :: Value -> Value -> ValueScope -> Value evalFn (Fn f) arg scope = f arg scope evalFn _ _ _ = VUnit chainingFn :: EName -> Value -> Value chainingFn argName next = Fn (\oarg _ -> Fn (\arg scope -> let margs = case oarg of FnApArgs pairs -> let v = fromMaybe VUnit $ M.lookup "***" pairs in FnApArgs $ M.insert "***" arg $ M.insert argName v pairs _ -> FnApArgs $ M.fromList [(argName, oarg), ("***", arg)] in evalFn next margs scope)) chaininLastFn :: EName -> [Expr] -> Value chaininLastFn argName body = Fn (\arg scope -> let scope' = case arg of FnApArgs pairs -> foldl (\env (k, v) -> insert k v env) scope (M.toList $ M.insert argName (fromMaybe VUnit $ M.lookup "***" pairs) pairs) _ -> insert argName arg scope in snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) body) destrChainingFn :: Pattern -> Value -> Value destrChainingFn pat next = Fn (\oarg _ -> Fn (\arg scope -> let margs = case oarg of DestrFnApArgs args freeVal -> DestrFnApArgs (args ++ [PatVal pat freeVal]) arg _ -> DestrFnApArgs [PatVal pat oarg] arg in evalFn next margs scope)) destrChaininLastFn :: Pattern -> [Expr] -> Value destrChaininLastFn pat body = Fn (\arg scope -> let scope' = case arg of DestrFnApArgs args freeVal -> let s = foldl (\env (PatVal pat' val) -> define pat' val env) scope args in define pat freeVal s _ -> define pat arg scope in snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) body) tConChainingFn :: Tag -> Value -> Value tConChainingFn tag next = Fn (\oarg _ -> Fn (\arg scope -> let targs = case oarg of TConArgs args tag' -> TConArgs (args ++ [arg]) tag' _ -> TConArgs [oarg, arg] tag in evalFn next targs scope)) tConChaininLastFn :: Tag -> Value tConChaininLastFn tag = Fn (\arg _ -> let args = case arg of TConArgs args' _ -> args' VUnit -> [] _ -> [arg] in Adt tag args) excludePatternBoundNames :: Pattern -> Exclude -> Exclude excludePatternBoundNames pat excluded = case pat of IdPattern name -> S.insert name excluded TuplePattern pats -> foldl (\exc p -> excludePatternBoundNames p exc) excluded pats TConPattern _ pats -> foldl (\exc p -> excludePatternBoundNames p exc) excluded pats _ -> excluded visit :: Expr -> ValueScope -> ValueEnv -> Exclude -> (ValueScope, ValueEnv, Exclude) visit expr scope capturedEnv excluded = case expr of EList values -> foldl (\(s, c, e) value -> visit value s c e) (scope, capturedEnv, excluded) values EIf cond thenInstrs elseInstrs -> (sco'', env'', exc'') where (sco, env, exc) = visit cond scope capturedEnv excluded (sco', env', exc') = foldl (\(s, c, e) value -> visit value s c e) (sco, env, exc) thenInstrs (sco'', env'', exc'') = foldl (\(s, c, e) value -> visit value s c e) (sco', env', exc') elseInstrs EVar name -> if name `notElem` excluded then let (scope', val) = eval expr scope in (scope', M.insert name val capturedEnv, excluded) else (scope, capturedEnv, excluded) EApp fn arg -> let (s, c, e) = visit fn scope capturedEnv excluded in visit arg s c e EDestructLetBinding main _ _ -> (scope, capturedEnv, excludePatternBoundNames main excluded) EPatternMatching input cases -> let (scope', capturedEnv', excluded') = visit input scope capturedEnv excluded in foldl (\(s, c, e) (Case pat outcomes) -> let e' = excludePatternBoundNames pat e in let (s', c', _) = foldl (\(sco, env, exc) instr -> visit instr sco env exc) (s, c, e') outcomes in (s', c', e)) (scope', capturedEnv', excluded') cases _ -> (scope, capturedEnv, excluded) envCapturingFnWrapper :: Value -> Expr -> ValueScope -> Value envCapturingFnWrapper fn expr scope = case expr of (ELambda params _ instrs) -> mkFn capturedEnv where excluded = foldl (\exc (Named name _) -> S.insert name exc) S.empty params capturedEnv = mkCapturedEnv excluded instrs (EDestructLetBinding (IdPattern name) args instrs) -> mkFn capturedEnv where excluded = foldl (\exc pat -> excludePatternBoundNames pat exc) (S.singleton name) args capturedEnv = mkCapturedEnv excluded instrs _ -> VUnit where mkCapturedEnv excluded instrs = let (_, capturedEnv, _) = foldl (\(s, c, e) instr -> visit instr s c e) (scope, M.empty, excluded) instrs in capturedEnv mkFn capturedEnv = Fn (\arg scope' -> let scope'' = foldl (\env (k, v) -> insert k v env) scope' $ M.toList capturedEnv in evalFn fn arg scope'') -- to predicate if a value is match specific pattern match :: Value -> Pattern -> ValueScope -> (ValueScope, Bool) match input pattern scope = case pattern of WildcardPattern -> (scope, True) IdPattern name -> (insert name input scope, True) NumPattern val -> (scope, input == (VNum val)) BoolPattern val -> (scope, input == (VBool val)) CharPattern val -> (scope, input == (VChar val)) TuplePattern pats -> case input of VTuple items -> if length items /= length pats then (scope, False) else isAllMatch items pats _ -> (scope, False) TConPattern name pats -> case input of Adt tag args -> if name == tag && length pats == length args then isAllMatch args pats else (scope, False) _ -> (scope, False) where isAllMatch items pats = let (scope', isMatchs) = foldl (\(env, matchs) (item, pat) -> let (env', isMatch) = match item pat env in (env', matchs ++ [isMatch])) (scope, []) $ zip items pats in (scope', all id isMatchs) define :: Pattern -> Value -> ValueScope -> ValueScope define pattern val scope = case pattern of IdPattern name -> insert name val scope TuplePattern pats -> case val of VTuple items -> defineVals pats items _ -> error $ "Invalid value " ++ show val ++ " for pattern " ++ show pattern -- maybe should check pattern name and length of pats and args just like the match function above TConPattern _ pats -> case val of Adt _ args -> defineVals pats args _ -> error $ "Invalid value " ++ show val ++ " for pattern " ++ show pattern _ -> scope where defineVals pats items = foldl (\env (pat, item) -> define pat item env) scope $ zip pats items eval :: Expr -> ValueScope -> (ValueScope, Value) eval expr scope = case expr of ENum v -> (scope, VNum v) EBool v -> (scope, VBool v) EChar v -> (scope, VChar v) EStr v -> (scope, makeList $ map VChar v) EUnit -> (scope, VUnit) EVar name -> case lookup name scope of Just val -> (scope, val) Nothing -> error $ "Unknown identifier " ++ show expr EAccessor obj field -> case eval obj scope of (_, VRecord pairs) -> case M.lookup field pairs of Just val -> (scope, val) Nothing -> error $ "No field " ++ field ++ "in "++ show obj _ -> error $ "Not a record " ++ show obj ETuple values -> (scope, VTuple $ map (\v -> snd (eval v scope)) values) EList values -> (scope, makeList $ map (\v -> snd (eval v scope)) values) ERecord pairs -> (scope, VRecord $ M.map (\v -> snd (eval v scope)) pairs) ELambda params _ instrs -> let fnV = case reverse params of (Named name _):xs -> fnChain where lastFn = chaininLastFn name instrs fnChain = foldl (\fn (Named n _) -> chainingFn n fn) lastFn xs _ -> VUnit in (scope, envCapturingFnWrapper fnV expr scope) EApp fn arg -> case fnV of Fn f -> let (_, argV) = eval arg scope' in (scope, f argV scope') Adt _ _ -> case eval arg scope' of (_, VUnit) -> (scope, fnV) _ -> error $ "Error while evaluating " ++ show expr ++ ": " ++ show fnV ++ " constructor doesn't take arguments" _ -> error $ "Error while evaluating " ++ show expr ++ ": " ++ show fnV ++ " is not a function" where scope' = child scope (_, fnV) = eval fn scope' EIf cond thenInstrs elseInstrs -> let (_, condV) = eval cond scope in case condV of VBool v -> if v then (scope, evalInstrs thenInstrs) else (scope, evalInstrs elseInstrs) where evalInstrs instrs = let scope' = child scope in snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) instrs _ -> error $ "Error while evaluating " ++ show expr ++ ": the condition is not a boolean" EPatternMatching input cases -> findPattern inputV cases where (_, inputV) = eval input scope findPattern :: Value -> [Case] -> (ValueScope, Value) findPattern val [] = error $ "Match exception: " ++ show input ++ " = " ++ show val ++ " didn't match any case of " ++ show expr findPattern val ((Case pat instrs):cs) = let (scope', isMatch) = match val pat $ child scope in if isMatch then (scope, snd $ foldl (\(env, val') instr -> val' `seq` eval instr env) (scope', VUnit) instrs) else findPattern val cs ELetBinding name def body -> let (scope', _) = eval (EDestructLetBinding name [] [def]) scope in (scope, snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) body) EDestructLetBinding main args instrs -> if length args == 0 -- define variable then let (_, val) = foldl (\(env, val') instr -> val' `seq` eval instr env) (child scope, VUnit) instrs in (define main val scope, val) -- define function else case main of IdPattern name -> let fnV = case reverse args of pat:pats -> fnChain where lastFn = destrChaininLastFn pat instrs fnChain = foldl (\fn p -> destrChainingFn p fn) lastFn pats _ -> VUnit in let fn = envCapturingFnWrapper fnV expr scope in (insert name fn scope, fn) _ -> error $ "Function name can only be a name, whereas a pattern " ++ show main ++ " was provided in " ++ show expr EDataDecl _ _ _ typeConstructors -> let scope' = foldl makeChain scope typeConstructors in (scope', VUnit) where makeChain env (TypeConstructor name types) = let fnV = case reverse types of _:ts -> fnChain where lastFn = tConChaininLastFn name fnChain = foldl (\fn _ -> tConChainingFn name fn) lastFn ts _ -> VUnit in if fnV == VUnit then insert name (Adt name []) env else insert name fnV env ETypeSig _ _ -> (scope, VUnit) EProgram instrs -> foldl (\(env, val) instr -> val `seq` eval instr env) (child scope, VUnit) instrs _ -> error $ "not support eval expr: " ++ show expr