datalog-lsp sensible file structure

datalog-lsp/src/Datalog/LSP.hs

@@ -1,4 +1,4 @@
-module Datalog.LSP (serverDefinition) where
+module Datalog.LSP where
 
 import Control.Monad.IO.Class
 import Language.LSP.Protocol.Message
@@ -6,31 +6,24 @@ import Language.LSP.Protocol.Types
 import Language.LSP.Server
 import Datalog.LSP.Hover (hoverHandler)
 import Datalog.LSP.Highlight (tokenHandler)
-import Datalog.LSP.Types (DLogLspM, LSPContext (LSPContext))
-import Datalog.LSP.DocChange (docChangeHandler, docOpenHandler)
-import qualified Data.Map as M
-import Control.Concurrent.STM
 
-handlers :: Handlers DLogLspM
+handlers :: Handlers (LspM ())
 handlers =
     mconcat
         [ initHandler
-        , docChangeHandler
-        , docOpenHandler
         , hoverHandler
         , tokenHandler
         ]
 
-initHandler :: Handlers DLogLspM
+initHandler :: Handlers (LspM ())
 initHandler = notificationHandler SMethod_Initialized $ \_ -> pure ()
 
-serverDefinition :: IO (ServerDefinition LSPContext)
+serverDefinition :: ServerDefinition ()
-serverDefinition = do
+serverDefinition = 
-        ref <- newTVarIO M.empty
+        ServerDefinition
-        pure $ ServerDefinition
+            { parseConfig = const $ const $ Right ()
-            { parseConfig = \c v -> Right c
             , onConfigChange = const $ pure ()
-            , defaultConfig = LSPContext ref
+            , defaultConfig = ()
             , configSection = "demo"
             , doInitialize = \env _req -> pure $ Right env
             , staticHandlers = const handlers

datalog-lsp/src/Datalog/LSP/DocChange.hs

@@ -1,77 +0,0 @@
-{-# LANGUAGE BlockArguments #-}
-
-module Datalog.LSP.DocChange (docChangeHandler, docOpenHandler) where
-
-import Control.Concurrent.STM
-import Control.Monad.Trans
-import Data.Map qualified as M
-import Data.Text qualified as T
-import Datalog.LSP.Types
-import Datalog.LSP.Utils (currentBufferText, currentBufferUri, currentBufferUriUnNormalized)
-import Datalog.Parser (parseProgram)
-import Language.LSP.Protocol.Lens (HasParams, HasTextDocument, HasUri)
-import Language.LSP.Protocol.Message (SMethod (SMethod_TextDocumentDidChange, SMethod_TextDocumentDidOpen, SMethod_TextDocumentPublishDiagnostics))
-import Language.LSP.Protocol.Types (Diagnostic (..), DiagnosticSeverity (DiagnosticSeverity_Error), Position (..), PublishDiagnosticsParams (..), Range (Range), Uri)
-import Language.LSP.Server (Handlers, MonadLsp, getConfig, notificationHandler, sendNotification)
-import Text.Megaparsec
-import qualified Data.List.NonEmpty as NE
-
-docOpenHandler :: Handlers DLogLspM
-docOpenHandler = notificationHandler SMethod_TextDocumentDidOpen updateState
-
-docChangeHandler :: Handlers DLogLspM
-docChangeHandler = notificationHandler SMethod_TextDocumentDidChange updateState
-
-updateState :: (HasParams s a1, MonadLsp LSPContext (t IO), HasUri a2 Uri, HasTextDocument a1 a2, MonadTrans t) => s -> t IO ()
-updateState req = do
-    let uri = currentBufferUri req
-    LSPContext parseStateRef <- getConfig
-    bufferText <- currentBufferText req
-    x <- lift . atomically $ do
-        v <- readTVar parseStateRef
-
-        let parsedBuffer = runParser parseProgram (show uri) bufferText
-
-        writeTVar parseStateRef $
-            M.insert uri parsedBuffer v
-
-        pure parsedBuffer
-
-    case x of
-        Left (ParseErrorBundle errs position) ->
-            let 
-                (a, b) = attachSourcePos errorOffset errs position
-            in
-            sendNotification
-                SMethod_TextDocumentPublishDiagnostics
-                PublishDiagnosticsParams
-                    { _uri = currentBufferUriUnNormalized req
-                    , _version = Nothing
-                    , _diagnostics =
-                        NE.toList . flip fmap a $ \(err, pos) ->
-                             Diagnostic
-                                { _range = Range (f pos) (f pos)
-                                , _severity = Just DiagnosticSeverity_Error
-                                , _code = Nothing
-                                , _codeDescription = Nothing
-                                , _source = Nothing
-                                , _message = T.pack . parseErrorTextPretty $ err
-                                , _tags = Nothing
-                                , _relatedInformation = Nothing
-                                , _data_ = Nothing
-                                }
-                            
-                    }
-        Right prog ->
-            sendNotification
-                SMethod_TextDocumentPublishDiagnostics
-                PublishDiagnosticsParams
-                    { _uri = currentBufferUriUnNormalized req
-                    , _version = Nothing
-                    , _diagnostics = []
-                    }
-
-f :: SourcePos -> Position
-f (SourcePos _ line column) = Position (unPos' line) (unPos' column)
-    where
-        unPos' = fromIntegral . (\x -> x - 1) . unPos

datalog-lsp/src/Datalog/LSP/Highlight.hs

@@ -1,60 +1,28 @@
 module Datalog.LSP.Highlight where
 
-import Control.Concurrent.STM
+import Control.Lens ((^.), Lens')
-import Control.Monad.Trans
 import Data.Either (fromRight)
-import Data.Map qualified as M
+import Data.Maybe (fromJust)
-import Data.Text qualified as T
+import Language.LSP.Protocol.Lens (params, textDocument, uri, HasTextDocument, HasParams, HasUri)
-import Datalog.LSP.Types (DLogLspM, LSPContext (..))
-import Datalog.LSP.Utils (currentBufferUri)
-import Datalog.Parser (SrcLoc (..))
-import Datalog.Syntax (Atom' (Atom), Program' (..), RelId (RelId), Rule' (..), Term' (..))
 import Language.LSP.Protocol.Message
 import Language.LSP.Protocol.Types
 import Language.LSP.Server
 
-tokenHandler :: Handlers DLogLspM
+tokenHandler :: Handlers (LspM ())
 tokenHandler = requestHandler SMethod_TextDocumentSemanticTokensFull $ \req responder -> do
-    LSPContext parseRef <- getConfig
+    let 
-    p <- lift . readTVarIO $ parseRef
+        openUri = toNormalizedUri $ req ^. docUri
-    case M.lookup (currentBufferUri req) p of
+        token =
-        Nothing ->
+            SemanticTokenAbsolute
-            responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Doc not bundle" Nothing)
+                { _line = 0
-        Just (Left _) ->
+                , _startChar = 0
-            responder (Left $ TResponseError (InL LSPErrorCodes_RequestFailed) "Failed to parse" Nothing)
+                , _length = 5
-        Just (Right prog) -> do
+                , _tokenType = SemanticTokenTypes_Keyword
-            responder
+                , _tokenModifiers = []
-                ( Right
+                }
-                    . InL
+        tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token]
-                    . fromRight (error "")
+    c <- fromJust <$> getVirtualFile openUri
-                    . makeSemanticTokens defaultSemanticTokensLegend
+    responder (Right $ InL tokens)
-                    $ highlightProg prog
-                )
 
-highlightProg :: Program' SrcLoc -> [SemanticTokenAbsolute]
+docUri :: (HasParams s s1,  HasTextDocument s1 s2, HasUri s2 a) => Lens' s a 
-highlightProg (Program _ rs) = rs >>= highlightRule
+docUri = params . textDocument . uri
-
-highlightRule :: Rule' SrcLoc -> [SemanticTokenAbsolute]
-highlightRule (Rule _ a as) = a : as >>= highlightAtom
-
-highlightAtom :: Atom' SrcLoc -> [SemanticTokenAbsolute]
-highlightAtom (Atom loc (RelId relId) ts) = highlightRel ++ (ts >>= highlightTerm)
-  where
-    highlightRel = pure $ tokenFromSrcLoc loc' SemanticTokenTypes_Interface
-    loc' = loc{endCol = startCol loc + length (T.unpack relId)}
-
-highlightTerm :: Term' SrcLoc -> [SemanticTokenAbsolute]
-highlightTerm =
-    pure <$> \case
-        Con loc _ -> tokenFromSrcLoc loc SemanticTokenTypes_Number
-        Var loc _ -> tokenFromSrcLoc loc SemanticTokenTypes_Keyword
-
-tokenFromSrcLoc :: SrcLoc -> SemanticTokenTypes -> SemanticTokenAbsolute
-tokenFromSrcLoc (SrcLoc sl sc _ ec) tokenType =
-    SemanticTokenAbsolute
-        { _line = fromIntegral $ sl - 1
-        , _startChar = fromIntegral $ sc - 1
-        , _length = fromIntegral $ ec - sc
-        , _tokenType = tokenType
-        , _tokenModifiers = []
-        }

datalog-lsp/src/Datalog/LSP/Hover.hs

@@ -7,9 +7,8 @@ import Language.LSP.Protocol.Message
 import Language.LSP.Protocol.Types
 import Language.LSP.Server
 import Language.LSP.VFS (virtualFileText)
-import Datalog.LSP.Types (DLogLspM)
 
-hoverHandler :: Handlers DLogLspM
+hoverHandler :: Handlers (LspM ())
 hoverHandler = requestHandler SMethod_TextDocumentHover $ \req responder -> do
     let
         openUri = toNormalizedUri $ req ^. docUri

datalog-lsp/src/Datalog/LSP/Types.hs

@@ -1,20 +0,0 @@
-module Datalog.LSP.Types (DLogLspM, LSPContext(..)) where
-
-import Control.Monad.Reader (ReaderT)
-import Language.LSP.Server (LspM)
-import Control.Concurrent.STM (TVar)
-import Text.Megaparsec
-import Data.Text (Text)
-import Data.Void (Void)
-import Data.Map (Map)
-import Language.LSP.Protocol.Types qualified as J
-import Datalog.Syntax (Program')
-import Datalog.Parser (SrcLoc)
-
-type DLogLspM = LspM LSPContext
-
-type UriBundle a = Map J.NormalizedUri a
-
-data LSPContext = LSPContext
-    { parseState :: TVar (UriBundle (Either (ParseErrorBundle Text Void) (Program' SrcLoc)))
-    }

datalog-lsp/src/Datalog/LSP/Utils.hs

@@ -1,19 +0,0 @@
-module Datalog.LSP.Utils where
-
-import Control.Lens
-import Data.Maybe
-import Data.Text qualified as T
-import Language.LSP.Protocol.Lens
-import Language.LSP.Protocol.Types
-import Language.LSP.Server
-import Language.LSP.VFS
-
-currentBufferText :: (MonadLsp config f, HasParams s a1, HasTextDocument a1 a2,  HasUri a2 Uri) => s -> f T.Text
-currentBufferText req = virtualFileText . fromJust <$> getVirtualFile (currentBufferUri req)
-
-currentBufferUri :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 Uri) => s -> NormalizedUri
-currentBufferUri = toNormalizedUri . currentBufferUriUnNormalized
-
-currentBufferUriUnNormalized :: (HasParams s a1, HasTextDocument a1 a2, HasUri a2 a3) => s -> a3
-currentBufferUriUnNormalized req = req ^. (params . textDocument . uri)
-

datalog-lsp/src/Main.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 import Datalog.LSP (serverDefinition)
 import Language.LSP.Server (runServer)
 
 main :: IO Int
-main = serverDefinition >>= runServer 
+main = runServer serverDefinition

datalog/src/Datalog/Parser.hs

@@ -5,15 +5,14 @@ module Datalog.Parser (
     parseTerm,
     parseRule,
     parseProgram,
-    SrcLoc (..),
 )
 where
 
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Void (Void)
-import Datalog.Syntax (Atom' (..), Program' (..), Rule' (..), Term' (..))
 import Datalog.Syntax hiding (Atom, Program, Rule, Term)
+import Datalog.Syntax (Atom' (..), Program' (..), Rule' (..), Term' (..))
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
@@ -21,14 +20,6 @@ import Text.Pretty.Simple
 
 type Parser = Parsec Void Text
 
-data SrcLoc = SrcLoc
-    { startLine :: Int
-    , startCol :: Int
-    , endLine :: Int
-    , endCol :: Int
-    }
-    deriving (Show)
-
 type Atom = Atom' SrcLoc
 type Term = Term' SrcLoc
 type Rule = Rule' SrcLoc
@@ -73,8 +64,7 @@ parseQuery :: Parser [Atom]
 parseQuery = parseAtom `sepBy` comma
 
 parseRule :: Parser Rule
-parseRule =
+parseRule = parseThingWithSub (\loc (a, as) -> Rule loc a as) $
-    parseThingWithSub (\loc (a, as) -> Rule loc a as) $
         try rule1 <|> rule2
   where
     rule1 = do
@@ -92,10 +82,23 @@ parseProgram = parseThingWithSub Program (many parseRule)
 
 parseThingWithSub :: (SrcLoc -> c -> f SrcLoc) -> Parser c -> Parser (f SrcLoc)
 parseThingWithSub f parseSub = do
-    SourcePos _ sl sc <- getSourcePos
+    s <- getSourcePos
     c <- parseSub
-    SourcePos _ el ec <- getSourcePos
+    e <- getSourcePos
-    pure $ f (SrcLoc (unPos sl) (unPos sc) (unPos el) (unPos ec)) c
+    pure $ f (SrcLoc s e) c
+
+annotateSrcLoc :: (Functor f) => Parser (f a) -> Parser (f SrcLoc)
+annotateSrcLoc p = do
+    s <- getSourcePos
+    res <- p
+    f <- getSourcePos
+    pure (SrcLoc s f <$ res)
+
+data SrcLoc = SrcLoc
+    { start :: SourcePos
+    , end :: SourcePos
+    }
+    deriving (Show)
 
 test = do
     let r = runParser parseProgram "???" prog

flake.nix

@@ -43,7 +43,7 @@
             ghcid
           ];
         };
-        packages.default = haskell.packages."geolog-lsp:exe:datalog-lsp";
+        packages.default = haskell.packages."geolog-lsp:exe:geolog-lsp";
       }
     );
 }

geolog-lsp.cabal

@@ -28,7 +28,6 @@ library datalog-parser
         containers,
         megaparsec,
         pretty-simple,
-        lens
     exposed-modules:
         Datalog.Parser,
         Datalog.Syntax
@@ -43,17 +42,10 @@ executable datalog-lsp
                       lsp,
                       text,
                       containers,
-                      lens,
+                      lens
-                      megaparsec,
-                      datalog-parser,
-                      mtl,
-                      stm
     other-modules:
         Datalog.LSP
-        Datalog.LSP.DocChange
-        Datalog.LSP.Types
         Datalog.LSP.Highlight
         Datalog.LSP.Hover
-        Datalog.LSP.Utils
     hs-source-dirs:   datalog-lsp/src
     default-language: GHC2024

nvim-setup.lua

@@ -1,11 +1,10 @@
 vim.filetype.add({
     extension = {
-        mydatalog = "dl"
+        lsptest = "lsptest"
     }
 })
-vim.lsp.config['mydatalog'] = {
+vim.lsp.config['geolog'] = {
-    cmd = { './result/bin/datalog-lsp' },
+    cmd = { './result/bin/geolog-lsp' },
-    filetypes = { 'mydatalog' }
+    filetypes = { 'lsptest'}
 }
-vim.lsp.enable('mydatalog')
+vim.lsp.enable('geolog')
-

test.dl

@@ -1,11 +0,0 @@
-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(X,Y) :- r(Y,X).