refactor repo to datalog/datalog-lsp

datalog-lsp/src/Main.hs

@@ -35,7 +35,7 @@ handlers =
                         , _tokenModifiers = []
                         }
                 tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
-
+            c <- fromJust <$> getVirtualFile docUri
             responder (Right $ InL tokens)
         ]
 

datalog/src/Datalog/Parser.hs

@@ -0,0 +1,71 @@
+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 Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as L
+
+type Parser = Parsec Void Text
+
+lexeme :: (MonadParsec e Text m) => m a -> m a
+lexeme = L.lexeme whitespace
+
+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 "{-" "-}")
+
+parens :: (MonadParsec e Text m) => m a -> m a
+parens = between (symbol "(") (symbol ")")
+
+comma, period :: (MonadParsec e Text m) => m ()
+comma = () <$ symbol ","
+period = () <$ symbol "."
+
+parseCon :: (MonadParsec e Text m) => m Term
+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))
+
+parseTerm :: Parser Term
+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)
+
+parseQuery :: Parser [Atom]
+parseQuery = parseAtom `sepBy` comma
+
+parseFact :: Parser Rule
+parseFact = do
+  headAtom <- parseAtom
+  period
+  return (headAtom :- [])
+
+parseRule :: Parser Rule
+parseRule = try parseFact <|> do
+  headAtom <- parseAtom <* symbol ":-"
+  bodyAtoms <- parseQuery
+  period
+  return (headAtom :- bodyAtoms)
+
+parseProgram :: Parser Program
+parseProgram = Program <$> many parseRule

datalog/src/Datalog/Syntax.hs

@@ -0,0 +1,86 @@
+module Datalog.Syntax where
+
+import Data.Char (isUpper)
+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)
+
+newtype VarId = VarId Text
+  deriving (Eq, Ord, Show)
+
+newtype RelId = RelId Text
+  deriving (Eq, Ord, Show)
+
+data Term = Con ConId | Var VarId
+  deriving (Eq, Ord, Show)
+
+con :: Text -> Term
+con = Con . ConId
+
+var :: Text -> Term
+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]
+  deriving (Eq, Ord, Show)
+
+atom :: Text -> [Text] -> Atom
+atom relName args = Atom (RelId relName) (map term args)
+
+data Rule = Atom :- [Atom]
+  deriving (Eq, Ord, Show)
+
+data Program = Program [Rule]
+  deriving (Eq, Ord, Show)
+
+class HasConstants a where
+  constants :: a -> Set ConId
+
+instance HasConstants Term where
+  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 Atom where
+  constants (Atom _ ts) = constants ts
+
+instance HasConstants Rule where
+  constants (h :- b) = Set.union (constants h) (constants b)
+
+instance HasConstants Program where
+  constants (Program rs) = constants rs
+
+class Pretty t where
+  pretty :: t -> Text
+
+instance Pretty ConId where
+  pretty (ConId t) = t
+
+instance Pretty VarId where
+  pretty (VarId t) = t
+
+instance Pretty RelId where
+  pretty (RelId t) = t
+
+instance Pretty Term where
+  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) <> ")"
+
+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)

geolog-lsp.cabal

@@ -18,17 +18,29 @@ common warnings
 common extensions
     default-extensions:
         OverloadedRecordDot
+        OverloadedStrings
 
-executable geolog-lsp
+library datalog-parser
+    import: warnings, extensions
+    build-depends:
+        base,
+        text,
+        containers,
+        megaparsec
+    exposed-modules:
+        Datalog.Parser,
+        Datalog.Syntax
+    hs-source-dirs: datalog/src
+    default-language: GHC2024
+
+executable datalog-lsp
     import:           warnings, extensions
     main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
     build-depends:
                       base,
                       lsp,
                       text,
                       containers,
                       lens
-    hs-source-dirs:   src
+    hs-source-dirs:   datalog-lsp/src
     default-language: GHC2024