wip - have fun

datalog/src/Datalog/Parser.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE MultilineStrings #-}
+
 module Datalog.Parser
     ( parseTerm
     , parseAtom
@@ -14,6 +16,7 @@ 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
 
@@ -36,36 +39,63 @@ comma, period :: (MonadParsec e Text m) => m ()
 comma = () <$ symbol ","
 period = () <$ symbol "."
 
-parseCon :: (MonadParsec e Text m) => m Term
+parseCon :: (MonadParsec e Text m) => m (Term' SrcLoc)
-parseCon = Con . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
+parseCon = Con dummy . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
 
-parseVar :: (MonadParsec e Text m) => m Term
+parseVar :: (MonadParsec e Text m) => m (Term' SrcLoc)
-parseVar = Var . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
+parseVar = Var dummy . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
 
-parseTerm :: Parser Term
+parseTerm :: Parser (Term' SrcLoc)
 parseTerm = parseVar <|> parseCon
 
-parseAtom :: Parser Atom
+parseAtom :: Parser (Atom' SrcLoc)
 parseAtom = do
+  p <- getSourcePos
   rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
   args <- parens (parseTerm `sepBy` comma)
-  return (Atom rel args)
+  return (Atom SrcLoc{start = p} rel args)
 
-parseQuery :: Parser [Atom]
+parseQuery :: Parser [Atom' SrcLoc]
 parseQuery = parseAtom `sepBy` comma
 
-parseFact :: Parser Rule
+parseFact :: Parser (Rule' SrcLoc)
 parseFact = do
+  p <- getSourcePos
   headAtom <- parseAtom
   period
-  return (headAtom :- [])
+  return (Rule SrcLoc{start = p} headAtom [])
 
-parseRule :: Parser Rule
+parseRule :: Parser (Rule' SrcLoc)
 parseRule = try parseFact <|> do
+  p <- getSourcePos
   headAtom <- parseAtom <* symbol ":-"
   bodyAtoms <- parseQuery
   period
-  return (headAtom :- bodyAtoms)
+  return (Rule SrcLoc{start = p} headAtom bodyAtoms)
 
-parseProgram :: Parser Program
+parseProgram :: Parser (Program' SrcLoc)
-parseProgram = Program <$> many parseRule
+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).
+  """

datalog/src/Datalog/Syntax.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
 module Datalog.Syntax where
 
 import Data.Char (isUpper)
@@ -15,49 +17,56 @@ newtype VarId = VarId Text
 newtype RelId = RelId Text
   deriving (Eq, Ord, Show)
 
-data Term = Con ConId | Var VarId
+type Term = Term' ()
+data Term' a = Con a ConId | Var a 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
 
-data Atom = Atom RelId [Term]
+type Atom = Atom' ()
+data Atom' a = Atom a RelId [Term' a]
   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)
 
-data Rule = Atom :- [Atom]
+type Rule = Rule' ()
+data Rule' a = Rule a (Atom' a) [Atom' a]
   deriving (Eq, Ord, Show)
+{-# COMPLETE (:-) #-}
+pattern (:-) :: Atom' a -> [Atom' a] -> Rule' a
+pattern a :- b <- Rule _ a b
 
-data Program = Program [Rule]
+type Program = Program' ()
+data Program' a = Program a [Rule' a]
   deriving (Eq, Ord, Show)
 
 class HasConstants a where
   constants :: a -> Set ConId
 
-instance HasConstants Term where
+instance HasConstants (Term' a) where
   constants t = case t of
-    Con x -> Set.singleton x
+    Con _ x -> Set.singleton x
-    Var _ -> Set.empty
+    Var _ _ -> Set.empty
 
 instance HasConstants a => HasConstants [a] where
   constants xs = Set.unions (map constants xs)
 
-instance HasConstants Atom where
+instance HasConstants (Atom' a) where
-  constants (Atom _ ts) = constants ts
+  constants (Atom _ _ ts) = constants ts
 
-instance HasConstants Rule where
+instance HasConstants (Rule' a) where
   constants (h :- b) = Set.union (constants h) (constants b)
 
-instance HasConstants Program where
+instance HasConstants (Program' a) where
-  constants (Program rs) = constants rs
+  constants (Program _ rs) = constants rs
 
 class Pretty t where
   pretty :: t -> Text
@@ -72,15 +81,15 @@ instance Pretty RelId where
   pretty (RelId t) = t
 
 instance Pretty Term where
-  pretty (Con conId) = pretty conId
+  pretty (Con () conId) = pretty conId
-  pretty (Var varId) = pretty varId
+  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,7 +26,8 @@ library datalog-parser
         base,
         text,
         containers,
-        megaparsec
+        megaparsec,
+        pretty-simple,
     exposed-modules:
         Datalog.Parser,
         Datalog.Syntax