summaryrefslogtreecommitdiff
path: root/src/Transfer/Interpreter.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Transfer/Interpreter.hs')
-rw-r--r--src/Transfer/Interpreter.hs240
1 files changed, 0 insertions, 240 deletions
diff --git a/src/Transfer/Interpreter.hs b/src/Transfer/Interpreter.hs
deleted file mode 100644
index 926b7bd3a..000000000
--- a/src/Transfer/Interpreter.hs
+++ /dev/null
@@ -1,240 +0,0 @@
-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
- | VDbl Double
- | VType
- | VRec [(CIdent,Value)]
- | VClos Env Exp
- | VCons CIdent [Value]
- | VPrim (Value -> Value)
- | VMeta Integer
- deriving (Show)
-
-instance Show (a -> b) where
- show _ = "<<function>>"
-
---
--- * 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 ]
-
-seqEnv :: Env -> Env
-seqEnv (Env e) = Env $! deepSeqList [ fst p `seq` p | p <- e ]
-
--- | The built-in types and functions.
-builtin :: Env
-builtin =
- mkEnv [(CIdent "Integer",VType),
- (CIdent "Double",VType),
- (CIdent "String",VType),
- mkIntUn "neg" negate toInt,
- mkIntBin "add" (+) toInt,
- mkIntBin "sub" (-) toInt,
- mkIntBin "mul" (*) toInt,
- mkIntBin "div" div toInt,
- mkIntBin "mod" mod toInt,
- mkIntBin "eq" (==) toBool,
- mkIntBin "cmp" compare toOrd,
- mkIntUn "show" show toStr,
- mkDblUn "neg" negate toDbl,
- mkDblBin "add" (+) toDbl,
- mkDblBin "sub" (-) toDbl,
- mkDblBin "mul" (*) toDbl,
- mkDblBin "div" (/) toDbl,
- mkDblBin "mod" (\_ _ -> 0.0) toDbl,
- mkDblBin "eq" (==) toBool,
- mkDblBin "cmp" compare toOrd,
- mkDblUn "show" show toStr,
- mkStrBin "add" (++) toStr,
- mkStrBin "eq" (==) toBool,
- mkStrBin "cmp" compare toOrd,
- mkStrUn "show" show toStr
- ]
- where
- toInt i = VInt i
- toDbl i = VDbl i
- toBool b = VCons (CIdent (show b)) []
- toOrd o = VCons (CIdent (show o)) []
- toStr s = VStr s
- mkUn t a x f g = let c = CIdent ("prim_" ++ x ++ "_" ++ t)
- in (c, VPrim (\n -> a f g n))
- mkBin t a x f g = let c = CIdent ("prim_" ++ x ++ "_" ++ t)
- in (c, VPrim (\n -> VPrim (\m -> a f g n m )))
- mkIntUn = mkUn "Integer" $ \ f g x ->
- case x of
- VInt n -> g (f n)
- _ -> error $ printValue x ++ " is not an integer"
- mkIntBin = mkBin "Integer" $ \ f g x y ->
- case (x,y) of
- (VInt n,VInt m) -> g (f n m)
- _ -> error $ printValue x ++ " and " ++ printValue y
- ++ " are not both integers"
- mkDblUn = mkUn "Double" $ \ f g x ->
- case x of
- VDbl n -> g (f n)
- _ -> error $ printValue x ++ " is not a double"
- mkDblBin = mkBin "Double" $ \ f g x y ->
- case (x,y) of
- (VDbl n,VDbl m) -> g (f n m)
- _ -> error $ printValue x ++ " and " ++ printValue y
- ++ " are not both doubles"
- mkStrUn = mkUn "String" $ \ f g x ->
- case x of
- VStr n -> g (f n)
- _ -> error $ printValue x ++ " is not a string"
- mkStrBin = mkBin "String" $ \ f g x y ->
- case (x,y) of
- (VStr n,VStr m) -> g (f n m)
- _ -> error $ printValue x ++ " and " ++ printValue y
- ++ " are not both strings"
-
-addModuleEnv :: Env -> Module -> Env
-addModuleEnv env (Module ds) =
- 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' = [ (id, v) | LetDef id e <- defs,
- let v = eval env' e]
- `addToEnv` env
- in eval (seqEnv env') exp2
- ECase exp cases ->
- let v = eval env exp
- r = case firstMatch env v cases of
- Nothing -> error $ "No pattern matched " ++ printValue v
- Just (e,env') -> eval env' e
- in v `seq` r
- EAbs _ _ -> VClos env x
- EPi _ _ _ -> VClos env x
- EApp exp1 exp2 ->
- let v1 = eval env exp1
- v2 = eval env exp2
- in case v1 of
- VClos env' (EAbs 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
- in case v of
- VRec fs -> recLookup id fs
- _ -> error $ printValue v ++ " is not a record, "
- ++ "cannot get field " ++ printTree id
-
- 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 -> lookupEnv env id
- EType -> VType
- EStr str -> VStr str
- EInteger n -> VInt n
- EDouble n -> VDbl n
- EMeta (TMeta t) -> VMeta (read $ drop 1 t)
-
-firstMatch :: Env -> Value -> [Case] -> Maybe (Exp,Env)
-firstMatch _ _ [] = Nothing
-firstMatch env v (Case p g e:cs) =
- case match p v of
- Nothing -> firstMatch env v cs
- Just bs -> let env' = bs `addToEnv` env
- in case eval env' g of
- VCons (CIdent "True") [] -> Just (e,env')
- VCons (CIdent "False") [] -> firstMatch env v cs
- x -> error $ "Error in guard: " ++ printValue x
- ++ " is not a Bool"
-
-bind :: PatternVariable -> Value -> [(CIdent,Value)]
-bind (PVVar x) v = [(x,v)]
-bind PVWild _ = []
-
-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
- 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 (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)) []
-
---
--- * Convert values to expressions
---
-
-valueToExp :: Value -> Exp
-valueToExp v =
- case v of
- VStr s -> EStr s
- VInt i -> EInteger i
- VDbl i -> EDouble i
- VType -> EType
- VRec fs -> ERec [ FieldValue f (valueToExp v) | (f,v) <- fs]
- VClos env e -> e
- VCons c vs -> foldl EApp (EVar c) (map valueToExp vs)
- VPrim _ -> EVar (CIdent "<<primitive>>") -- FIXME: what to return here?
- VMeta n -> EMeta $ TMeta $ "?" ++ show n
-
---
--- * Pretty printing of values
---
-
-printValue :: Value -> String
-printValue v = printTree (valueToExp v)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:15:22 +0000