I've been reading too many papers and writing too little code. These are my first 300 lines of Haskell:
{-# LANGUAGE NoMonomorphismRestriction, TemplateHaskell #-}
module Forth where
import qualified Data.Map.Lazy as Map
import Control.Monad.State
import Control.Monad.Error
import Text.Read (readMaybe)
import Text.Parsec
import Control.Applicative hiding ((<|>), optional, many)
import Control.Lens
import Control.Lens.Operators
import Safe
data Forth = Forth {
_stack :: [Integer],
_loopStack :: [Integer],
_heap :: Map.Map String [Exp]} deriving (Show)
data Exp = Cmt String | Dump | Num Integer | Plus | Min | Mul | Div | Mod | Dup | Swap | Drop | PP
| LoopIndex Int | In | Out String | CR | Eq | Lt | Gt
| Word String [Exp] | Call String | If [Exp] [Exp] | DoLoop [Exp] Bool | Leave
deriving (Show)
makeLenses ''Forth
type ForthS a = ErrorT String (StateT Forth IO) a
emptyForth :: Forth
emptyForth = Forth [] [] Map.empty
pushStack :: Integer -> ForthS ()
pushStack n = stack %= (n:)
popStack :: ForthS Integer
popStack = do
s <- use stack
case s of
[] -> throwError "Empty stack. Can't pop!"
(n:ns) -> do
stack .= ns
return n
dumpStack :: ForthS [Integer]
dumpStack = zoom stack get
--
pushLoopStack :: Integer -> ForthS ()
pushLoopStack n = loopStack %= (n:)
popLoopStack :: ForthS Integer
popLoopStack = do
s <- use loopStack
case s of
[] -> throwError "Empty loop stack. Can't pop!"
(n:ns) -> do
loopStack .= ns
return n
--(.?) :: MonadState s m => Getting s1 s s1 -> Getting (f a) s1 a -> m (Maybe a)
(.?) a b = do
v <- use a
return (v ^? b)
peekLoopStack :: Int -> ForthS Integer
peekLoopStack i = do
--a <- (loopStack .? ix i)
a <- zoom loopStack (gets $ flip atMay i)
case a of
Just n -> return n
Nothing -> throwError $ "Loop stack is empty."
--
setWord :: String -> [Exp] -> ForthS ()
setWord word val = heap %= (Map.insert word val)
getWord :: String -> ForthS [Exp]
getWord word = do
h <- use heap
case Map.lookup word h of
Just a -> return a
Nothing -> throwError $ "Word \"" ++ word ++ "\" is not defined."
-----------------------
execProg :: [Exp] -> IO ()
execProg xs = do
(success, machine) <- runProg xs
case success of
Left m -> putStrLn $ "\nFailed: " ++ m ++ show machine
Right _ -> putStrLn $ "\nOk: " ++ show machine
runProg :: [Exp] -> IO (Either String (), Forth)
runProg xs = runEval (mapM_ eval xs)
runEval :: Eval -> IO (Either String (), Forth)
runEval ev = runStateT (runErrorT ev) emptyForth
type Eval = ForthS ()
eval :: Exp -> Eval
eval (Cmt _) = return ()
eval (Dump) = do
ns <- dumpStack
liftIO $ print ns
eval (Num n) = pushStack n
eval (Plus) = do
a <- popStack
b <- popStack
pushStack (b+a)
eval (Min) = do
a <- popStack
b <- popStack
pushStack (b-a)
eval (Mul) = do
a <- popStack
b <- popStack
pushStack (b*a)
eval (Div) = do
a <- popStack
b <- popStack
pushStack (b `div` a)
eval (Mod) = do
a <- popStack
b <- popStack
pushStack (b `mod` a)
eval (Dup) = do
a <- popStack
pushStack a
pushStack a
eval (Swap) = do
a <- popStack
b <- popStack
pushStack a
pushStack b
eval (Drop) = do
_ <- popStack
return ()
eval (PP) = do
a <- popStack
liftIO $ print a
eval (LoopIndex i) = do
n <- peekLoopStack i
pushStack n
eval (In) = do
s <- liftIO getLine
case readMaybe s of
Just n -> pushStack n
Nothing -> throwError $ "Input \"" ++ s ++ "\" is not a number."
eval (Out s) = liftIO $ putStr s
eval (CR) = liftIO $ putStrLn ""
eval (Eq) = do
a <- popStack
b <- popStack
pushStack (if b==a then 1 else 0)
eval (Lt) = do
a <- popStack
b <- popStack
pushStack (if b<a then 1 else 0)
eval (Gt) = do
a <- popStack
b <- popStack
pushStack (if b>a then 1 else 0)
eval (Word key val) = setWord key val
eval (Call key) = do
val <- getWord key
mapM_ eval val
eval (If yes no) = do
a <- popStack
mapM_ eval (if a/=0 then yes else no)
eval (Leave) = mzero
eval (DoLoop xs plusLoop) = do
idx <- popStack
lim <- popStack
pushLoopStack lim
pushLoopStack idx
let go lim idx = do
mapM_ eval xs
inc <- if plusLoop then popStack else return 1
guard $ not $ if inc >= 0 then (lim < idx) `xor` (lim <= idx + inc) else (lim <= idx) `xor` (lim < idx + inc)
_ <- popLoopStack
_ <- popLoopStack
pushLoopStack lim
pushLoopStack (idx + inc)
go lim (idx + inc)
let finish = do
_ <- popLoopStack
_ <- popLoopStack
return ()
mplus (go lim idx) finish
xor :: Bool -> Bool -> Bool
x `xor` y = (x || y) && not (x && y)
-----------------------------
execParse :: String -> IO ()
execParse = execProg . parseForth
parseForth :: String -> [Exp]
parseForth s = case parse forthParser "YOLO" s of
Left e -> [Out $ "ERROR PARSED: " ++ show e]
Right xs -> xs
forthParser = ws *> many forthExp <* eof
forthExp = foldl1 (<||>) $ map (\e-> e <* (ws1 <|> eof))[
comments >>= pure . Cmt,
integer >>= pure . Num, -- negative numbers suck
char '-' *> pure Min,
char '+' *> pure Plus,
char '*' *> pure Mul,
char '/' *> pure Div,
char '.' *> pure PP,
char '=' *> pure Eq,
char '<' *> pure Lt,
char '>' *> pure Gt,
char '%' *> pure Mod,
char 'i' *> pure (LoopIndex 0),
char 'j' *> pure (LoopIndex 2),
char 'k' *> pure (LoopIndex 4),
string "false" *> pure (Num 0),
string "true" *> pure (Num 1),
string "CR" *> pure CR,
string "dump" *> pure Dump,
string "dup" *> pure Dup,
string "swap" *> pure Swap,
string "drop" *> pure Drop,
string "in" *> pure In,
string "leave" *> pure Leave,
ifThenElse,
doLoop,
stringLike >>= pure . Out ,
definition,
many1 alphaNum >>= pure . Call -- if it isn't a keyword, it must be a call
]
p <||> q = try p <|> q
ws = skipMany (oneOf " \n\r")
ws1 = skipMany1 (oneOf " \n\r")
lexeme p = ws *> p <* ws
integer = rd <$> (plus <|> minus <|> number)
where rd = read :: String -> Integer
plus = char '+' *> number
minus = (:) <$> char '-' <*> number
number = many1 digit
stringLike = char '\'' *> many (noneOf ['\'']) <* char '\''
comments = char '(' *> many (noneOf [')' , '\r', '\n']) <* char ')'
definition = do
char ':'
name <- lexeme (many1 alphaNum)
prog <- forthParser
char ';'
return $ Word name prog
ifThenElse = do
string "if"
ws
yes <- manyTill forthExp (try $ lookAhead $ string "else" <|> string "then")
no <- option [] $ do
string "else"
ws
manyTill forthExp (try $ lookAhead $ string "then")
string "then"
return $ If yes no
doLoop = do
string "do"
ws
body <- manyTill forthExp (try $ lookAhead $ string "loop" <|> string "+loop")
choice [string "loop" *> return (DoLoop body False), string "+loop" *> return (DoLoop body True)]
----------------
main :: IO ()
main = do
s <- getContents
execParse s
Use execParse in GHCi to parse and run a program.
Example:
execParse ": neg (n -- n') 0 swap - ; 'enter a number to negate' CR in neg . 'looping' CR 0 50 do i . -5 +loop true if 'always print this' else 'never print this' then dump"
In this project I've tried to use Parsec, a small transformer stack and basic lens functionality. Comments on the use of these are what I'm after, but everything helps.
I've used NoMonomorphismRestriction to deal with Parsec. It can't infer types but the types are too complicated to figure out myself. I was wondering whether this could be because of type synonyms and whether there's an easy guide to typing Parsec functions, or maybe I'm complicating things too much.
I've found using transformers pretty straightforward, and it matches pretty well with lens. But, all lens operators have State versions except the getters, which makes it pretty awkward. I can use zoom, but that isn't always pretty (can't be used with ^? for example).
1 Answer 1
I think popStack might look a little nicer using the LambdaCase extension:
popStack :: ForthS Integer
popStack = use stack >>= \case
[] -> throwError "Empty stack. Can't pop!"
(n:ns) -> stack .= ns >> return n
The same transformation can occur with popLoopStack. It also applies to peekLoopStack, but in that case, you might even use maybe rather than a language extension:
peekLoopStack :: Int -> ForthS Integer
peekLoopStack = maybe (throwError "Loop stack is empty.") return
. zoom loopStack . gets . flip atMay
You could also use maybe to eliminate the do in getWord.
You have a lot of binary operators. Each one is implemented like this:
eval (Plus) = do
a <- popStack
b <- popStack
pushStack (b+a)
I think that’s a little repetitive. I might define a little helper function:
binop :: (Integer -> Integer -> Integer) -> Eval
binop f = do
a <- popStack
b <- popStack
pushStack (f b a)
Then you can define your operators like this:
eval Plus = binop (+)
eval Min = binop (-)
eval Mul = binop (*)
-- ...
This leaves less room for error.
In a similar vein to the first suggestion, you might try to eliminate the do from Call:
eval (Call key) = getWord key >>= mapM_ eval
xor is /=. There is no need to define xor when you could just use /=.
forthExp
comments >>= pure . Cmt can be replaced with fmap Cmt comments or Cmt <$> comments. Similarly for integer, stringLike, and calls.
char '-' *> pure Min can be replaced with Min <$ char '-'. Similarly for the others.
The outer structure, too, can probably be changed. Rather than using
foldl1 (<||>) $ map (\e-> e <* (ws1 <|> eof))
I think this would be clearer:
choice $ map ((<* (es1 <|> eof)) . try)
I would avoid the name ifThenElse, as that is used by GHC’s RebindableSyntax extension should you ever want to use it in the future.
Transformer stack
Your transformer stack looks okay, but I might consider replacing the underlying IO with a free monad providing only the operations (input, output) you need, and then provide an interpreter to use IO. This makes it trivial to test, as you can make it pure by just inspecting the resulting structure rather than using the IO interpreter. See this blog post for more details.