summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Transfer/Interpreter.hs121
-rw-r--r--src/Transfer/InterpreterAPI.hs10
-rw-r--r--transfer/run_core.hs21
3 files changed, 110 insertions, 42 deletions
diff --git a/src/Transfer/Interpreter.hs b/src/Transfer/Interpreter.hs
index 493a69c1e..03813fae8 100644
--- a/src/Transfer/Interpreter.hs
+++ b/src/Transfer/Interpreter.hs
@@ -13,19 +13,43 @@ data Value = VStr String
| VInt Integer
| VType
| VRec [(CIdent,Value)]
- | VAbs (Value -> Value)
- | VPi (Value -> Value)
+ | VClos Env PatternVariable Exp
| VCons CIdent [Value]
+ | VPrim (Value -> Value)
deriving (Show)
instance Show (a -> b) where
show _ = "<<function>>"
-type Env = [(CIdent,Value)]
+--
+-- * Environment
+--
+
+newtype Env = Env [(CIdent,Value)]
+ deriving Show
+
+mkEnv :: [(CIdent,Value)] -> Env
+mkEnv = Env
+addToEnv :: [(CIdent,Value)] -> Env -> Env
+addToEnv bs (Env e) = Env (bs ++ e)
+lookupEnv :: Env -> CIdent -> Value
+lookupEnv (Env e) id =
+ case lookup id e of
+ Just x -> x
+ Nothing -> error $ "Variable " ++ printTree id ++ " not in environment."
+ ++ " Environment contains: " ++ show (map (printTree . fst) e)
+
+prEnv :: Env -> String
+prEnv (Env e) = unlines [ printTree id ++ ": " ++ printValue v | (id,v) <- e ]
+
+-- | The built-in types and functions.
builtin :: Env
-builtin = [mkIntUn "neg" negate,
+builtin =
+ mkEnv [(CIdent "Int",VType),
+ (CIdent "String",VType),
+ mkIntUn "neg" negate,
mkIntBin "add" (+),
mkIntBin "sub" (-),
mkIntBin "mul" (*),
@@ -39,45 +63,52 @@ builtin = [mkIntUn "neg" negate,
mkIntCmp "ne" (/=)]
where
mkIntUn x f = let c = CIdent ("prim_"++x++"_Int")
- in (c, VAbs (\n -> appInt1 c (VInt . f) n))
+ in (c, VPrim (\n -> appInt1 (VInt . f) n))
mkIntBin x f = let c = CIdent ("prim_"++x++"_Int")
- in (c, VAbs (\n -> VAbs (\m -> appInt2 c (\n m -> VInt (f n m)) n m )))
+ in (c, VPrim (\n -> VPrim (\m -> appInt2 (\n m -> VInt (f n m)) n m )))
mkIntCmp x f = let c = CIdent ("prim_"++x++"_Int")
- in (c, VAbs (\n -> VAbs (\m -> appInt2 c (\n m -> toBool (f n m)) n m)))
+ in (c, VPrim (\n -> VPrim (\m -> appInt2 (\n m -> toBool (f n m)) n m)))
toBool b = VCons (CIdent (if b then "True" else "False")) []
- appInt1 c f x = case x of
+ appInt1 f x = case x of
VInt n -> f n
_ -> error $ printValue x ++ " is not an integer" -- VCons c [x]
- appInt2 c f x y = case (x,y) of
+ appInt2 f x y = case (x,y) of
(VInt n,VInt m) -> f n m
_ -> error $ printValue x ++ " and " ++ printValue y ++ " are not both integers" -- VCons c [x,y]
addModuleEnv :: Env -> Module -> Env
addModuleEnv env (Module ds) =
- let env' = [ (c,VCons c []) | DataDecl _ _ cs <- ds, ConsDecl c _ <- cs ]
- ++ [ (t,VCons t []) | DataDecl t _ _ <- ds ]
- ++ [ (x,eval env' e) | ValueDecl x e <- ds]
- ++ env
+ let bs = [ (c,VCons c []) | DataDecl _ _ cs <- ds, ConsDecl c _ <- cs ]
+ ++ [ (t,VCons t []) | DataDecl t _ _ <- ds ]
+ ++ [ (x,eval env' e) | ValueDecl x e <- ds]
+ env' = addToEnv bs env
in env'
+--
+-- * Evaluation.
+--
+
eval :: Env -> Exp -> Value
eval env x = case x of
ELet defs exp2 ->
let env' = deepSeqList [ v `seq` (id, v) | LetDef id _ e <- defs,
let v = eval env' e]
- ++ env
+ `addToEnv` env
in eval env' exp2
- ECase exp cases -> let v = eval env exp
- r = case firstMatch v cases of
- Nothing -> error $ "No pattern matched " ++ printValue v
- Just (e,bs) -> eval (bs++env) e
- in v `seq` r
- EAbs id exp -> VAbs $! (\v -> eval (bind id v ++ env) exp)
- EPi id _ exp -> VPi $! (\v -> eval (bind id v ++ env) exp)
+ ECase exp cases ->
+ let v = eval env exp
+ r = case firstMatch v cases of
+ Nothing -> error $ "No pattern matched " ++ printValue v
+ Just (e,bs) -> eval (bs `addToEnv` env) e
+ in v `seq` r
+ EAbs id exp -> VClos env id $! exp
+ -- FIXME: what to do?
+ -- EPi id _ exp -> VClos env id $! exp
EApp exp1 exp2 -> let v1 = eval env exp1
v2 = eval env exp2
in case v1 of
- VAbs f -> f $! v2
+ VClos env' id e -> eval (bind id v2 `addToEnv` env') e
+ VPrim f -> f $! v2
VCons c vs -> (VCons $! c) $! ((++) $! vs) $! [v2]
_ -> error $ "Bad application (" ++ printValue v1 ++ ") (" ++ printValue v2 ++ ")"
EProj exp id -> let v = eval env exp
@@ -88,25 +119,22 @@ eval env x = case x of
EEmptyRec -> VRec []
ERecType fts -> VRec $! deepSeqList $! [ v `seq` (f,v) | FieldType f e <- fts, let v = eval env e]
ERec fvs -> VRec $! deepSeqList $! [ v `seq` (f,v) | FieldValue f e <- fvs, let v = eval env e]
- EVar id -> case lookup id env of
- Just x -> x
- Nothing -> error $ "Variable " ++ printTree id ++ " not in environment."
- ++ " Environment contains: " ++ show (map (printTree . fst) env)
+ EVar id -> lookupEnv env id
EType -> VType
EStr str -> VStr str
EInt n -> VInt n
-firstMatch :: Value -> [Case] -> Maybe (Exp,Env)
+firstMatch :: Value -> [Case] -> Maybe (Exp,[(CIdent,Value)])
firstMatch _ [] = Nothing
firstMatch v (Case p e:cs) = case match p v of
Nothing -> firstMatch v cs
- Just env -> {- trace (show v ++ " matched " ++ show p) $ -} Just (e,env)
+ Just env -> Just (e,env)
-bind :: PatternVariable -> Value -> Env
+bind :: PatternVariable -> Value -> [(CIdent,Value)]
bind (PVVar x) v = [(x,v)]
bind PVWild _ = []
-match :: Pattern -> Value -> Maybe Env
+match :: Pattern -> Value -> Maybe [(CIdent,Value)]
match (PCons c' ps) (VCons c vs)
| c == c' = if length vs == length ps
then concatM $ zipWith match ps vs
@@ -138,11 +166,30 @@ deepSeqList :: [a] -> [a]
deepSeqList = foldr (\x xs -> x `seq` xs `seq` (x:xs)) []
--
+-- * Convert values to expressions
+--
+
+valueToExp :: Value -> Exp
+valueToExp v =
+ case v of
+ VStr s -> EStr s
+ VInt i -> EInt i
+ VType -> EType
+ VRec fs -> ERec [ FieldValue f (valueToExp v) | (f,v) <- fs]
+ VClos _ id e -> EAbs id e
+ -- FIXME: what do we do with VPi?
+ -- VPi id e -> EPi id (EVar (CIdent "_")) e -- FIXME: should be a meta variable or something
+ VCons c vs -> foldl EApp (EVar c) (map valueToExp vs)
+ VPrim _ -> EVar (CIdent "<<primitive>>") -- FIXME: what to return here?
+
+--
-- * Pretty printing of values
--
printValue :: Value -> String
-printValue v = prValue 0 0 v ""
+printValue v = printTree (valueToExp v)
+{-
+ prValue 0 0 v ""
where
prValue p n v = case v of
VStr s -> shows s
@@ -150,17 +197,19 @@ printValue v = prValue 0 0 v ""
VType -> showString "Type"
VRec cs -> showChar '{' . joinS (showChar ';')
(map prField cs) . showChar '}'
- VAbs f -> showString "<<function>>"
- {- let x = "$"++show n
- in showChar '\\' . showString (x++" -> ")
- . prValue 0 (n+1) (f (VCons (CIdent x) [])) -- hacky to use VCons
- -}
+ VAbs id e -> showString "<<function>>"
+ -- let x = "$"++show n
+ -- in showChar '\\' . showString (x++" -> ")
+ -- . prValue 0 (n+1) (f (VCons (CIdent x) [])) -- hacky to use VCons
+
VPi f -> showString "<<function type>>"
VCons c [] -> showIdent c
VCons c vs -> parenth (showIdent c . concatS (map (\v -> spaceS . prValue 1 n v) vs))
+ VPrim _ -> "<<primitive>>"
where prField (i,v) = showIdent i . showChar '=' . prValue 0 n v
parenth s = if p > 0 then showChar '(' . s . showChar ')' else s
showIdent (CIdent i) = showString i
+-}
spaceS :: ShowS
spaceS = showChar ' '
diff --git a/src/Transfer/InterpreterAPI.hs b/src/Transfer/InterpreterAPI.hs
index d78265534..2fe04e8f3 100644
--- a/src/Transfer/InterpreterAPI.hs
+++ b/src/Transfer/InterpreterAPI.hs
@@ -1,4 +1,7 @@
-module Transfer.InterpreterAPI (Env, load, loadFile, evaluateString) where
+module Transfer.InterpreterAPI (Env, builtin,
+ load, loadFile,
+ evaluateString, evaluateExp
+ ) where
import Transfer.Core.Abs
import Transfer.Core.Lex
@@ -17,6 +20,7 @@ load n s = case pModule (myLexer s) of
Ok m -> return $ addModuleEnv builtin m
-- | Read a transfer module in core format from a file.
+-- Fails in the IO monad if there is a problem loading the file.
loadFile :: FilePath -> IO Env
loadFile f = readFile f >>= load f
@@ -29,3 +33,7 @@ evaluateString env s =
Ok e -> do
let v = eval env e
return $ printValue v
+
+-- | Evaluate an expression in the given environment.
+evaluateExp :: Env -> Exp -> Exp
+evaluateExp env exp = valueToExp $ eval env exp
diff --git a/transfer/run_core.hs b/transfer/run_core.hs
index 1d0457acd..0bb7f1aa8 100644
--- a/transfer/run_core.hs
+++ b/transfer/run_core.hs
@@ -1,14 +1,22 @@
import Transfer.InterpreterAPI
+import Transfer.Interpreter (prEnv)
+import Control.Monad (when)
import Data.List (partition, isPrefixOf)
import System.Environment (getArgs)
+import System.IO (isEOF)
interpretLoop :: Env -> IO ()
-interpretLoop env = do
- line <- getLine
- r <- evaluateString env line
- putStrLn r
- interpretLoop env
+interpretLoop env =
+ do
+ eof <- isEOF
+ if eof
+ then return ()
+ else do
+ line <- getLine
+ r <- evaluateString env line
+ putStrLn r
+ interpretLoop env
runMain :: Env -> IO ()
runMain env = do
@@ -21,6 +29,9 @@ main = do args <- getArgs
env <- case files of
[f] -> loadFile f
_ -> fail "Usage: run_core [-i] <file>"
+ when ("-v" `elem` flags) $ do
+ putStrLn "Top-level environment:"
+ putStrLn (prEnv env)
if "-i" `elem` flags
then interpretLoop env
else runMain env
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:22:06 +0000