87 lines
2.7 KiB
Haskell
87 lines
2.7 KiB
Haskell
module Logic.Parse where
|
|
|
|
import Control.Applicative (Applicative, Alternative(..))
|
|
import Data.Functor (Functor)
|
|
|
|
newtype Parser symbol output = Parser
|
|
{ runParser :: Input symbol -> Either ParseError (output, Input symbol)
|
|
}
|
|
|
|
data Input symbol = Input
|
|
{ inputPos :: Int
|
|
, inputSeq :: [symbol]
|
|
} deriving (Eq, Show)
|
|
|
|
mkInput :: [symbol] -> Input symbol
|
|
mkInput = Input 0
|
|
|
|
data ParseError =
|
|
ParseError Int String
|
|
deriving Show
|
|
|
|
expected :: Show s => String -> Input s -> ParseError
|
|
expected thing input = ParseError (inputPos input) $
|
|
"expected " <> thing <> ", found " <> show (take 20 $ inputSeq input)
|
|
|
|
eof :: Show symbol => Parser symbol a -> Input symbol -> Either ParseError a
|
|
eof p input = do
|
|
(result, rest) <- runParser p input
|
|
case inputSeq rest of
|
|
[] -> Right result
|
|
_ -> Left $ expected "end of input" rest
|
|
|
|
instance Functor (Parser s) where
|
|
fmap :: (a -> b) -> Parser symbol a -> Parser symbol b
|
|
fmap f (Parser p) = Parser $ \input -> do
|
|
(result, rest) <- p input
|
|
return (f result, rest)
|
|
|
|
instance Applicative (Parser s) where
|
|
pure :: a -> Parser s a
|
|
pure result = Parser $ \input -> Right (result, input)
|
|
|
|
(<*>) :: Parser s (a -> b) -> Parser s a -> Parser s b
|
|
(Parser p1) <*> (Parser p2) =
|
|
Parser $ \input -> do
|
|
(f, rest) <- p1 input
|
|
(result, rest') <- p2 rest
|
|
return (f result, rest')
|
|
|
|
instance Alternative (Parser s) where
|
|
empty :: Parser s a
|
|
empty = Parser $ const empty
|
|
|
|
(<|>) :: Parser s a -> Parser s a -> Parser s a
|
|
(Parser p1) <|> (Parser p2) =
|
|
Parser $ \input -> p1 input <|> p2 input
|
|
|
|
instance Alternative (Either ParseError) where
|
|
empty :: Either ParseError a
|
|
empty = Left $ ParseError 0 "this parser always fails"
|
|
|
|
(<|>) :: Either ParseError a -> Either ParseError a -> Either ParseError a
|
|
(Right x) <|> _ = Right x
|
|
(Left _) <|> e = e
|
|
|
|
instance Monad (Parser s) where
|
|
(>>=) :: Parser s a -> (a -> Parser s b) -> Parser s b
|
|
p1 >>= next = Parser $ \input ->
|
|
case runParser p1 input of
|
|
Right (result, rest) -> runParser (next result) rest
|
|
Left err -> Left err
|
|
|
|
parseToken :: (Eq s, Show s) => [s] -> Parser s [s]
|
|
parseToken token = Parser parse
|
|
where
|
|
n = length token
|
|
parse input@(Input pos xs)
|
|
| token == take n xs = Right $ (token,) $ Input (pos + n) (drop n xs)
|
|
| otherwise = Left $ expected (show token) input
|
|
|
|
parseIf :: Show s => String -> (s -> Bool) -> Parser s s
|
|
parseIf description check = Parser $ \input ->
|
|
case inputSeq input of
|
|
[] -> Left $ ParseError (inputPos input) "unexpected end of input"
|
|
(char:chars)
|
|
| check char -> Right $ (char,) $ Input (inputPos input + 1) chars
|
|
| otherwise -> Left $ expected description input
|