Simple4: records

Simple4/Interpreter.hs

@@ -0,0 +1,272 @@
+{-# LANGUAGE MultiParamTypeClasses, NamedFieldPuns #-}
+-- Tiny3.Interpreter2 extended with if and let
+
+module Simple4.Interpreter where
+import Simple4.Syntax
+
+import qualified Data.Map as Map
+import Control.Monad.Error
+import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Identity
+import Data.Maybe(catMaybes)
+
+data IntState = IntState { 
+  store :: Store, 
+  freeLocs :: [Loc], 
+  env :: Env,
+  scopes :: Scopes}
+
+initState = IntState initStore initFreeLocs initEnv initScopes
+
+type IM a = StateT IntState (ErrorT String IO) a
+runIM :: IM a -> IntState -> IO (Either String (a,IntState))
+runIM m st = runErrorT (runStateT m st)
+
+runProg :: Defs -> IO ()
+runProg p = do
+  res <- runIM (evalDefs p) initState
+  case res of
+    Left e -> putStrLn e
+    Right (a,state) -> do
+      print a
+      printState state
+
+printState :: IntState -> IO ()
+printState state = do
+  putStr "Env: "
+  printEnv (env state)
+  putStr "Store: "
+  print $ Map.toAscList (store state)
+
+-- * Values
+
+data Val = VInt Integer | VLoc Loc | VNone | VRec Record
+         deriving (Eq) 
+type Record = (Map.Map Name Val)
+
+instance Show Val where
+  show (VInt n) = show n
+  show (VLoc l) = "loc:"++show l
+  show VNone = "None"
+  show (VRec map) =  show $ Map.toAscList map
+
+getVInt :: Val -> IM Integer
+getVInt (VInt i) = return i
+getVInt v = throwError $ "Not an integer: "++show v
+
+getVLoc :: Val -> IM Loc
+getVLoc (VLoc l) = return l
+getVLoc v = throwError $ "Not a loc: "++show v
+
+getVRec :: Val -> IM Record
+getVRec (VRec r) = return r
+getVRec v = throwError $ "Not a record: "++show v
+
+isTrueVal :: Val -> Bool
+isTrueVal (VInt 0) = False
+isTrueVal (VInt _) = True
+isTrueVal (VLoc _) = True
+isTrueVal (VNone)  = False
+isTrueVal (VRec r) = not $ Map.null r
+-- * Store    
+
+type Loc = Int
+type Store = Map.Map Loc Val
+initStore :: Store
+initStore = Map.empty
+
+alloc :: IM Loc
+alloc = do
+  locs <- getFreeLocs
+  case locs of
+    [] -> throwError "alloc: no more free locs"
+    (l:ls) -> putFreeLocs ls >> return l
+
+free :: Loc -> IM ()
+free l = do 
+  ls <- getFreeLocs
+  putFreeLocs (l:ls)
+
+updateStore :: Loc -> Val -> IM ()
+updateStore v x = modify $ \state -> state { 
+  store = Map.insert v x (store state)}
+
+getStore :: IM Store  
+getStore = gets store
+
+getLocContents :: Loc -> IM Val
+getLocContents loc = do
+  store <- getStore 
+  let res  = Map.lookup loc store
+  maybe (throwError $ "Unknown loc: "++ show loc) return res
+
+initFreeLocs :: [Loc]
+initFreeLocs = [1..2^16]
+
+getFreeLocs :: IM [Loc]
+getFreeLocs = gets freeLocs
+
+putFreeLocs :: [Loc] -> IM ()
+putFreeLocs freeLocs = modify $ \r -> r { freeLocs }
+
+-- * Names and Environment
+type Env = Map.Map Name [Loc]  -- a map name -> loc stack
+initEnv :: Env
+initEnv = Map.empty
+
+printEnv :: Env -> IO ()
+printEnv env = print $ Map.toAscList env
+
+type Scope = [Name]
+type Scopes = [Scope]
+
+emptyScope = []
+initScopes = [emptyScope]
+
+getEnv :: IM Env
+getEnv = gets env
+
+putEnv :: Env -> IM ()
+putEnv env = modify $ \r -> r { env }
+
+modifyEnv :: (Env -> Env) -> IM ()
+modifyEnv f = getEnv >>= putEnv . f
+
+getScopes ::  IM Scopes
+getScopes = gets scopes
+
+putScopes :: Scopes -> IM ()
+putScopes scopes = modify $ \r -> r { scopes }
+
+modifyScopes :: (Scopes -> Scopes) -> IM ()
+modifyScopes f = getScopes >>= putScopes . f
+
+popScope :: IM Scope
+popScope = do
+  (scope:scopes) <- getScopes
+  putScopes scopes
+  return scope
+
+enterScope :: IM ()
+enterScope = modifyScopes (emptyScope:)
+
+leaveScope :: IM ()
+leaveScope = do
+  env <- getEnv
+  scope <- popScope
+  let scopeLocs = catMaybes $ map (flip lookupEnv env) scope
+  mapM_ free scopeLocs
+  let env' = foldr (\n e -> Map.update pop n e)env scope
+  putEnv env' where
+    pop :: [Loc] -> Maybe [Loc]
+    pop [x] = Nothing
+    pop (x:xs) = Just xs
+
+createVar :: Name -> IM Loc
+createVar n = do
+     l <- alloc
+     modifyEnv (updateEnv n l)
+     modifyScopes (addLocal n)
+     return l
+
+addLocal :: Name -> Scopes -> Scopes
+addLocal n (h:t) =(n:h):t 
+addLocal n [] = []
+
+lookupEnv :: Name -> Env -> Maybe Loc
+lookupEnv n e = do
+  stack <- Map.lookup n e 
+  case stack of
+    [] -> Nothing
+    (l:_) -> return l
+
+updateEnv :: Name -> Loc -> Env -> Env
+updateEnv n l = Map.insertWith (++) n [l] 
+
+getNameLoc :: Name -> IM Loc
+getNameLoc n =  do
+  env <- getEnv
+  let res  = lookupEnv n env
+  maybe (throwError $ unwords["Undefined var",n,"env is",show env]) return res
+
+getVar :: Name -> IM Val
+getVar v =  do
+  l <- getNameLoc v
+  getLocContents l
+
+-- | Evaluate expressions
+eval :: Exp -> IM Val
+eval (EInt i) = return (VInt i)
+eval (EVar s) = getVar s
+eval (EAdd e1 e2) = do -- liftM2 (+) (eval e1) (eval e2)
+  i1 <- getVInt =<< eval e1 
+  i2 <- getVInt =<< eval e2
+  return $ VInt (i1+i2)                  
+eval (EIf e1 e2 e3) = do
+     v1 <- eval e1
+     if isTrueVal v1 then eval e2 else eval e3
+eval (ELet "_" e1 e0) = eval e1 >> eval e0
+eval (ELet n e1 e0) = do
+     enterScope
+     execDef n e1
+     v0 <- eval e0
+     leaveScope
+     return v0
+eval (ELets ds e0) = do
+     enterScope
+     execDefs ds
+     v0 <- eval e0
+     leaveScope
+     return v0
+eval (ENew e) = do     
+     v <- eval e
+     l <- alloc
+     updateStore l v
+     return $ VLoc l
+eval (EDeref e) = do
+  v <- eval e
+  l <- getVLoc v
+  getLocContents l
+eval ERecEmpty = return $ VRec Map.empty
+eval (EGet n1 n2) = do
+   vl <- getVar n1
+   l  <- getVLoc vl
+   vr <- getLocContents l
+   r <- getVRec vr
+   maybe (throwError $ unwords [show r,"has no field",n2]) 
+         return
+         (getFieldVal n2 r)
+eval (ESet n1 n2 e) = do
+  vl <- getVar n1
+  l  <- getVLoc vl
+  vr <- getLocContents l
+  r <- getVRec vr
+  v <- eval e
+  updateStore l (VRec (Map.insert n2 v r))
+  return v
+eval ENone = return VNone
+
+getFieldVal :: Name -> Record -> Maybe Val
+getFieldVal n r= Map.lookup n r
+
+execDef :: Name -> Exp -> IM ()
+execDef n e = do
+  v <- eval e
+  l <- createVar n
+  updateStore l v
+
+execDefs :: [(Name,Exp)] -> IM ()
+execDefs  [] = return ()
+execDefs ((n,e):ds) = execDef n e >> execDefs ds
+
+evalDef :: Name -> Exp -> IM Val
+evalDef n e = do
+  v <- eval e
+  l <- createVar n
+  updateStore l v
+  return v
+
+evalDefs :: [(Name,Exp)] -> IM Val
+evalDefs  [(n,e)] = evalDef n e
+evalDefs ((n,e):ds) = evalDef n e >> evalDefs ds

Simple4/ParsecParser.hs

@@ -0,0 +1,82 @@
+module Simple4.ParsecParser where
+import Simple4.Syntax
+import Data.Functor
+import Control.Monad
+import Control.Monad.Error
+
+import Text.ParserCombinators.Parsec
+import qualified Text.ParserCombinators.Parsec.Token as PT
+import Text.ParserCombinators.Parsec.Language(emptyDef)
+
+langDef = emptyDef { 
+  PT.reservedNames = ["let", "in", "new", "None",
+                      "if","then","else"]}
+lexer = PT.makeTokenParser langDef
+
+identifier = PT.identifier lexer
+integer = PT.integer lexer
+symbol = PT.symbol lexer
+parens  = PT.parens lexer
+reserved = PT.reserved lexer
+kw = reserved
+
+runParser :: String -> String -> Either ParseError Defs
+runParser info input = parse pProg info input
+
+pProg :: Parser Defs
+pProg = pDefs
+
+pDefs :: Parser Defs
+pDefs = many1 pDef
+
+pDef :: Parser Def
+pDef = do
+  v <- identifier
+  foo <- symbol "="
+  e <- pExp
+  return $ (v, e)
+
+pExp, pTerm, pF :: Parser Exp
+pExp = pIf <|> pNew <|> pLet <|> pArith 
+
+pIf = do
+  kw "if"
+  e1 <- pExp
+  kw "then"
+  e2 <- pExp
+  kw "else"
+  e3 <- pExp
+  return $ EIf e1 e2 e3
+
+pLet :: Parser Exp
+pLet = do
+  kw "let" 
+  ds <- pDefs 
+  kw "in"
+  e <- pExp
+  return $ ELets ds e
+
+pNew = ENew <$> (kw "new" >> pExp)
+
+pArith :: Parser Exp
+pArith = pTerm `chainl1` pAdd
+
+pAdd = symbol "+" >> return EAdd
+
+pTerm = pF
+pF = EInt <$> integer <|> pIdExp <|> parens pExp 
+          <|> EDeref <$> (EVar <$> (symbol "*" >> identifier))
+          <|> pRec <|> (kw "None" >> return ENone)
+pRec = symbol "{" >> symbol "}" >> return ERecEmpty
+
+{- I = id I'
+I' = "." id I'' | eps
+I'' = "=" E | eps
+-}
+pIdExp = identifier >>= pIdExp'
+pIdExp' :: Name -> Parser Exp
+pIdExp' n = (symbol "." >> identifier >>= pIdExp'' n )
+          <|> (return $ EVar n)
+
+pIdExp'' n n2 = (symbol "=" >> (ESet n n2 <$> pExp))
+                <|> (return $ EGet n n2)

Simple4/Syntax.hs

@@ -0,0 +1,28 @@
+module Simple4.Syntax where
+
+type Name = String
+type Defs = [Def]
+type Def = (Name,Exp)
+
+data Exp
+    = EInt Integer
+    | EVar Name
+    | EAdd Exp Exp
+    | ELet Name Exp Exp
+    | ELets Defs Exp
+    | EIf Exp Exp Exp
+    | ENew Exp
+    | EDeref Exp 
+    | ENone
+    | ERecEmpty
+    | EGet Name Name
+    | ESet Name Name Exp
+      deriving(Eq,Show)
+
+instance Num Exp where
+    fromInteger = EInt
+    (+) = EAdd
+    (*) = undefined
+    (-) = undefined
+    signum = undefined
+    abs = undefined