>
> module Epic.Evaluator(eval) where
> import Epic.Language
> import Debug.Trace
Assume all expressions are in HOAS form - if we see any Vs, or any Updates
then we have an error. Returns expression in standard form.
> eval :: [EvalDecl] -> Expr -> Expr
> eval ctx e = case ev e of
> Nothing -> quote 0 e
> Just e' -> quote 0 e'
> where
> ev (R n) = case lookupD n ctx of
> Just e' -> ev e'
> Nothing -> return $ R n
> ev (V i) = return $ V i
> ev (App f xs) = do f' <- ev f
> xs' <- mapM ev xs
> evFn f' xs'
> ev (Lazy e) = ev e
> ev (Par e) = ev e
> ev (Effect e) = ev e
> ev (Con t es) = do es' <- mapM ev es
> return $ Con t es'
> ev (Proj e i) = do e' <- ev e
> return $ project e' i
> ev (Case e alts) = do e' <- ev e
> docase e' alts
> ev (If x t e) = do x' <- ev x
> case x of
> Const (MkInt 0) -> ev e
> _ -> ev t
> ev (While _ _) = fail "Can't evaluate while"
> ev (WhileAcc _ _ _) = fail "Can't evaluate while"
> ev (Op op x y) = do x' <- ev x
> y' <- ev y
> case (x', y') of
> (Const xv, Const yv) -> return $ doOp op xv yv
> _ -> return $ Op op x' y'
> ev (Let _ _ _ _) = fail "Not in HOAS form (let)"
> ev (LetM _ _ _) = fail "Can't do updates"
> ev (HLet n ty val sc) = do val' <- ev val
> ev (sc val')
> ev (HLam n ty sc) = do let sc' = \x -> case ev (sc x) of
> Nothing -> sc x
> Just v -> v
> return $ HLam n ty sc'
> ev (WithMem a t e) = ev e
> ev (ForeignCall t str args)
> = do args' <- mapM ev (map fst args)
> return $ ForeignCall t str (zip args' (map snd args))
> ev (LazyForeignCall t str args)
> = do args' <- mapM ev (map fst args)
> return $ LazyForeignCall t str (zip args' (map snd args))
> ev x = return x
> evFn (HLam n t sc) (a:as) = do a' <- ev (sc a)
> evFn a' as
> evFn f [] = ev f
> evFn f as = return $ App f as
> docase c@(Con t as) alts = case fConAlt t as alts of
> Just rhs -> ev rhs
> Nothing -> return $ Case c alts
> docase c@(Const (MkInt i)) alts
> = case fConstAlt i alts of
> Just rhs -> ev rhs
> Nothing -> return $ Case c alts
> docase c alts = return $ Case c alts
> fConAlt :: Int -> [Expr] -> [CaseAlt] -> Maybe Expr
> fConAlt t args (HAlt t' n rhs : _)
> | t == t' && n == length args =
> substRHS args rhs
> where
> substRHS [] (HExp rhs) = return rhs
> substRHS (x:xs) (HBind n ty rhsf) = substRHS xs (rhsf x)
> fConAlt t args (DefaultCase e : _) = return e
> fConAlt t args (_:xs) = fConAlt t args xs
> fConAlt t args _ = Nothing
> fConstAlt :: Int -> [CaseAlt] -> Maybe Expr
> fConstAlt t (ConstAlt t' rhs:_)
> | t == t' = return rhs
> fConstAlt t (DefaultCase e : _) = return e
> fConstAlt t (_:xs) = fConstAlt t xs
> fConstAlt t _ = Nothing
> doOp Plus (MkInt x) (MkInt y) = Const $ MkInt (x+y)
> doOp Minus (MkInt x) (MkInt y) = Const $ MkInt (xy)
> doOp Times (MkInt x) (MkInt y) = Const $ MkInt (x*y)
> doOp Divide (MkInt x) (MkInt y) = Const $ MkInt (x `div` y)
> doOp Modulo (MkInt x) (MkInt y) = Const $ MkInt (x `mod` y)
> doOp OpEQ (MkInt x) (MkInt y) = bint (x==y)
> doOp OpLT (MkInt x) (MkInt y) = bint (x<y)
> doOp OpLE (MkInt x) (MkInt y) = bint (x<=y)
> doOp OpGT (MkInt x) (MkInt y) = bint (x>y)
> doOp OpGE (MkInt x) (MkInt y) = bint (x>=y)
> doOp FPlus (MkFloat x) (MkFloat y) = Const $ MkFloat (x+y)
> doOp FMinus (MkFloat x) (MkFloat y) = Const $ MkFloat (xy)
> doOp FTimes (MkFloat x) (MkFloat y) = Const $ MkFloat (x*y)
> doOp FDivide (MkFloat x) (MkFloat y) = Const $ MkFloat (x/y)
> doOp OpFEQ (MkFloat x) (MkFloat y) = bint (x==y)
> doOp OpFLT (MkFloat x) (MkFloat y) = bint (x<y)
> doOp OpFLE (MkFloat x) (MkFloat y) = bint (x<=y)
> doOp OpFGT (MkFloat x) (MkFloat y) = bint (x>y)
> doOp OpFGE (MkFloat x) (MkFloat y) = bint (x>=y)
> doOp op x y = Op op (Const x) (Const y)
> bint True = Const $ MkInt 1
> bint False = Const $ MkInt 0
> project :: Expr -> Int -> Expr
> project (Con t as) i | i < length as = as!!i
> project e i = Proj e i
> lookupD n [] = Nothing
> lookupD n (EDecl en def:xs) | n == en = Just def
> lookupD n (_:xs) = lookupD n xs
> class Quote a where
> quote :: Int -> a -> a
> instance Quote a => Quote [a] where
> quote l = map (quote l)
> instance Quote a => Quote (a, Type) where
> quote l (x,t) = (quote l x, t)
> instance Quote Expr where
> quote v (App x xs) = App (quote v x) (quote v xs)
> quote v (Lazy x) = Lazy (quote v x)
> quote v (Par x) = Par (quote v x)
> quote v (Effect x) = Effect (quote v x)
> quote v (Con t xs) = Con t (quote v xs)
> quote v (Proj x i) = Proj (quote v x) i
> quote v (Case e as) = Case (quote v e) (quote v as)
> quote v (If x y z) = If (quote v x) (quote v y) (quote v z)
> quote v (While x y) = While (quote v x) (quote v y)
> quote v (WhileAcc x y z) = WhileAcc (quote v x) (quote v y) (quote v z)
> quote v (Op o x y) = Op o (quote v x) (quote v y)
> quote v (HLam n ty fn) = Lam n ty (quote (v+1) (fn (V v)))
> quote v (WithMem a x y) = WithMem a (quote v x) (quote v y)
> quote v (ForeignCall t s xs) = ForeignCall t s (quote v xs)
> quote v (LazyForeignCall t s xs) = LazyForeignCall t s (quote v xs)
> quote v x = x
> instance Quote CaseAlt where
> quote v (HAlt t n rhs) = buildRHS v t [] rhs where
> buildRHS v t acc (HExp e) = Alt t (reverse acc) (quote v e)
> buildRHS v t acc (HBind n ty rhs)
> = buildRHS (v+1) t ((n,ty):acc) (rhs (V v))
> quote v (ConstAlt c e) = ConstAlt c (quote v e)
> quote v (DefaultCase e) = DefaultCase (quote v e)