128 lines
3.2 KiB
Haskell
128 lines
3.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Propa.Prolog.Parse
|
|
( parseStats
|
|
, parseDb
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Data.Bifunctor
|
|
import Data.Char
|
|
import Data.Void
|
|
|
|
import Control.Monad.Combinators.Expr
|
|
import qualified Data.Text as T
|
|
import Text.Megaparsec
|
|
import qualified Text.Megaparsec.Char as C
|
|
import qualified Text.Megaparsec.Char.Lexer as L
|
|
|
|
import Propa.Prolog.Types
|
|
|
|
type Parser = Parsec Void T.Text
|
|
|
|
-- Lexeme stuff
|
|
|
|
space :: Parser ()
|
|
space = L.space C.space1 (L.skipLineComment "%") (L.skipBlockComment "/*" "*/")
|
|
|
|
lexeme :: Parser a -> Parser a
|
|
lexeme = L.lexeme space
|
|
|
|
symbol :: T.Text -> Parser T.Text
|
|
symbol = L.symbol space
|
|
|
|
parens :: Parser a -> Parser a
|
|
parens = between (symbol "(") (symbol ")")
|
|
|
|
brackets :: Parser a -> Parser a
|
|
brackets = between (symbol "[") (symbol "]")
|
|
|
|
-- Names
|
|
|
|
pName :: Parser T.Text
|
|
pName = lexeme $ unquotedName <|> quotedName
|
|
where
|
|
unquotedName = takeWhile1P (Just "lowercase character") isLower
|
|
quotedName = fmap T.pack $ C.char '\'' *> manyTill L.charLiteral (C.char '\'')
|
|
|
|
pVarName :: Parser T.Text
|
|
pVarName = lexeme $ takeWhile1P (Just "uppercase character") isUpper
|
|
|
|
-- Statements
|
|
|
|
pTermToStat :: Parser (Term T.Text) -> Parser (Stat T.Text)
|
|
pTermToStat p = do
|
|
term <- p
|
|
case term of
|
|
(TVar _) -> fail "expected statement, not variable"
|
|
(TInt _) -> fail "expected statement, not integer"
|
|
(TStat s) -> pure s
|
|
|
|
-- | Parse a statement of the form @name(args)@.
|
|
pPlainStat :: Parser (Stat T.Text)
|
|
pPlainStat = do
|
|
name <- pName
|
|
terms <- parens (pTerm `sepBy1` symbol ",") <|> pure []
|
|
pure $ Stat name terms
|
|
|
|
pStat :: Parser (Stat T.Text)
|
|
pStat = pPlainStat <|> pTermToStat pTerm
|
|
|
|
pStats :: Parser [Stat T.Text]
|
|
pStats = (pStat `sepBy1` symbol ",") <* symbol "."
|
|
|
|
-- Terms
|
|
|
|
pCons :: Parser (Term T.Text)
|
|
pCons = brackets $ do
|
|
elems <- pTerm `sepBy1` symbol ","
|
|
void $ symbol "|"
|
|
rest <- pTerm
|
|
pure $ foldr (\a b -> TStat $ Stat "[|]" [a, b]) rest elems
|
|
|
|
pList :: Parser (Term T.Text)
|
|
pList = do
|
|
elems <- brackets $ pTerm `sepBy` symbol ","
|
|
pure $ foldr (\a b -> TStat $ Stat "[|]" [a, b]) (TStat $ Stat "[]" []) elems
|
|
|
|
-- | Parse a term that is not an expression.
|
|
pPlainTerm :: Parser (Term T.Text)
|
|
pPlainTerm
|
|
= (TVar <$> pVarName)
|
|
<|> (TInt <$> L.signed (pure ()) L.decimal)
|
|
<|> (TStat <$> pPlainStat)
|
|
<|> try pCons
|
|
<|> pList
|
|
<|> parens pTerm
|
|
|
|
pTerm :: Parser (Term T.Text)
|
|
pTerm = makeExprParser pPlainTerm
|
|
[ [ binary "=" ]
|
|
]
|
|
where
|
|
binary name = InfixL $ (\a b -> TStat $ Stat name [a, b]) <$ symbol name
|
|
|
|
-- Definitions
|
|
|
|
pDef :: Parser (Def T.Text)
|
|
pDef = do
|
|
stat <- pStat
|
|
stats <- (symbol ":-" *> (pStat `sepBy1` symbol ",")) <|> pure []
|
|
void $ symbol "."
|
|
pure $ Def stat stats
|
|
|
|
pDefs :: Parser [Def T.Text]
|
|
pDefs = many pDef
|
|
|
|
-- And finally, our nice parsers
|
|
|
|
parseHelper :: Parser a -> FilePath -> T.Text -> Either T.Text a
|
|
parseHelper p path input
|
|
= first (T.pack . errorBundlePretty)
|
|
$ parse (space *> p <* eof) path input
|
|
|
|
parseStats :: FilePath -> T.Text -> Either T.Text [Stat T.Text]
|
|
parseStats = parseHelper pStats
|
|
|
|
parseDb :: FilePath -> T.Text -> Either T.Text (Db T.Text)
|
|
parseDb = parseHelper pDefs
|