83 lines
2.0 KiB
Haskell
83 lines
2.0 KiB
Haskell
module Parser where
|
|
|
|
import Base
|
|
|
|
import Data.String (fromString)
|
|
import Control.Applicative
|
|
import qualified Data.Text as T
|
|
|
|
data ASTNode = MoveRight
|
|
| MoveLeft
|
|
| Increment
|
|
| Decrement
|
|
| Replace
|
|
| Print
|
|
| Loop ASTNode
|
|
|
|
flattenAST :: [ASTNode] -> [BFAction]
|
|
flattenAST = concatMap f
|
|
where
|
|
f (Loop x) = [JumpLeft] ++ process x ++ [JumpRight]
|
|
f x = [x]
|
|
|
|
data ParserError
|
|
= EndOfInput
|
|
| UnexpectedSymbol Char
|
|
| Empty
|
|
deriving (Eq, Show)
|
|
|
|
newtype Parser a = Parser
|
|
{ runParser :: T.Text -> Either [ParserError] (a, T.Text)
|
|
}
|
|
|
|
instance Functor Parser where
|
|
fmap f (Parser x) = Parser run
|
|
where
|
|
run input = case x input of
|
|
Left err -> Left err
|
|
Right (out, res) -> Right (f out, rest)
|
|
|
|
instance Applicative Parser where
|
|
pure a = Parser $ \input -> Right (a, input)
|
|
Parser x <*> Parser y = Parser run
|
|
where
|
|
run input = case x input of
|
|
Left err -> Left err
|
|
Right (x', rest) -> case y rest of
|
|
Left err -> Left err
|
|
Right (y', rest') -> Right (x' y', rest')
|
|
|
|
instance Monad Parser where
|
|
return = pure
|
|
Parser x >>= y = Parser run
|
|
where
|
|
run input = case x input of
|
|
Left err -> Left err
|
|
Right (out, rest) ->
|
|
let Parser x' = y out in x' rest
|
|
|
|
instance Alternative Parser where
|
|
empty = Parser $ \_ -> Left [Empty]
|
|
Parser x <|> Parser y = Parser run
|
|
where
|
|
run input = case x input of
|
|
Right (out, rest) -> Right (out, rest)
|
|
Left err -> case y input of
|
|
Right (out, rest) -> Right (out, rest)
|
|
Left err' -> Left err <> err'
|
|
|
|
satisfy :: (Char -> Bool) -> Parser T.Text
|
|
satisfy p = Parser run
|
|
where
|
|
run "" = Left [EndOfInput]
|
|
run (x : rest) = if p x then Right (x, rest) else Left [UnexpectedSymbol x]
|
|
|
|
char :: Char -> Parser T.Text
|
|
char c = satisfy (== c)
|
|
|
|
string :: T.Text -> Parser T.Text
|
|
string (x:xs) = do
|
|
y <- char x
|
|
ys <- string xs
|
|
return $ T.append x ys
|