Simple Monadic Parser in Haskell http://michal.muskala.eu/2015/09/23/simple-monadic-parser-in-haskell.html
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
module Language.Brainfuck.Parser | |
(parse) | |
where | |
import Control.Monad.Except | |
import Control.Monad.State | |
data ParseError = Unexpected Char | |
| UnexpectedEof | |
| Unknown | |
deriving (Eq, Show) | |
newtype Parser a = P { runP :: ExceptT ParseError (State String) a | |
} deriving ( Monad | |
, MonadError ParseError | |
, MonadState String | |
) | |
data AST = PtrMove Int | |
| MemMove Int | |
| Output | |
| Input | |
| Loop [AST] | |
deriving (Eq, Show) | |
parse :: String -> Either ParseError [AST] | |
parse = fmap fst . runParser parseAll . filter isMeaningful | |
where isMeaningful = (`elem` "><+-,.[]") | |
parseAll :: Parser [AST] | |
parseAll = do | |
exprs <- many parseOne | |
eof | |
return exprs | |
parseOne :: Parser AST | |
parseOne = choice [ transform '>' (PtrMove 1) | |
, transform '<' (PtrMove (-1)) | |
, transform '+' (MemMove 1) | |
, transform '-' (MemMove (-1)) | |
, transform ',' Output | |
, transform '.' Input | |
, parseLoop | |
] | |
where transform char ast = expect char >> return ast | |
expect char = satisfy (== char) | |
parseLoop :: Parser AST | |
parseLoop = do | |
consume '[' | |
steps <- many parseOne | |
consume ']' | |
return (Loop steps) | |
where consume char = satisfy (== char) >> return () | |
eof :: Parser () | |
eof = do | |
s <- get | |
case s of | |
[] -> return () | |
_ -> throwError UnexpectedEof | |
many :: Parser a -> Parser [a] | |
many parser = recurse `catchError` \_ -> return [] | |
where recurse = do | |
result <- parser | |
rest <- many parser | |
return (result:rest) | |
option :: Parser a -> Parser a -> Parser a | |
option parser1 parser2 = do | |
s <- get | |
parser1 `catchError` \_ -> do | |
put s | |
parser2 | |
runParser :: Parser a -> String -> Either ParseError (a, String) | |
runParser parser str = | |
case (runState . runExceptT . runP) parser str of | |
(Left err, _) -> Left err | |
(Right r, rest) -> Right (r, rest) | |
choice :: [Parser a] -> Parser a | |
choice = foldr option (throwError Unknown) | |
satisfy :: (Char -> Bool) -> Parser Char | |
satisfy predicate = do | |
s <- get | |
case s of | |
x:xs | predicate x -> do | |
put xs | |
return x | |
x:_ -> throwError (Unexpected x) | |
[] -> throwError UnexpectedEof |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment