From 60c2c2fe6dd38d1761153acc160ce94331f12520 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Sun, 13 Dec 2020 20:09:19 +0000
Subject: [PATCH] Parse terms and definitions

---
 package.yaml              |  1 +
 propa-tools.cabal         |  3 ++
 src/Propa/Prolog/Parse.hs | 81 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 85 insertions(+)
 create mode 100644 src/Propa/Prolog/Parse.hs

diff --git a/package.yaml b/package.yaml
index a20f19a..497600f 100644
--- a/package.yaml
+++ b/package.yaml
@@ -14,6 +14,7 @@ extra-doc-files:
 dependencies:
 - base >= 4.7 && < 5
 - containers
+- megaparsec
 - text
 - transformers
 
diff --git a/propa-tools.cabal b/propa-tools.cabal
index 0286fc7..e95a440 100644
--- a/propa-tools.cabal
+++ b/propa-tools.cabal
@@ -24,6 +24,7 @@ library
       Propa.Lambda.Term
       Propa.Prolog.Display
       Propa.Prolog.Example
+      Propa.Prolog.Parse
       Propa.Prolog.Types
       Propa.Prolog.Unify
   other-modules:
@@ -33,6 +34,7 @@ library
   build-depends:
       base >=4.7 && <5
     , containers
+    , megaparsec
     , text
     , transformers
   default-language: Haskell2010
@@ -47,6 +49,7 @@ executable propa-tools-exe
   build-depends:
       base >=4.7 && <5
     , containers
+    , megaparsec
     , propa-tools
     , text
     , transformers
diff --git a/src/Propa/Prolog/Parse.hs b/src/Propa/Prolog/Parse.hs
new file mode 100644
index 0000000..f26a2ac
--- /dev/null
+++ b/src/Propa/Prolog/Parse.hs
@@ -0,0 +1,81 @@
+{-# 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 ")")
+
+-- 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
+
+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)
+
+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) 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