generalize parser symbols; parser monad
This commit is contained in:
parent
4d7fd8be7c
commit
ab8ed1c73c
2 changed files with 38 additions and 24 deletions
|
@ -3,53 +3,55 @@ module Logic.Parse where
|
|||
import Control.Applicative (Applicative, Alternative(..))
|
||||
import Data.Functor (Functor)
|
||||
|
||||
newtype Parser output = Parser
|
||||
{ runParser :: Input -> Either ParseError (output, Input)
|
||||
newtype Parser symbol output = Parser
|
||||
{ runParser :: Input symbol -> Either ParseError (output, Input symbol)
|
||||
}
|
||||
|
||||
data Input = Input
|
||||
data Input symbol = Input
|
||||
{ inputPos :: Int
|
||||
, inputSeq :: [Char]
|
||||
, inputSeq :: [symbol]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
mkInput :: [Char] -> Input
|
||||
mkInput :: [symbol] -> Input symbol
|
||||
mkInput = Input 0
|
||||
|
||||
data ParseError =
|
||||
ParseError Int String
|
||||
deriving (Show)
|
||||
deriving Show
|
||||
|
||||
expected :: String -> Input -> ParseError
|
||||
expected :: Show s => String -> Input s -> ParseError
|
||||
expected thing input = ParseError (inputPos input) $
|
||||
"expected " <> thing <> ", found " <> show (take 20 $ inputSeq input)
|
||||
|
||||
eof :: Parser a -> Input -> Either ParseError a
|
||||
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 where
|
||||
fmap :: (a -> b) -> Parser a -> Parser b
|
||||
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 where
|
||||
pure :: a -> Parser a
|
||||
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 where
|
||||
empty :: Parser a
|
||||
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
|
||||
|
||||
|
@ -57,10 +59,18 @@ 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
|
||||
|
||||
parseToken :: String -> Parser String
|
||||
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
|
||||
|
@ -68,7 +78,7 @@ parseToken token = Parser parse
|
|||
| token == take n xs = Right $ (token,) $ Input (pos + n) (drop n xs)
|
||||
| otherwise = Left $ expected (show token) input
|
||||
|
||||
parseIf :: String -> (Char -> Bool) -> Parser Char
|
||||
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"
|
||||
|
|
|
@ -13,19 +13,23 @@ import Logic.Statement (Statement(..))
|
|||
import Control.Applicative (Alternative((<|>), some))
|
||||
import Data.Char (isAlphaNum)
|
||||
|
||||
stmtAtom :: Parser Statement
|
||||
stmtAtom :: Parser Char Statement
|
||||
stmtAtom = Atom <$> parse
|
||||
where
|
||||
parse = some $ parseIf "statement variable" $ \char -> isAlphaNum char || char == '_'
|
||||
parse = some $ parseIf "variable name" $ \char -> isAlphaNum char || char == '_'
|
||||
|
||||
stmtNot :: Parser Statement
|
||||
stmtNot :: Parser Char Statement
|
||||
stmtNot = Not <$> (parseToken "!" *> stmt)
|
||||
|
||||
stmtBinary :: Parser Statement
|
||||
stmtBinary = parseToken "(" *> body <* parseToken ")"
|
||||
stmtBinary :: Parser Char Statement
|
||||
stmtBinary = do
|
||||
parseToken "("
|
||||
s1 <- stmt
|
||||
constructor <- parseConnective
|
||||
s2 <- stmt
|
||||
parseToken ")"
|
||||
return $ constructor s1 s2
|
||||
where
|
||||
body = (\s1 f s2 -> f s1 s2) <$> stmt <*> parseConnective <*> stmt
|
||||
|
||||
parseConnective =
|
||||
fmap (const And) (parseToken "&")
|
||||
<|> fmap (const Or) (parseToken "|")
|
||||
|
@ -35,7 +39,7 @@ stmtBinary = parseToken "(" *> body <* parseToken ")"
|
|||
|
||||
fail = Parser $ \input -> Left $ expected "connective" input
|
||||
|
||||
stmt :: Parser Statement
|
||||
stmt :: Parser Char Statement
|
||||
stmt = Parser $ \input ->
|
||||
let
|
||||
parser =
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue