Added evaluateExp and builtin to InterpreterAPI. Check for EOF in interactive transfer interpreter mode.

src/Transfer/Interpreter.hs

@@ -13,19 +13,43 @@ data Value = VStr String
            | VInt Integer
            | VType
            | VRec [(CIdent,Value)]
-           | VAbs (Value -> Value)
+           | VClos Env PatternVariable Exp
-           | VPi (Value -> Value)
            | 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 ] 
+    let bs = [ (c,VCons c []) | DataDecl _ _ cs <- ds, ConsDecl c _ <- cs ] 
-              ++ [ (t,VCons t []) | DataDecl t _  _ <- ds ] 
+             ++ [ (t,VCons t []) | DataDecl t _  _ <- ds ] 
-              ++ [ (x,eval env' e) | ValueDecl x e <- ds]
+             ++ [ (x,eval env' e) | ValueDecl x e <- ds]
-              ++ env
+        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
+  ECase exp cases -> 
-                          r = case firstMatch v cases of
+      let v = eval env exp
-                                  Nothing -> error $ "No pattern matched " ++ printValue v
+          r = case firstMatch v cases of
-                                  Just (e,bs) -> eval (bs++env) e
+                  Nothing -> error $ "No pattern matched " ++ printValue v
-                         in v `seq` r
+                  Just (e,bs) -> eval (bs `addToEnv` env) e
-  EAbs id exp  -> VAbs $! (\v -> eval (bind id v ++ env) exp)
+       in v `seq` r
-  EPi id _ exp  -> VPi $! (\v -> eval (bind id v ++ env) exp)
+  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
+  EVar id  -> lookupEnv env id
-                    Just x -> x
-                    Nothing -> error $ "Variable " ++ printTree id ++ " not in environment."
-                                       ++ " Environment contains: " ++ show (map (printTree . fst) env)
   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
@@ -137,12 +165,31 @@ concatM = liftM concat . sequence
 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>>"
+              VAbs id e  -> showString "<<function>>"
-                            {- let x = "$"++show n
+                            -- let x = "$"++show n
-                             in showChar '\\' . showString (x++" -> ") 
+                            -- in showChar '\\' . showString (x++" -> ") 
-                                    . prValue 0 (n+1) (f (VCons (CIdent x) [])) -- hacky to use VCons
+                            --        . 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 ' '

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

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    
+interpretLoop env = 
-                    line <- getLine
+    do
-                    r <- evaluateString env line
+    eof <- isEOF
-                    putStrLn r
+    if eof
-                    interpretLoop env
+       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