Refactor to add metadata

datalog/src/Datalog/Parser.hs

@@ -37,10 +37,10 @@ comma = () <$ symbol ","
 period = () <$ symbol "."
 
 parseCon :: (MonadParsec e Text m) => m Term
-parseCon = Con . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
+parseCon = Con () . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
 
 parseVar :: (MonadParsec e Text m) => m Term
-parseVar = Var . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
+parseVar = Var () . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
 
 parseTerm :: Parser Term
 parseTerm = parseVar <|> parseCon
@@ -49,7 +49,7 @@ parseAtom :: Parser Atom
 parseAtom = do
   rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
   args <- parens (parseTerm `sepBy` comma)
-  return (Atom rel args)
+  return (Atom () rel args)
 
 parseQuery :: Parser [Atom]
 parseQuery = parseAtom `sepBy` comma
@@ -68,4 +68,4 @@ parseRule = try parseFact <|> do
   return (headAtom :- bodyAtoms)
 
 parseProgram :: Parser Program
-parseProgram = Program <$> many parseRule
+parseProgram = Program () <$> many parseRule

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' () -> [Atom' ()] -> Rule' ()
+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
-    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 where
-  constants (Atom _ ts) = constants ts
+instance HasConstants (Atom' a) where
+  constants (Atom _ _ ts) = constants ts
 
-instance HasConstants Rule where
-  constants (h :- b) = Set.union (constants h) (constants b)
+instance HasConstants (Rule' a) where
+  constants (Rule _ h b) = Set.union (constants h) (constants b)
 
-instance HasConstants Program where
-  constants (Program rs) = constants rs
+instance HasConstants (Program' a) where
+  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 (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)