diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- based on the haskell-lsp example by Alan Zimmerman module Main (main) where @@ -16,7 +17,6 @@ import Data.Default import qualified Data.Text as T import Data.Typeable (typeOf) -import HsInspect.LSP.Context (BuildTool(..)) import HsInspect.LSP.Impl import qualified Language.Haskell.LSP.Control as CTRL import qualified Language.Haskell.LSP.Core as Core @@ -45,8 +45,7 @@ (putStrLn help) >> exitSuccess when (elem "--version" args) $ (putStrLn version) >> exitSuccess - let tool = if (elem "--stack" args) then Stack else Cabal - res <- run tool + res <- run case res of 0 -> exitSuccess c -> exitWith . ExitFailure $ c @@ -54,13 +53,13 @@ -- 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. -run :: BuildTool -> IO Int -run tool = flip E.catches [E.Handler ioExcept, E.Handler someExcept] $ do +run :: IO Int +run = flip E.catches [E.Handler ioExcept, E.Handler someExcept] $ do rin <- atomically newTChan let dp lf = do liftIO $ U.logs "main.run:dp entered" - _rpid <- forkIO $ reactor tool lf rin + _rpid <- forkIO $ reactor lf rin liftIO $ U.logs "main.run:dp tchan" return Nothing @@ -81,17 +80,19 @@ -- supported requests are duplicated here, in the reactor, and lspHandlers supported :: [J.ClientMethod] -supported = [J.TextDocumentHover] +supported = [J.TextDocumentHover, J.TextDocumentCompletion] -reactor :: BuildTool -> Core.LspFuncs () -> TChan FromClientMessage -> IO () -reactor tool lf inp = do +reactor :: Core.LspFuncs () -> TChan FromClientMessage -> IO () +reactor lf inp = do U.logs "reactor:entered" 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 forever $ do inval <- atomically $ readTChan inp case inval of - NotInitialized _notification -> do + NotInitialized _ -> do U.logs "reactor:init" let reg cmd = J.Registration "hsinspect-lsp" cmd Nothing regs = J.RegistrationParams (J.List $ reg <$> supported) @@ -99,20 +100,13 @@ rid <- Core.getNextReqId lf Core.sendFunc lf . ReqRegisterCapability $ fmServerRegisterCapabilityRequest rid regs - (ReqHover req@(J.RequestMessage _ _ _ params)) -> do - U.logs $ "reactor:hover:" ++ show params - let J.TextDocumentPositionParams (J.TextDocumentIdentifier doc) (J.Position line col) _ = params - Just file = J.uriToFilePath doc - res <- runExceptT $ hoverProvider caches tool file (line + 1, col + 1) + ReqHover req@(J.RequestMessage _ _ _ (J.TextDocumentPositionParams (toFile -> Just file) (toPos -> pos) _)) -> do + U.logs $ "reactor:hover:" ++ show (file, pos) + res <- runExceptT $ hoverProvider caches file pos case res of Left err -> do U.logs $ "reactor:hover:err:" ++ err - -- the only way to get a popup on the user's screen is to use a show - -- notification, the ErrorReq ends up being rendered exactly the - -- same as a success, so useless. Core.sendFunc lf . RspHover $ Core.makeResponseMessage req Nothing - Core.sendFunc lf . NotShowMessage $ - J.NotificationMessage "2.0" J.WindowShowMessage (J.ShowMessageParams J.MtWarning $ T.pack err) Right Nothing -> do Core.sendFunc lf . RspHover $ Core.makeResponseMessage req Nothing @@ -123,18 +117,35 @@ (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 + 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) + -- preemptively populate caches NotDidOpenTextDocument (J.NotificationMessage _ _ params) -> do U.logs "reactor:open" let (J.DidOpenTextDocumentParams (J.TextDocumentItem uri _ _ _)) = params Just file = J.uriToFilePath uri - -- TODO forkIO - void . runExceptT $ do - ctx <- cachedContext caches tool file + populated <- runExceptT $ do + ctx <- cachedContext caches file void $ cachedImports caches ctx file void $ cachedIndex caches ctx + case populated of + Right _ -> pure () + Left err -> + Core.sendFunc lf . NotShowMessage . + J.NotificationMessage "2.0" J.WindowShowMessage . + J.ShowMessageParams J.MtWarning $ T.pack err - -- TODO completionProvider -- TODO definitionProvider -- TODO signatureHelpProvider -- TODO import symbol at point (CodeActionQuickFix?) 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.2 +version: 0.0.3 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 @@ -9,13 +9,13 @@ module HsInspect.LSP.Context where import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except (withExceptT) -import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Except (ExceptT(..), throwE) import Data.List (isSuffixOf) -import Data.List.Extra (trim) import HsInspect.LSP.Util +import System.Directory (findExecutablesInDirectories) import System.FilePath +-- TODO replace String with Text data Context = Context { hsinspect :: FilePath , package_dir :: FilePath @@ -24,27 +24,22 @@ , srcdir :: FilePath } -data BuildTool = Cabal | Stack - -findContext :: FilePath -> BuildTool -> ExceptT String IO Context -findContext src tool = do +findContext :: FilePath -> ExceptT String IO Context +findContext src = do ghcflags' <- discoverGhcflags src ghcpath' <- discoverGhcpath src let readWords file = words <$> readFile' file readFile' = liftIO . readFile - Context <$> discoverHsInspect src tool <*> discoverPackageDir src <*> readWords ghcflags' <*> readFile' ghcpath' <*> pure (takeDirectory ghcflags') + ghcpath <- readFile' ghcpath' + Context <$> discoverHsInspect ghcpath <*> discoverPackageDir src <*> readWords ghcflags' <*> pure ghcpath <*> pure (takeDirectory ghcflags') -discoverHsInspect :: FilePath -> BuildTool -> ExceptT String IO FilePath -discoverHsInspect file tool = do - let dir = takeDirectory file - dir' <- discoverPackageDir dir - withExceptT (\err -> help_hsinspect ++ "\n\n" ++ err) $ case tool of - Cabal -> do - _ <- shell "cabal" ["build", "-v0", ":pkg:hsinspect:exe:hsinspect"] (Just dir') Nothing [] - trim <$> shell "cabal" ["exec", "-v0", "which", "--", "hsinspect"] (Just dir') Nothing [] - Stack -> do - _ <- shell "stack" ["build", "--silent", "hsinspect"] (Just dir') Nothing [] - trim <$> shell "stack" ["exec", "--silent", "which", "--", "hsinspect"] (Just dir') Nothing [] +discoverHsInspect :: String -> ExceptT String IO FilePath +discoverHsInspect path = do + let dirs = splitSearchPath path + found <- liftIO $ findExecutablesInDirectories dirs "hsinspect" + case found of + [] -> throwE help_hsinspect + exe : _ -> pure exe -- c.f. haskell-tng--compile-dominating-package discoverPackageDir :: FilePath -> ExceptT String IO FilePath 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 @@ -16,7 +16,6 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Debug.Trace (traceShowId) import qualified FastString as GHC import qualified GHC as GHC import GHC.Paths (libdir) @@ -39,11 +38,11 @@ -- TODO the index could use a data structure that is faster to search -cachedContext :: Caches -> BuildTool -> FilePath -> ExceptT String IO Context -cachedContext (Caches cache _ _) tool file = do +cachedContext :: Caches -> FilePath -> ExceptT String IO Context +cachedContext (Caches cache _ _) file = do key <- takeDirectory <$> discoverGhcflags file let work = do - ctx <- findContext file tool + ctx <- findContext file liftIO $ C.insert cache key ctx pure ctx fromMaybeM work . liftIO $ C.lookup cache key @@ -74,7 +73,7 @@ if module'' /= module' then [] else do - e <- traceShowId $ flatten entries + e <- flatten entries let matcher name typ = if name == sym && name /= typ then [typ] else [] case e of Id _ name typ -> matcher name typ @@ -82,9 +81,9 @@ Pat _ name typ -> matcher name typ TyCon _ _ _ -> [] -hoverProvider :: Caches -> BuildTool -> FilePath -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text)) -hoverProvider caches tool file position = do - ctx <- cachedContext caches tool file +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 @@ -97,6 +96,11 @@ Nothing -> _full imp 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 [] -- c.f. haskell-tng--hsinspect-symbol-at-point --