Current progress

datalog/src/Datalog/Parser.hs

@@ -1,18 +1,18 @@
 {-# LANGUAGE MultilineStrings #-}
 
-module Datalog.Parser
-    ( parseTerm
-    , parseAtom
-    , parseRule
-    , parseQuery
-    , parseProgram
-    )
-  where
+module Datalog.Parser (
+    parseTerm,
+    parseAtom,
+    parseRule,
+    parseQuery,
+    parseProgram,
+)
+where
 
-import Datalog.Syntax
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Void (Void)
+import Datalog.Syntax
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
@@ -27,10 +27,11 @@ symbol :: (MonadParsec e Text m) => Text -> m Text
 symbol = L.symbol whitespace
 
 whitespace :: (MonadParsec e Text m) => m ()
-whitespace = L.space
-  space1
-  (L.skipLineComment "--")
-  (L.skipBlockComment "{-" "-}")
+whitespace =
+    L.space
+        space1
+        (L.skipLineComment "--")
+        (L.skipBlockComment "{-" "-}")
 
 parens :: (MonadParsec e Text m) => m a -> m a
 parens = between (symbol "(") (symbol ")")
@@ -48,57 +49,63 @@ parseVar = Var () . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaN
 parseTerm :: Parser Term
 parseTerm = parseVar <|> parseCon
 
-parseAtom :: Parser Atom
-parseAtom = do
-  rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
-  args <- parens (parseTerm `sepBy` comma)
-  return (Atom () rel args)
+parseAtom :: Parser (Atom' SrcLoc)
+parseAtom = annotateSrcLoc $ do
+    rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
+    args <- parens (parseTerm `sepBy` comma)
+    return (Atom () rel args)
 
-parseQuery :: Parser [Atom]
+parseQuery :: Parser [Atom' SrcLoc]
 parseQuery = parseAtom `sepBy` comma
 
-parseFact :: Parser Rule
-parseFact = do
-  headAtom <- parseAtom
-  period
-  return (Rule () headAtom [])
+parseFact :: Parser (Rule' SrcLoc)
+parseFact = annotateSrcLoc $ do
+    headAtom <- parseAtom
+    period
+    return (Rule NoLoc headAtom [])
 
-parseRule :: Parser Rule
-parseRule = try parseFact <|> do
-  headAtom <- parseAtom <* symbol ":-"
-  bodyAtoms <- parseQuery
-  period
-  return (Rule () headAtom bodyAtoms)
+parseRule :: Parser (Rule' SrcLoc)
+parseRule =
+    annotateSrcLoc $
+        try parseFact <|> do
+            headAtom <- parseAtom <* symbol ":-"
+            bodyAtoms <- parseQuery
+            period
+            return (Rule NoLoc headAtom bodyAtoms)
 
-parseProgram :: Parser Program
-parseProgram = Program () <$> many parseRule
+parseProgram :: Parser (Program' SrcLoc)
+parseProgram = annotateSrcLoc $ Program NoLoc <$> many parseRule
 
-annotateSrcLoc :: Functor f => Parser (f a) -> Parser (f SrcLoc)
+annotateSrcLoc :: (Functor f) => Parser (f a) -> Parser (f SrcLoc)
 annotateSrcLoc p = do
     s <- getSourcePos
     res <- p
     f <- getSourcePos
     pure (SrcLoc s f <$ res)
 
-data SrcLoc = SrcLoc
-  { start :: SourcePos
-  , end :: SourcePos
-  } deriving Show
+data SrcLoc
+    = SrcLoc
+        { start :: SourcePos
+        , end :: SourcePos
+        }
+    | NoLoc
+    deriving (Show)
 
 test = do
-  let r = runParser parseProgram "???" prog
-  pPrint @IO r
+    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).
+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(0,1).
+    r(1,2).
+    r(2,3).
+    r(3,4).
+    r(4,5).
 
-  r(X,Y) :- r(Y,X).
-  """
+    r(X,Y) :- r(Y,X).
+    """

datalog/src/Datalog/Syntax.hs

@@ -48,6 +48,16 @@ type Program = Program' ()
 data Program' a = Program a [Rule' a]
   deriving (Eq, Ord, Show)
 
+class Decorable t where
+    decorateNode :: a -> t a -> t a
+
+instance (Decorable Program') where decorateNode x (Program _ rs) = Program x rs
+instance (Decorable Rule') where decorateNode x (Rule _ a as) = Rule x a as
+instance (Decorable Atom') where decorateNode x (Atom _ relId ts) = Atom x relId ts
+instance (Decorable Term') where 
+    decorateNode x (Var _ varId) = Var x varId
+    decorateNode x (Con _ conId) = Con x conId
+
 class HasConstants a where
   constants :: a -> Set ConId