Monadic interpreter for a small concatenative calculus

Actions.hs

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

Eval.hs

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)) []

Main.hs

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

Parser.hs

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

Syntax.hs

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)