transition InterpState to use StateT IO
This commit is contained in:
parent
d9e1a7bdc1
commit
d2ad20ff3a
2 changed files with 11 additions and 21 deletions
29
interp.hs
29
interp.hs
|
@ -6,7 +6,8 @@ module Interp where
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
import Control.Monad.State (State, runState, evalState, get, put)
|
import Control.Monad.Trans (lift)
|
||||||
|
import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, put)
|
||||||
import System.IO (Handle, hPutStr, hGetLine, hFlush, stdout, stdin)
|
import System.IO (Handle, hPutStr, hGetLine, hFlush, stdout, stdin)
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
import AST
|
import AST
|
||||||
|
@ -28,7 +29,7 @@ data Value = IntV Integer
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
|
||||||
type Env = M.Map String Value -- an environment
|
type Env = M.Map String Value -- an environment
|
||||||
type InterpState = State ([Handle], Env) -- interpreter state (open handles, global env)
|
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
|
||||||
|
|
||||||
lookup :: Env -> String -> Maybe Value
|
lookup :: Env -> String -> Maybe Value
|
||||||
lookup env name = M.lookup name env
|
lookup env name = M.lookup name env
|
||||||
|
@ -60,29 +61,19 @@ l *$ r = error $ "cannot * " ++ show l ++ " and " ++ show r
|
||||||
(IntV l) /$ (IntV r) = IntV (l `div` r)
|
(IntV l) /$ (IntV r) = IntV (l `div` r)
|
||||||
l /$ r = error $ "cannot / " ++ show l ++ " and " ++ show r
|
l /$ r = error $ "cannot / " ++ show l ++ " and " ++ show r
|
||||||
|
|
||||||
-- these are pretty nasty and instead of using unsafePerformIO
|
|
||||||
-- we could throw eval, etc. into StateT with IO instead, but then
|
|
||||||
-- everything would be in IO.
|
|
||||||
|
|
||||||
_putstr (StrV str) = do
|
_putstr (StrV str) = do
|
||||||
(handles,_) <- get
|
(handles,_) <- get
|
||||||
let stdout_s = head handles
|
let stdout_s = head handles
|
||||||
let io = unsafe_putstr stdout_s str
|
io <- lift $ hPutStr stdout_s str >> hFlush stdout_s
|
||||||
return $ seq io UnitV
|
return UnitV
|
||||||
where
|
|
||||||
{-# NOINLINE unsafe_putstr #-}
|
|
||||||
unsafe_putstr h s = unsafePerformIO $ hPutStr h s >> hFlush h
|
|
||||||
|
|
||||||
_print v = _putstr $ StrV $ show v ++ "\n"
|
_print v = _putstr $ StrV $ show v ++ "\n"
|
||||||
|
|
||||||
_getline UnitV = do
|
_getline UnitV = do
|
||||||
(handles,_) <- get
|
(handles,_) <- get
|
||||||
let stdin_s = handles !! 1
|
let stdin_s = handles !! 1
|
||||||
let str = unsafe_getline stdin_s
|
str <- lift $ hGetLine stdin_s
|
||||||
return $ seq () $ StrV str
|
return $ StrV str
|
||||||
where
|
|
||||||
{-# NOINLINE unsafe_getline #-}
|
|
||||||
unsafe_getline h = unsafePerformIO $ hGetLine h
|
|
||||||
|
|
||||||
_itos (IntV i) = return $ StrV $ show i
|
_itos (IntV i) = return $ StrV $ show i
|
||||||
_itos v = error $ "itos: not an int: " ++ show v
|
_itos v = error $ "itos: not an int: " ++ show v
|
||||||
|
@ -216,10 +207,10 @@ apply (FnV pats) arg =
|
||||||
|
|
||||||
apply (Builtin (BIF fn)) arg = fn arg
|
apply (Builtin (BIF fn)) arg = fn arg
|
||||||
|
|
||||||
evalProgram :: [AST] -> Value -- fold the state from each node and return the result
|
evalProgram :: [AST] -> IO Value -- fold the state from each node and return the result
|
||||||
evalProgram nodes = evalState (foldr1 (>>) $ map eval nodes) initialState
|
evalProgram nodes = evalStateT (foldr1 (>>) $ map eval nodes) initialState
|
||||||
|
|
||||||
evalString :: String -> Value
|
evalString :: String -> IO Value
|
||||||
evalString program =
|
evalString program =
|
||||||
case parseProgram program of
|
case parseProgram program of
|
||||||
Left err -> error $ show err
|
Left err -> error $ show err
|
||||||
|
|
3
lamb.hs
3
lamb.hs
|
@ -17,8 +17,7 @@ allExist (x:xs) = do
|
||||||
evalFile :: String -> IO Value
|
evalFile :: String -> IO Value
|
||||||
evalFile path = do
|
evalFile path = do
|
||||||
contents <- readFile path
|
contents <- readFile path
|
||||||
let ev = evalString contents
|
evalString contents
|
||||||
if ev == UnitV then return ev else return ev -- this is just to force evaluation
|
|
||||||
|
|
||||||
main = do
|
main = do
|
||||||
args <- getArgs
|
args <- getArgs
|
||||||
|
|
Loading…
Reference in a new issue