Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Monadic interpreter for a small concatenative calculus
module Actions (Action, tryDoAction, actions, defaultAction) where
import System.Exit
import Data.List
import Data.Maybe
import Syntax
import Parser
import Eval
type Action = (String, String -> IO ())
defaultAction = evalPrint
actions :: [Action]
actions = [
(":q", const exitSuccess),
(":e", evalPrint)
]
actionPrefixes = map fst actions
tryDoAction :: String -> Action -> IO Bool
tryDoAction line (pre, act)
| isPrefixOf pre line = act (fromJust $ stripPrefix pre line) >> return True
| otherwise = return False
evalPrint line =
case parseTerm line of
Left err -> print err
Right ast -> runEval ast >>= showEvalResult
showEvalResult :: Either String Stack -> IO ()
showEvalResult (Left err) = putStrLn err
showEvalResult (Right stack) =
putStrLn (showStack stack)
showStack [] = "<<empty>>"
showStack ts = intercalate " " $ map show $ reverse ts
module Eval where
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Except
import Data.List
import qualified Data.Map as Map
import Syntax
type Scope = Map.Map Name Value
type Stack = [Value]
data Value
= VInt Integer
| VBool Bool
| VClosure [Name] Term Scope
instance Show Value where
show (VInt i) = show i
show (VBool b) = show b
show VClosure{} = "<<closure>>"
type Step = (Term,Stack)
type Eval a = ReaderT Scope (ExceptT String (StateT Stack IO)) a
eval :: Term -> Eval ()
eval Null = return ()
eval (Lit (LInt i) t) =
eval t >> push (VInt $ fromIntegral i)
eval (Lit (LBool b) t) =
eval t >> push (VBool b)
eval (Abs ns body t) = do
env <- ask
eval t >> push (VClosure ns body env)
eval (Var n t) = do
env <- ask
case Map.lookup n env of
Nothing -> throwError $ "could not find name: " ++ n
Just v -> eval t >> push v
eval (Call t) =
eval t >> apply
eval (Prim p t) =
eval t >> applyPrim p
peek :: Eval Value
peek = do
st <- get
case st of
[] -> throwError "expected an item, found nothing"
(top:rest) -> return top
pop :: Eval Value
pop = do
st <- get
case st of
[] -> throwError "expected an item, found nothing"
(top:rest) -> put rest >> return top
popN :: Int -> Eval Stack
popN n = do
st <- get
let (popped,st') = splitAt n st
put st'
return popped
pop2 = popN 2
push :: Value -> Eval ()
push v = modify (v:)
final :: Eval Stack
final = get >>= return
extend :: Scope -> [Name] -> [Value] -> Scope
extend env ns vs = Map.fromList (zip ns vs) `Map.union` env
popClosure :: Eval Value
popClosure = do
v <- pop
case v of
VClosure{} -> return v
_ -> throwError "expected a function, got something else"
apply :: Eval ()
apply = do
(VClosure args body env) <- popClosure
passed <- popN (length args)
if length passed < length args
then throwError "too few arguments for function call"
else do
local (const $ extend env (reverse args) passed) (eval body)
applyPrim :: Prim -> Eval ()
applyPrim Print = peek >>= liftIO . putStrLn . show
applyPrim Add = pop2 >>= primBinNumOp (+) Add
applyPrim Sub = pop2 >>= primBinNumOp (-) Sub
applyPrim Mul = pop2 >>= primBinNumOp (*) Mul
applyPrim Div = pop2 >>= primBinNumOp div Div
applyPrim Mod = pop2 >>= primBinNumOp mod Mod
applyPrim DivMod = do
args <- pop2
primBinNumOp div DivMod args
primBinNumOp mod DivMod args
applyPrim And = pop2 >>= primBinBoolOp (&&) And
applyPrim Or = pop2 >>= primBinBoolOp (||) Or
primBinNumOp :: (Integer -> Integer -> Integer) -> Prim -> Stack -> Eval ()
primBinNumOp f op [VInt i1, VInt i2] = push $ VInt $ f i1 i2
primBinNumOp _ op args = binOpErr op args
primBinBoolOp :: (Bool -> Bool -> Bool) -> Prim -> Stack -> Eval ()
primBinBoolOp f op [VBool b1, VBool b2] = push $ VBool $ f b1 b2
primBinBoolOp _ op args = binOpErr op args
binOpErr :: Prim -> Stack -> Eval ()
binOpErr op [_, _] = throwError $ "incorrect argument type(s) for primitive operation: " ++ show op
binOpErr op [_] = throwError $ show op ++ " expects two arguments but was given one"
binOpErr op [] = throwError $ show op ++ " expects two arguments but was given none"
runEval :: Term -> IO (Either String Stack)
runEval t = fst <$> runStateT (runExceptT (runReaderT (eval t >> final) Map.empty)) []
module Main where
import Control.Monad
import Control.Monad.Trans
import System.Console.Haskeline
import Data.List
import Parser
import Eval
import Syntax
import Actions
main :: IO ()
main =
runInputT defaultSettings repl
repl = do
input <- getInputLine "hydrogen> "
case input of
Nothing -> outputStrLn "l8r m8r"
Just line -> (liftIO $ process line) >> repl
process :: String -> IO ()
process line = do
tests <- sequence $ map (tryDoAction line) actions
if any id tests then return () else defaultAction line
module Parser where
import Data.Char
import Text.Parsec
import Text.Parsec.String (Parser)
import Text.Parsec.Language (haskellStyle)
import qualified Text.Parsec.Expr as Ex
import qualified Text.Parsec.Token as Tok
import Data.List
import Syntax
lexer :: Tok.TokenParser ()
lexer = Tok.makeTokenParser style
where ops = ["->","\\","+","*","-","=",".","!"]
names = ["true", "false", "print", "add", "sub", "mul", "div", "divmod", "and", "or"]
style = haskellStyle {Tok.reservedOpNames = ops,
Tok.reservedNames = names,
Tok.commentLine = "#"}
reserved :: String -> Parser ()
reserved = Tok.reserved lexer
reservedOp :: String -> Parser ()
reservedOp = Tok.reservedOp lexer
identifier :: Parser String
identifier = Tok.identifier lexer
parens :: Parser a -> Parser a
parens = Tok.parens lexer
contents :: Parser a -> Parser a
contents p = do
Tok.whiteSpace lexer
r <- p
eof
return r
natural :: Parser Integer
natural = Tok.natural lexer
variable :: Parser (Term -> Term)
variable = Var <$> identifier
number :: Parser (Term -> Term)
number = do
n <- natural
return $ Lit (LInt (fromIntegral n))
true :: Parser (Term -> Term)
true = do
reserved "true"
return $ Lit (LBool True)
false :: Parser (Term -> Term)
false = do
reserved "false"
return $ Lit (LBool False)
prim :: Parser (Term -> Term)
prim = do
(reserved "print" >> return (Prim Print))
<|> (reserved "add" >> return (Prim Add))
<|> (reserved "sub" >> return (Prim Sub))
<|> (reserved "mul" >> return (Prim Mul))
<|> (reserved "div" >> return (Prim Div))
<|> (reserved "mod" >> return (Prim Mod))
<|> (reserved "divmod" >> return (Prim DivMod))
<|> (reserved "and" >> return (Prim And))
<|> (reserved "or" >> return (Prim Or))
call :: Parser (Term -> Term)
call = do
reservedOp "!"
return $ Call
verb :: Parser (Term -> Term)
verb = do
reservedOp "("
ns <- many identifier
reservedOp "."
t <- term
reservedOp ")"
return $ Abs ns t
piece :: Parser (Term -> Term)
piece = do
variable
<|> number
<|> true
<|> false
<|> prim
<|> call
<|> verb
term :: Parser Term
term = do
es <- many piece
return (foldl' (flip ($)) Null es)
parseTerm :: String -> Either ParseError Term
parseTerm input = parse (contents term) "<stdin>" input
module Syntax where
import Data.List
type Name = String
data Term
= Null
| Lit Lit Term
| Prim Prim Term
| Var Name Term
| Abs [Name] Term Term
| Call Term
deriving Eq
instance Show Term where
show Null = ""
show (Lit l t) = show t ++ " " ++ show l
show (Prim p t) = show t ++ " " ++ show p
show (Var n t) = show t ++ " " ++ n
show (Abs ns body t) = show t ++ " (" ++ intercalate " " ns ++ "." ++ show body ++ ")"
show (Call t) = show t ++ " !"
data Lit
= LInt Int
| LBool Bool
deriving Eq
instance Show Lit where
show (LInt i) = show i
show (LBool b) = show b
data Prim
= Print
| Add
| Sub
| Mul
| Div
| Mod
| DivMod
| And
| Or
deriving (Eq, Show)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment