hsinspect-lsp 0.0.3 → 0.0.4

raw patch · 4 files changed

+148/−22 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• exe/Main.hs +55/−13
• hsinspect-lsp.cabal +1/−1
• library/HsInspect/LSP/Context.hs +1/−2
• library/HsInspect/LSP/Impl.hs +91/−6

@@ -23,6 +23,7 @@ import Language.Haskell.LSP.Messages import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Utility as U+import qualified Language.Haskell.LSP.VFS as VFS import System.Environment (getArgs) import System.Exit import qualified System.Log.Logger as L@@ -35,7 +36,7 @@ #endif  help :: String-help = "hsinspect-lsp [--help|version|stack]\n"+help = "hsinspect-lsp [--help|version]\n"  -- TODO automated integration tests, e.g. using Emacs lsp-mode main :: IO ()@@ -50,6 +51,19 @@     0 -> exitSuccess     c -> exitWith . ExitFailure $ c +syncOptions :: J.TextDocumentSyncOptions+syncOptions = J.TextDocumentSyncOptions+  { J._openClose         = Just True+  , J._change            = Just J.TdSyncIncremental+  , J._willSave          = Just False+  , J._willSaveWaitUntil = Just False+  , J._save              = Just $ J.SaveOptions $ Just False+  }++lspOptions :: Core.Options+lspOptions = def { Core.textDocumentSync = Just syncOptions+                 }+ -- TODO replace haskell-lsp (which is huge!) with a minimal jsonrpc --      implementation that covers only the things we actually support. The --      advantage would be to speedup installation for the user.@@ -70,11 +84,10 @@       }    flip E.finally L.removeAllHandlers $ do-    Core.setupLogger Nothing [] L.DEBUG-    CTRL.run callbacks (lspHandlers rin) lspOptions Nothing+    Core.setupLogger (Just "/tmp/hsinspect.log") [] L.DEBUG+    CTRL.run callbacks (lspHandlers rin) lspOptions (Just "/tmp/hsinspect-session.log")    where-    lspOptions = def     ioExcept   (e :: E.IOException) = print e >> return 1     someExcept (e :: E.SomeException) = print e >> return 1 @@ -88,6 +101,9 @@   caches <- Caches <$> C.newCache Nothing <*> C.newCache Nothing <*> C.newCache Nothing   let toPos (J.Position line col) = (line + 1, col + 1) -- LSP is zero indexed, ghc is one indexed       toFile (J.TextDocumentIdentifier doc) = J.uriToFilePath doc+      toFileAndNormalizedUri (J.TextDocumentIdentifier doc) =+        (,) <$> J.uriToFilePath doc <*> pure (J.toNormalizedUri doc)+   forever $ do     inval <- atomically $ readTChan inp     case inval of@@ -117,18 +133,39 @@                          (Just $ J.Range (J.Position line' col') (J.Position line'' col''))             Core.sendFunc lf . RspHover $ Core.makeResponseMessage req (Just halp) -      ReqCompletion req@(J.RequestMessage _ _ _ (J.CompletionParams (toFile -> Just file) (toPos -> pos) _ _)) -> do-        U.logs $ "reactor:complete:" ++ show (file, pos)-        res <- runExceptT $ completionProvider caches file pos+      ReqCompletion req@(J.RequestMessage _ _ _ (J.CompletionParams (toFileAndNormalizedUri -> Just (filePath, uri)) (toPos -> pos) _ _)) -> do+        -- let fileUri :: J.NormalizedUri+        -- -- fileUri  = notification ^. J.params+        -- --                          . J.textDocument+        -- --                          . J.uri+        -- --                          . to J.toNormalizedUri+        U.logs $ "reactor:complete:" ++ show (uri, pos)+        mFile <- Core.getVirtualFileFunc lf uri+        U.logs $ "mfile contents: " ++ show (VFS.virtualFileText <$> mFile)         let none = J.Completions $ J.List []-        case res of-          Left err -> do-            U.logs $ "reactor:complete:err:" ++ err+        case mFile of+          Just file -> do+            res <- runExceptT $ completionProvider caches filePath (VFS.virtualFileText file) pos+            case res of+              Left err -> do+                U.logs $ "reactor:complete:err:" ++ err+                Core.sendFunc lf . RspCompletion $ Core.makeResponseMessage req none++              Right symbols -> do+                let render txt = J.CompletionItem txt Nothing (J.List []) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+                Core.sendFunc lf . RspCompletion $ Core.makeResponseMessage req (J.Completions . J.List $ render <$> symbols)+          Nothing -> do             Core.sendFunc lf . RspCompletion $ Core.makeResponseMessage req none+        -- res <- runExceptT $ completionProvider caches file pos+        -- let none = J.Completions $ J.List []+        -- case res of+        --   Left err -> do+        --     U.logs $ "reactor:complete:err:" ++ err+        --     Core.sendFunc lf . RspCompletion $ Core.makeResponseMessage req none -          Right symbols -> do-            let render txt = J.CompletionItem txt Nothing (J.List []) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing-            Core.sendFunc lf . RspCompletion $ Core.makeResponseMessage req (J.Completions . J.List $ render <$> symbols)+        --   Right symbols -> do+        --     let render txt = J.CompletionItem txt Nothing (J.List []) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+        --     Core.sendFunc lf . RspCompletion $ Core.makeResponseMessage req (J.Completions . J.List $ render <$> symbols)        -- preemptively populate caches       NotDidOpenTextDocument (J.NotificationMessage _ _ params) -> do@@ -142,6 +179,8 @@         case populated of           Right _ -> pure ()           Left err ->+            -- TODO cache when we send errors so we don't end up spamming the+            --      user, limit to one popup per package.             Core.sendFunc lf . NotShowMessage .               J.NotificationMessage "2.0" J.WindowShowMessage .                 J.ShowMessageParams J.MtWarning $ T.pack err@@ -162,6 +201,9 @@          , Core.definitionHandler = Just $ passHandler ReqDefinition          , Core.initializedHandler = Just $ passHandler NotInitialized          , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler NotDidOpenTextDocument+         , Core.didSaveTextDocumentNotificationHandler   = Just $ passHandler NotDidSaveTextDocument+         , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler NotDidChangeTextDocument+         , Core.didCloseTextDocumentNotificationHandler  = Just $ passHandler NotDidCloseTextDocument          -- Emacs lsp-mode sends these, even though we don't ask for them...          , Core.cancelNotificationHandler = Just $ passHandler NotCancelRequestFromClient          , Core.responseHandler = Just $ \_ -> pure ()

@@ -1,6 +1,6 @@ cabal-version: 2.2 name:          hsinspect-lsp-version:       0.0.3+version:       0.0.4 synopsis:      LSP interface over the hsinspect binary. license:       GPL-3.0-or-later license-file:  LICENSE

@@ -4,8 +4,7 @@ -- discovered from the file that the user is currently visiting. -- -- This module gathers the definition of the context and the logic to infer it,--- which assumes that .cabal (or package.yaml) and .ghc.flags files are present,--- and that the build tool is either cabal-install or stack.+-- which assumes that .cabal (or package.yaml) and .ghc.flags files are present. module HsInspect.LSP.Context where  import Control.Monad.IO.Class (liftIO)

@@ -5,17 +5,19 @@ -- Features of https://microsoft.github.io/language-server-protocol/specification.html module HsInspect.LSP.Impl where +import Control.Monad (guard) import Control.Monad.Extra (fromMaybeM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Except (throwE) import Data.Cache (Cache) import qualified Data.Cache as C+import Data.List (nub) import Data.List.Extra (firstJust)-import Data.Maybe (listToMaybe)-import Data.Maybe (fromMaybe)+import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T+import Debug.Trace import qualified FastString as GHC import qualified GHC as GHC import GHC.Paths (libdir)@@ -62,7 +64,22 @@  -- zero indexed data Span = Span Int Int Int Int -- line, col, line, col+  deriving Show +getFullModuleName :: Text -> [Import] -> Maybe Text+getFullModuleName query imports =+  case results of+    [] -> Nothing+    result:_ -> Just result+  where results = mapMaybe extractModule imports+        extractModule imp = do+          qualName <- _qual imp+          guard $ T.isPrefixOf query qualName+          let fullImport = _full imp+          let (T.init -> module', _) =+                T.breakOnEnd "." fullImport+          return $ module'+ findType :: Text -> [Package] -> Maybe Text findType qual pkgs = listToMaybe $ do   let (T.init -> module', sym) = T.breakOnEnd "." qual@@ -81,13 +98,29 @@       Pat _ name typ -> matcher name typ       TyCon _ _ _ -> [] +findNameAndTypes :: Text -> [Package] -> [(Text, Text, Text)]+findNameAndTypes qual pkgs = do+  let (_, sym) = T.breakOnEnd "." qual+  let flatten Nothing = []+      flatten (Just as) = as+  pkg <- pkgs+  Module m entries <- flatten . _modules $ pkg+  e <- flatten entries+  let matcher name typ = if T.isPrefixOf sym name then [(name, typ, m)] else []+  case traceShowId e of+    Id _ name typ -> matcher name typ+    Con _ name typ -> matcher name typ+    Pat _ name typ -> matcher name typ+    TyCon _ _ _ -> []++ hoverProvider :: Caches -> FilePath -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text)) hoverProvider caches file position = do   ctx <- cachedContext caches file   symbols <- cachedImports caches ctx file   index <- cachedIndex' caches ctx   found <- symbolAtPoint file position-  pure $ case found of+  pure $ case traceShow found found of     Nothing -> Nothing     Just (range, sym) ->       let matcher imp = if _local imp == Just sym || _qual imp == Just sym || _full imp == sym@@ -97,11 +130,35 @@                         else Nothing        in (range,) <$> firstJust matcher symbols --- FIXME implement -- TODO use the index to add optional type information-completionProvider :: Caches -> FilePath -> (Int, Int) -> ExceptT String IO [Text]-completionProvider _ _ _ = pure []+completionProvider :: Caches -> FilePath -> Text -> (Int, Int) -> ExceptT String IO [Text]+completionProvider caches file contents position = do+  ctx <- cachedContext caches file+  symbols <- cachedImports caches ctx file+  index <- cachedIndex' caches ctx+  found <- symbolAtVirtualPoint file contents position+  pure $ case traceShow (found, symbols) found of+    Nothing -> []+    Just (_, sym) -> do+      let findNameAndType :: Text -> Import -> Text+          findNameAndType name imp =+            case findType (_full imp) index of+              Just typ -> name <> " :: " <> typ+              Nothing -> name +          matcher :: (Import -> Maybe Text) -> Import -> Maybe Text+          matcher key imp = do+            pref <- key imp+            if T.isPrefixOf sym pref+              then return $ findNameAndType pref imp+              else Nothing++      let localMatches = map (matcher _local) symbols+      let qualMatches = map (matcher _qual) symbols+      let fullMatches = map (matcher (Just . _full)) symbols++      nub $ catMaybes $ localMatches <> qualMatches <> fullMatches+ -- c.f. haskell-tng--hsinspect-symbol-at-point -- -- TODO consider replacing this (inefficient) ghc api usage with a regexp or@@ -119,6 +176,34 @@       -- when the point is on the very first character of the span and if we       -- must pick between the first or last char, we prefer the first.       point = GHC.realSrcLocSpan $ GHC.mkRealSrcLoc file' line (col + 1)+  -- TODO construct the real dflags from the Context (remove libdir dependency)+  dflags <- liftIO . GHC.runGhc (Just libdir) $ GHC.getSessionDynFlags+  -- lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]+  case GHC.lexTokenStream buf startLoc dflags of+    GHC.POk _ ts  ->+      let containsPoint :: (GHC.Located GHC.Token, String) -> Maybe (Span, Text)+          containsPoint ((GHC.L (GHC.UnhelpfulSpan _) _), _) = Nothing+          containsPoint ((GHC.L (GHC.RealSrcSpan s) _), txt) =+            if GHC.containsSpan s point then Just (toSpan s, T.pack txt) else Nothing+          toSpan src = Span+            (GHC.srcSpanStartLine src - 1)+            (GHC.srcSpanStartCol src - 1)+            (GHC.srcSpanEndLine src - 1)+            (GHC.srcSpanEndCol src - 1)++       in pure . firstJust containsPoint $ GHC.addSourceToTokens startLoc buf ts++    _ -> throwE "lexer error" -- TODO getErrorMessages++symbolAtVirtualPoint :: FilePath -> Text -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text))+symbolAtVirtualPoint file contents (line, col) = do+  let buf' = GHC.stringToStringBuffer $ T.unpack contents+  buf <- maybe (throwE "line doesn't exist") pure $ GHC.atLine 1 buf'+  let file' = GHC.mkFastString file+      startLoc = GHC.mkRealSrcLoc file' 1 1+      -- when you autocomplete you're at the end of word+      -- you do not want suggestions for the next column+      point = GHC.realSrcLocSpan $ GHC.mkRealSrcLoc file' line col   -- TODO construct the real dflags from the Context (remove libdir dependency)   dflags <- liftIO . GHC.runGhc (Just libdir) $ GHC.getSessionDynFlags   -- lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]