hsinspect-lsp 0.0.2 → 0.0.3

raw patch · 4 files changed

+62/−52 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 +35/−24
• hsinspect-lsp.cabal +1/−1
• library/HsInspect/LSP/Context.hs +14/−19
• library/HsInspect/LSP/Impl.hs +12/−8

@@ -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?)

@@ -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

@@ -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

@@ -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 --