Move transfer into the GF repo.

1 files changed, 169 insertions, 0 deletions

diff --git a/src/Transfer/Interpreter.hs b/src/Transfer/Interpreter.hs
new file mode 100644
index 000000000..493a69c1e
--- /dev/null
+++ b/src/Transfer/Interpreter.hs
@@ -0,0 +1,169 @@
+module Transfer.Interpreter where
+
+import Transfer.Core.Abs
+import Transfer.Core.Print
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+
+import Debug.Trace
+
+data Value = VStr String
+           | VInt Integer
+           | VType
+           | VRec [(CIdent,Value)]
+           | VAbs (Value -> Value)
+           | VPi (Value -> Value)
+           | VCons CIdent [Value]
+  deriving (Show)
+
+instance Show (a -> b) where
+    show _ = "<<function>>"
+
+type Env = [(CIdent,Value)]
+
+
+builtin :: Env
+builtin = [mkIntUn  "neg" negate,
+           mkIntBin "add" (+),
+           mkIntBin "sub" (-),
+           mkIntBin "mul" (*),
+           mkIntBin "div" div,
+           mkIntBin "mod" mod,
+           mkIntCmp "lt"  (<),
+           mkIntCmp "le"  (<=),
+           mkIntCmp "gt"  (>),
+           mkIntCmp "ge"  (>=),
+           mkIntCmp "eq"  (==),
+           mkIntCmp "ne"  (/=)]
+  where 
+  mkIntUn x f = let c = CIdent ("prim_"++x++"_Int")
+                 in (c, VAbs (\n -> appInt1 c (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 )))
+  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)))
+  toBool b = VCons (CIdent (if b then "True" else "False")) []
+  appInt1 c 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
+                         (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
+     in env'
+
+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
+       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)
+  EApp exp1 exp2 -> let v1 = eval env exp1
+                        v2 = eval env exp2
+                     in case v1 of
+                               VAbs 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
+                    in case v of
+                               VRec fs -> recLookup id fs
+                               _ -> error $ printValue v ++ " is not a record, cannot get field " ++ printTree id
+
+  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)
+  EType  -> VType
+  EStr str  -> VStr str
+  EInt n  -> VInt n
+
+firstMatch :: Value -> [Case] -> Maybe (Exp,Env)
+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)
+
+bind :: PatternVariable -> Value -> Env
+bind (PVVar x) v = [(x,v)]
+bind PVWild _ = []
+
+match :: Pattern -> Value -> Maybe Env
+match (PCons c' ps) (VCons c vs) 
+    | c == c' = if length vs == length ps 
+                 then concatM $ zipWith match ps vs
+                 else error $ "Wrong number of arguments to " ++ printTree c
+match (PVar x) v                   = Just (bind x v)
+match (PRec fps) (VRec fs) = concatM [ match p (recLookup f fs) | FieldPattern f p <- fps ]
+match (PInt i) (VInt i') | i == i' = Just []
+match PType VType                  = Just []
+match (PStr s) (VStr s') | s == s' = Just []
+match (PInt i) (VInt i') | i == i' = Just []
+match _ _ = Nothing
+
+
+recLookup :: CIdent -> [(CIdent,Value)] -> Value
+recLookup l fs = 
+    case lookup l fs of
+        Just x -> x
+        Nothing -> error $ printValue (VRec fs) ++ " has no field " ++ printTree l
+
+--
+-- * Utilities
+--
+
+concatM :: Monad m => [m [a]] -> m [a]
+concatM = liftM concat . sequence
+
+-- | Force a list and its values.
+deepSeqList :: [a] -> [a]
+deepSeqList = foldr (\x xs -> x `seq` xs `seq` (x:xs)) []
+
+--
+-- * Pretty printing of values
+--
+
+printValue :: Value -> String
+printValue v = prValue 0 0 v ""
+  where
+  prValue p n v = case v of
+              VStr s     -> shows s
+              VInt i     -> shows i
+              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
+                             -}
+              VPi f      -> showString "<<function type>>"
+              VCons c [] -> showIdent c
+              VCons c vs -> parenth (showIdent c . concatS (map (\v -> spaceS . prValue 1 n v) vs))
+   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 ' '
+
+joinS :: ShowS -> [ShowS] -> ShowS
+joinS glue = concatS . intersperse glue