diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 () diff --git a/hsinspect-lsp.cabal b/hsinspect-lsp.cabal --- a/hsinspect-lsp.cabal +++ b/hsinspect-lsp.cabal @@ -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 diff --git a/library/HsInspect/LSP/Context.hs b/library/HsInspect/LSP/Context.hs --- a/library/HsInspect/LSP/Context.hs +++ b/library/HsInspect/LSP/Context.hs @@ -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) diff --git a/library/HsInspect/LSP/Impl.hs b/library/HsInspect/LSP/Impl.hs --- a/library/HsInspect/LSP/Impl.hs +++ b/library/HsInspect/LSP/Impl.hs @@ -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]