Current progress

datalog/src/Datalog/Parser.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE MultilineStrings #-}
-{-# LANGUAGE BlockArguments #-}
 
 module Datalog.Parser (
     parseTerm,
@@ -50,53 +49,32 @@ parseVar = Var () . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaN
 parseTerm :: Parser Term
 parseTerm = parseVar <|> parseCon
 
-parseAtom :: Parser Atom
+parseAtom :: Parser (Atom' SrcLoc)
-parseAtom = do
+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 :: Parser (Rule' SrcLoc)
-parseFact = do
+parseFact = annotateSrcLoc $ do
     headAtom <- parseAtom
     period
-    return (Rule () headAtom [])
+    return (Rule NoLoc headAtom [])
 
-parseRule :: Parser Rule
+parseRule :: Parser (Rule' SrcLoc)
 parseRule =
-    try parseFact <|> do
+    annotateSrcLoc $
-        headAtom <- parseAtom <* symbol ":-"
+        try parseFact <|> do
-        bodyAtoms <- parseQuery
+            headAtom <- parseAtom <* symbol ":-"
-        period
+            bodyAtoms <- parseQuery
-        return (Rule () headAtom bodyAtoms)
+            period
-parseRule' :: Parser (Rule' SrcLoc)
+            return (Rule NoLoc headAtom bodyAtoms)
-parseRule' = _
 
--- parseProgram :: Parser Program
 parseProgram :: Parser (Program' SrcLoc)
-parseProgram = do
+parseProgram = annotateSrcLoc $ Program NoLoc <$> many parseRule
-    -- annotateSrcLoc $
-    s <- getSourcePos
-    c <- many parseRule'
-    e <- getSourcePos
-    -- Program _ <$> many parseRule
-    pure $ Program (SrcLoc s e) c
-
-parseProgram' :: Parser (Program' SrcLoc)
-parseProgram' = parseThingWithSub (many parseRule') Program
-
-parseThingWithSub :: (Parser c) -> (SrcLoc -> c -> f SrcLoc) -> Parser (f SrcLoc)
-parseThingWithSub parseSub f = do
-    -- annotateSrcLoc $
-    s <- getSourcePos
-    -- c <- many parseRule'
-    c <- parseSub
-    e <- getSourcePos
-    -- Program _ <$> many parseRule
-    pure $ f (SrcLoc s e) c
 
 annotateSrcLoc :: (Functor f) => Parser (f a) -> Parser (f SrcLoc)
 annotateSrcLoc p = do
@@ -105,10 +83,12 @@ annotateSrcLoc p = do
     f <- getSourcePos
     pure (SrcLoc s f <$ res)
 
-data SrcLoc = SrcLoc
+data SrcLoc
-    { start :: SourcePos
+    = SrcLoc
-    , end :: SourcePos
+        { start :: SourcePos
-    }
+        , end :: SourcePos
+        }
+    | NoLoc
     deriving (Show)
 
 test = do

datalog/src/Datalog/Syntax.hs

@@ -3,23 +3,23 @@
 module Datalog.Syntax where
 
 import Data.Char (isUpper)
-import Data.Set (Set)
-import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Set qualified as Set
+import Data.Set (Set)
 
 newtype ConId = ConId Text
-    deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show)
 
 newtype VarId = VarId Text
-    deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show)
 
 newtype RelId = RelId Text
-    deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show)
 
 type Term = Term' ()
 data Term' a = Con a ConId | Var a VarId
-    deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show)
 
 con :: Text -> Term
 con = Con () . ConId
@@ -32,64 +32,74 @@ 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]
-    deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show)
 
 atom :: Text -> [Text] -> Atom
 atom relName args = Atom () (RelId relName) (map term args)
 
 type Rule = Rule' ()
 data Rule' a = Rule a (Atom' a) [Atom' a]
-    deriving (Eq, Ord, Show)
+  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]
-    deriving (Eq, Ord, Show)
+  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
+  constants :: a -> Set ConId
 
 instance HasConstants (Term' a) where
-    constants t = case t of
+  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
+instance HasConstants a => HasConstants [a] where
-    constants xs = Set.unions (map constants xs)
+  constants xs = Set.unions (map constants xs)
 
 instance HasConstants (Atom' a) where
-    constants (Atom _ _ ts) = constants ts
+  constants (Atom _ _ ts) = constants ts
 
 instance HasConstants (Rule' a) where
-    constants (h :- b) = Set.union (constants h) (constants b)
+  constants (h :- b) = Set.union (constants h) (constants b)
 
 instance HasConstants (Program' a) where
-    constants (Program _ rs) = constants rs
+  constants (Program _ rs) = constants rs
 
 class Pretty t where
-    pretty :: t -> Text
+  pretty :: t -> Text
 
 instance Pretty ConId where
-    pretty (ConId t) = t
+  pretty (ConId t) = t
 
 instance Pretty VarId where
-    pretty (VarId t) = t
+  pretty (VarId t) = t
 
 instance Pretty RelId where
-    pretty (RelId t) = t
+  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 :- []) = pretty h <> "."
-    pretty (h :- ts) = pretty h <> " :- " <> T.intercalate ", " (map pretty ts) <> "."
+  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)