datalog/src/Datalog/Parser.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE MultilineStrings #-}
-
 module Datalog.Parser
     ( parseTerm
     , parseAtom
@@ -16,7 +14,6 @@ import Data.Void (Void)
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
-import Text.Pretty.Simple
 
 type Parser = Parsec Void Text
 
@@ -39,63 +36,36 @@ comma, period :: (MonadParsec e Text m) => m ()
 comma = () <$ symbol ","
 period = () <$ symbol "."
 
-parseCon :: (MonadParsec e Text m) => m (Term' SrcLoc)
-parseCon = Con dummy . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
+parseCon :: (MonadParsec e Text m) => m Term
+parseCon = Con . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
 
-parseVar :: (MonadParsec e Text m) => m (Term' SrcLoc)
-parseVar = Var dummy . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
+parseVar :: (MonadParsec e Text m) => m Term
+parseVar = Var . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
 
-parseTerm :: Parser (Term' SrcLoc)
+parseTerm :: Parser Term
 parseTerm = parseVar <|> parseCon
 
-parseAtom :: Parser (Atom' SrcLoc)
+parseAtom :: Parser Atom
 parseAtom = do
-  p <- getSourcePos
   rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
   args <- parens (parseTerm `sepBy` comma)
-  return (Atom SrcLoc{start = p} rel args)
+  return (Atom rel args)
 
-parseQuery :: Parser [Atom' SrcLoc]
+parseQuery :: Parser [Atom]
 parseQuery = parseAtom `sepBy` comma
 
-parseFact :: Parser (Rule' SrcLoc)
+parseFact :: Parser Rule
 parseFact = do
-  p <- getSourcePos
   headAtom <- parseAtom
   period
-  return (Rule SrcLoc{start = p} headAtom [])
+  return (headAtom :- [])
 
-parseRule :: Parser (Rule' SrcLoc)
+parseRule :: Parser Rule
 parseRule = try parseFact <|> do
-  p <- getSourcePos
   headAtom <- parseAtom <* symbol ":-"
   bodyAtoms <- parseQuery
   period
-  return (Rule SrcLoc{start = p} headAtom bodyAtoms)
+  return (headAtom :- bodyAtoms)
 
-parseProgram :: Parser (Program' SrcLoc)
-parseProgram = Program dummy <$> many parseRule
-
-data SrcLoc = SrcLoc
-  { start :: SourcePos
-  -- , end :: (Word, Word)
-  } deriving Show
-dummy = SrcLoc{start = initialPos "dummy-file"}
-
-test = do
-  let r = runParser parseProgram "???" prog
-  pPrint @IO r
-
-prog = """
-  odd(X,Y) :- r(X,Y).
-  odd(X,Y) :- even(X,Z), r(Z,Y).
-  even(X,Y) :- odd(X,Z), r(Z,Y).
-
-  r(0,1).
-  r(1,2).
-  r(2,3).
-  r(3,4).
-  r(4,5).
-
-  r(X,Y) :- r(Y,X).
-  """
+parseProgram :: Parser Program
+parseProgram = Program <$> many parseRule

datalog/src/Datalog/Syntax.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE PatternSynonyms #-}
-
 module Datalog.Syntax where
 
 import Data.Char (isUpper)
@@ -17,56 +15,49 @@ newtype VarId = VarId Text
 newtype RelId = RelId Text
   deriving (Eq, Ord, Show)
 
-type Term = Term' ()
-data Term' a = Con a ConId | Var a VarId
+data Term = Con ConId | Var VarId
   deriving (Eq, Ord, Show)
 
 con :: Text -> Term
-con = Con () . ConId
+con = Con . ConId
 
 var :: Text -> Term
-var = Var () . VarId
+var = Var . VarId
 
 term :: Text -> Term
 term t = if not (T.null t) && isUpper (T.head t) then var t else con t
 
-type Atom = Atom' ()
-data Atom' a = Atom a RelId [Term' a]
+data Atom = Atom RelId [Term]
   deriving (Eq, Ord, Show)
 
 atom :: Text -> [Text] -> Atom
-atom relName args = Atom () (RelId relName) (map term args)
+atom relName args = Atom (RelId relName) (map term args)
 
-type Rule = Rule' ()
-data Rule' a = Rule a (Atom' a) [Atom' a]
+data Rule = Atom :- [Atom]
   deriving (Eq, Ord, Show)
-{-# COMPLETE (:-) #-}
-pattern (:-) :: Atom' a -> [Atom' a] -> Rule' a
-pattern a :- b <- Rule _ a b
 
-type Program = Program' ()
-data Program' a = Program a [Rule' a]
+data Program = Program [Rule]
   deriving (Eq, Ord, Show)
 
 class HasConstants a where
   constants :: a -> Set ConId
 
-instance HasConstants (Term' a) where
+instance HasConstants Term where
   constants t = case t of
-    Con _ x -> Set.singleton x
-    Var _ _ -> Set.empty
+    Con x -> Set.singleton x
+    Var _ -> Set.empty
 
 instance HasConstants a => HasConstants [a] where
   constants xs = Set.unions (map constants xs)
 
-instance HasConstants (Atom' a) where
-  constants (Atom _ _ ts) = constants ts
+instance HasConstants Atom where
+  constants (Atom _ ts) = constants ts
 
-instance HasConstants (Rule' a) where
+instance HasConstants Rule where
   constants (h :- b) = Set.union (constants h) (constants b)
 
-instance HasConstants (Program' a) where
-  constants (Program _ rs) = constants rs
+instance HasConstants Program where
+  constants (Program rs) = constants rs
 
 class Pretty t where
   pretty :: t -> Text
@@ -81,15 +72,15 @@ instance Pretty RelId where
   pretty (RelId t) = t
 
 instance Pretty Term where
-  pretty (Con () conId) = pretty conId
-  pretty (Var () varId) = pretty varId
+  pretty (Con conId) = pretty conId
+  pretty (Var varId) = pretty varId
 
 instance Pretty Atom where
-  pretty (Atom () relId terms) = pretty relId <> "(" <> T.intercalate "," (map pretty terms) <> ")"
+  pretty (Atom relId terms) = pretty relId <> "(" <> T.intercalate "," (map pretty terms) <> ")"
 
 instance Pretty Rule where
   pretty (h :- []) = pretty h <> "."
   pretty (h :- ts) = pretty h <> " :- " <> T.intercalate ", " (map pretty ts) <> "."
 
 instance Pretty Program where
-  pretty (Program () rs) = T.unlines (map pretty rs)
+  pretty (Program rs) = T.unlines (map pretty rs)

geolog-lsp.cabal

@@ -26,8 +26,7 @@ library datalog-parser
         base,
         text,
         containers,
-        megaparsec,
-        pretty-simple,
+        megaparsec
     exposed-modules:
         Datalog.Parser,
         Datalog.Syntax