From 8dc5cd3c173f2c4bfd6307e8b71a2d3104b8aa35 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 3 Mar 2026 11:14:25 +0000 Subject: [PATCH] format --- datalog/src/Datalog/Parser.hs | 86 ++++++++++++++++++----------------- datalog/src/Datalog/Syntax.hs | 56 +++++++++++------------ 2 files changed, 73 insertions(+), 69 deletions(-) diff --git a/datalog/src/Datalog/Parser.hs b/datalog/src/Datalog/Parser.hs index 506a16a..56f8bdf 100644 --- a/datalog/src/Datalog/Parser.hs +++ b/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 ")") @@ -50,30 +51,31 @@ 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) + rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar)) + args <- parens (parseTerm `sepBy` comma) + return (Atom () rel args) parseQuery :: Parser [Atom] parseQuery = parseAtom `sepBy` comma parseFact :: Parser Rule parseFact = do - headAtom <- parseAtom - period - return (Rule () headAtom []) + headAtom <- parseAtom + period + return (Rule () headAtom []) parseRule :: Parser Rule -parseRule = try parseFact <|> do - headAtom <- parseAtom <* symbol ":-" - bodyAtoms <- parseQuery - period - return (Rule () headAtom bodyAtoms) +parseRule = + try parseFact <|> do + headAtom <- parseAtom <* symbol ":-" + bodyAtoms <- parseQuery + period + return (Rule () headAtom bodyAtoms) parseProgram :: Parser Program parseProgram = Program () <$> 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 @@ -81,24 +83,26 @@ annotateSrcLoc p = do pure (SrcLoc s f <$ res) data SrcLoc = SrcLoc - { start :: SourcePos - , end :: SourcePos - } deriving Show + { start :: SourcePos + , end :: SourcePos + } + 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). + """ diff --git a/datalog/src/Datalog/Syntax.hs b/datalog/src/Datalog/Syntax.hs index 5f3bab5..e06cae8 100644 --- a/datalog/src/Datalog/Syntax.hs +++ b/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,64 @@ 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 HasConstants a where - constants :: a -> Set ConId + constants :: a -> Set ConId instance HasConstants (Term' a) where - constants t = case t of - Con _ x -> Set.singleton x - Var _ _ -> Set.empty + constants t = case t of + Con _ x -> Set.singleton x + Var _ _ -> Set.empty -instance HasConstants a => HasConstants [a] where - constants xs = Set.unions (map constants xs) +instance (HasConstants a) => HasConstants [a] where + 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 (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) <> "." + 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)