100 lines
2.5 KiB
Haskell
100 lines
2.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Propa.Prolog.Parse
|
|
( parseTerms
|
|
, parseDb
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Data.Bifunctor
|
|
import Data.Char
|
|
import Data.Void
|
|
|
|
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 "]")
|
|
|
|
-- Building blocks
|
|
|
|
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
|
|
|
|
pCons :: Parser (Term T.Text)
|
|
pCons = brackets $ do
|
|
elems <- pTerm `sepBy1` symbol ","
|
|
void $ symbol "|"
|
|
rest <- pTerm
|
|
pure $ foldr (\a b -> Stat "[|]" [a, b]) rest elems
|
|
|
|
pList :: Parser (Term T.Text)
|
|
pList = do
|
|
elems <- brackets $ pTerm `sepBy` symbol ","
|
|
pure $ foldr (\a b -> Stat "[|]" [a, b]) (Stat "[]" []) elems
|
|
|
|
pStat :: Parser (T.Text, [Term T.Text])
|
|
pStat = do
|
|
name <- pName
|
|
terms <- parens (pTerm `sepBy1` symbol ",") <|> pure []
|
|
pure (name, terms)
|
|
|
|
pTerm :: Parser (Term T.Text)
|
|
pTerm
|
|
= (Var <$> pVarName)
|
|
<|> (uncurry Stat <$> pStat)
|
|
<|> try pCons
|
|
<|> pList
|
|
|
|
pTerms :: Parser [Term T.Text]
|
|
pTerms = (pTerm `sepBy1` symbol ",") <* symbol "."
|
|
|
|
pDef :: Parser (Def T.Text)
|
|
pDef = do
|
|
name <- pName
|
|
args <- parens (pTerm `sepBy1` symbol ",") <|> pure []
|
|
terms <- (symbol ":-" *> (pTerm `sepBy1` symbol ",")) <|> pure []
|
|
void $ symbol "."
|
|
pure $ Def name args terms
|
|
|
|
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
|
|
|
|
parseTerms :: FilePath -> T.Text -> Either T.Text [Term T.Text]
|
|
parseTerms = parseHelper pTerms
|
|
|
|
parseDb :: FilePath -> T.Text -> Either T.Text (Db T.Text)
|
|
parseDb = parseHelper pDefs
|