Create a gist now

Instantly share code, notes, and snippets.

{-# 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