GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-18 01:09:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
bringert
2005-11-25 18:02:36 +00:00
parent 638826db35
commit 0fc7c76717
3 changed files with 110 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

121
src/Transfer/Interpreter.hs
View File

@@ -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
@@ -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>>"
{- 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 ' '

10
src/Transfer/InterpreterAPI.hs
View File

@@ -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

21
transfer/run_core.hs
View File

@@ -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