wipp

datalog/src/Datalog/Parser.hs

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

datalog/src/Datalog/Syntax.hs

@@ -3,10 +3,10 @@
 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)
@@ -48,16 +48,6 @@ 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
 
@@ -66,7 +56,7 @@ instance HasConstants (Term' a) where
         Con _ x -> Set.singleton x
         Var _ _ -> Set.empty
 
-instance HasConstants a => HasConstants [a] where
+instance (HasConstants a) => HasConstants [a] where
     constants xs = Set.unions (map constants xs)
 
 instance HasConstants (Atom' a) where