diff --git a/datalog/src/Datalog/Parser.hs b/datalog/src/Datalog/Parser.hs index d5c8707..766c4a2 100644 --- a/datalog/src/Datalog/Parser.hs +++ b/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 diff --git a/datalog/src/Datalog/Syntax.hs b/datalog/src/Datalog/Syntax.hs index 7ed4939..9cfb858 100644 --- a/datalog/src/Datalog/Syntax.hs +++ b/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)