hsinspect-lsp 0.0.1 → 0.0.2

raw patch · 6 files changed

+200/−114 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• exe/Main.hs +50/−16
• hsinspect-lsp.cabal +1/−1
• library/HsInspect/LSP/Context.hs +48/−40
• library/HsInspect/LSP/HsInspect.hs +9/−16
• library/HsInspect/LSP/Impl.hs +76/−32
• library/HsInspect/LSP/Util.hs +16/−9

@@ -14,6 +14,7 @@ import Control.Monad.STM import qualified Data.Cache as C import Data.Default+import qualified Data.Text as T import Data.Typeable (typeOf) import HsInspect.LSP.Context (BuildTool(..)) import HsInspect.LSP.Impl@@ -78,35 +79,66 @@     ioExcept   (e :: E.IOException) = print e >> return 1     someExcept (e :: E.SomeException) = print e >> return 1 +-- supported requests are duplicated here, in the reactor, and lspHandlers+supported :: [J.ClientMethod]+supported = [J.TextDocumentHover]+ reactor :: BuildTool -> Core.LspFuncs () -> TChan FromClientMessage -> IO () reactor tool lf inp = do   U.logs "reactor:entered"-  caches <- Caches <$> C.newCache Nothing <*> C.newCache Nothing+  caches <- Caches <$> C.newCache Nothing <*> C.newCache Nothing <*> C.newCache Nothing   forever $ do     inval <- atomically $ readTChan inp     case inval of -      (ReqSignatureHelp req@(J.RequestMessage _ _ _ params)) -> do-        U.logs $ "reactor:SignatureHelp:" ++ show params+      NotInitialized _notification -> do+        U.logs "reactor:init"+        let reg cmd = J.Registration "hsinspect-lsp" cmd Nothing+            regs = J.RegistrationParams (J.List $ reg <$> supported)++        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 $ signatureHelpProvider caches tool file (line + 1, col + 1)+        res <- runExceptT $ hoverProvider caches tool file (line + 1, col + 1)         case res of           Left err -> do-            U.logs $ "reactor:signatureHelpProvider:err:" ++ err-            -- FIXME how to send an error to the client?-          Right sigs -> do-            let render s = J.SignatureInformation s Nothing Nothing-                halp = J.SignatureHelp (J.List $ render <$> sigs) Nothing Nothing-            Core.sendFunc lf . RspSignatureHelp $ Core.makeResponseMessage req halp+            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) -      -- TODO completionProvider-      -- TODO definitionProvider+          Right Nothing -> do+            Core.sendFunc lf . RspHover $ Core.makeResponseMessage req Nothing -      -- TODO DidOpenTextDocument is a good opportunity to preemptively populate caches+          Right (Just (Span line' col' line'' col'', txt)) -> do+            let halp = J.Hover+                         (J.HoverContents . J.unmarkedUpContent $ txt)+                         (Just $ J.Range (J.Position line' col') (J.Position line'' col''))+            Core.sendFunc lf . RspHover $ Core.makeResponseMessage req (Just halp) -      -- TODO hygienic registration of supported commands+      -- 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+          void $ cachedImports caches ctx file+          void $ cachedIndex caches ctx +      -- TODO completionProvider+      -- TODO definitionProvider+      -- TODO signatureHelpProvider+      -- TODO import symbol at point (CodeActionQuickFix?)+       om -> do         U.logs $ "reactor:HandlerRequest:" ++ (show $ typeOf om) @@ -114,10 +146,12 @@ lspHandlers rin =   let passHandler :: (a -> FromClientMessage) -> Core.Handler a       passHandler c notification = atomically $ writeTChan rin (c notification)-  in def { Core.signatureHelpHandler = Just $ passHandler ReqSignatureHelp+  in def { Core.hoverHandler = Just $ passHandler ReqHover          , Core.completionHandler = Just $ passHandler ReqCompletion          , Core.definitionHandler = Just $ passHandler ReqDefinition          , Core.initializedHandler = Just $ passHandler NotInitialized-         , Core.cancelNotificationHandler = Just $ passHandler NotCancelRequestFromClient          , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler NotDidOpenTextDocument+         -- 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.1+version:       0.0.2 synopsis:      LSP interface over the hsinspect binary. license:       GPL-3.0-or-later license-file:  LICENSE

@@ -9,7 +9,7 @@ module HsInspect.LSP.Context where  import Control.Monad.IO.Class (liftIO)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Except (withExceptT) import Control.Monad.Trans.Except (ExceptT(..)) import Data.List (isSuffixOf) import Data.List.Extra (trim)@@ -21,54 +21,62 @@   , package_dir :: FilePath   , ghcflags :: [String]   , ghcpath :: String+  , srcdir :: FilePath   } -findContext :: MonadIO m => DiscoverContext m -> FilePath -> m Context-findContext DiscoverContext{..} src = do+data BuildTool = Cabal | Stack++findContext :: FilePath -> BuildTool -> ExceptT String IO Context+findContext src tool = do   ghcflags' <- discoverGhcflags src   ghcpath' <- discoverGhcpath src   let readWords file = words <$> readFile' file       readFile' = liftIO . readFile-  Context <$> discoverHsInspect src <*> discoverPackageDir src <*> readWords ghcflags' <*> readFile' ghcpath'+  Context <$> discoverHsInspect src tool <*> discoverPackageDir src <*> readWords ghcflags' <*> readFile' ghcpath' <*> pure (takeDirectory ghcflags') -data DiscoverContext m = DiscoverContext-  { discoverHsInspect :: FilePath -> m FilePath-  , discoverPackageDir :: FilePath -> m FilePath-  , discoverGhcflags :: FilePath -> m FilePath-  , discoverGhcpath :: FilePath -> m FilePath-  }+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 [] -data BuildTool = Cabal | Stack+-- c.f. haskell-tng--compile-dominating-package+discoverPackageDir :: FilePath -> ExceptT String IO FilePath+discoverPackageDir file = do+  let dir = takeDirectory file+      isCabal = (".cabal" `isSuffixOf`)+      isHpack = ("package.yaml" ==)+  failWithM "There must be a .cabal or package.yaml" $+    locateDominatingDir (\f -> isCabal f || isHpack f) dir -mkDiscoverContext :: BuildTool -> DiscoverContext (ExceptT String IO)-mkDiscoverContext tool = DiscoverContext {..}-  where-    discoverHsInspect :: FilePath -> ExceptT String IO FilePath-    discoverHsInspect file = do-      let dir = takeDirectory file-      dir' <- discoverPackageDir dir-      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 []+discoverGhcflags :: FilePath -> ExceptT String IO FilePath+discoverGhcflags file = do+  let dir = takeDirectory file+  failWithM ("There must be a .ghc.flags file. " ++ help_ghcflags) $+   locateDominatingFile (".ghc.flags" ==) dir -    -- c.f. haskell-tng--compile-dominating-package-    discoverPackageDir :: FilePath -> ExceptT String IO FilePath-    discoverPackageDir file = do-      let dir = takeDirectory file-          isCabal = (".cabal" `isSuffixOf`)-          isHpack = ("package.yaml" ==)-      locateDominating (\f -> isCabal f || isHpack f) dir+discoverGhcpath :: FilePath -> ExceptT String IO FilePath+discoverGhcpath file = do+  let dir = takeDirectory file+  failWithM ("There must be a .ghc.path file. " ++ help_ghcflags) $+    locateDominatingFile (".ghc.path" ==) dir -    discoverGhcflags :: FilePath -> ExceptT String IO FilePath-    discoverGhcflags file = do-      let dir = takeDirectory file-      (</> ".ghc.flags") <$> locateDominating (".ghc.flags" ==) dir+-- note that any formatting in these messages are stripped+help_ghcflags :: String+help_ghcflags = "The cause of this error could be that this package has not been compiled yet, \+                \or the ghcflags compiler plugin has not been installed for this package. \+                \See https://gitlab.com/tseenshe/hsinspect#installation for more details." -    discoverGhcpath :: FilePath -> ExceptT String IO FilePath-    discoverGhcpath file = do-      let dir = takeDirectory file-      (</> ".ghc.path") <$> locateDominating (".ghc.path" ==) dir+help_hsinspect :: String+help_hsinspect = "The hsinspect binary has not been installed for this package. \+                 \See https://gitlab.com/tseenshe/hsinspect#installation for more details."++-- from Control.Error.Util+failWithM :: Applicative m => e -> m (Maybe a) -> ExceptT e m a+failWithM e ma = ExceptT $ (maybe (Left e) Right) <$> ma

@@ -23,24 +23,17 @@ import HsInspect.LSP.Util import qualified System.Log.Logger as L -data HsInspect m = HsInspect-  { imports :: Context -> FilePath -> m [Import]-  , index :: Context -> m [Package]-  }+hsinspect_imports :: Context -> FilePath -> ExceptT String IO [Import]+hsinspect_imports ctx hs = hsinspect_raw ctx ["imports", hs] -mkHsInspect :: HsInspect (ExceptT String IO)-mkHsInspect = HsInspect {..}-  where-    imports :: Context -> FilePath -> ExceptT String IO [Import]-    imports ctx hs = call ctx ["imports", hs]-    index :: Context -> ExceptT String IO [Package]-    index ctx = call ctx ["index"]+hsinspect_index :: Context -> ExceptT String IO [Package]+hsinspect_index ctx = hsinspect_raw ctx ["index"] -    call :: FromJSON a => Context -> [String] -> ExceptT String IO a-    call Context{hsinspect, package_dir, ghcflags, ghcpath} args = do-      liftIO $ L.debugM "haskell-lsp" $ "hsinspect-lsp:cwd:" <> package_dir-      stdout <- shell hsinspect (args <> ["--json", "--"] <> ghcflags) (Just package_dir) (Just ghcpath) [("GHC_ENVIRONMENT", "-")]-      ExceptT . pure . eitherDecodeStrict' $ C.pack stdout+hsinspect_raw :: FromJSON a => Context -> [String] -> ExceptT String IO a+hsinspect_raw Context{hsinspect, package_dir, ghcflags, ghcpath} args = do+  liftIO $ L.debugM "haskell-lsp" $ "hsinspect-lsp:cwd:" <> package_dir+  stdout <- shell hsinspect (args <> ["--json", "--"] <> ghcflags) (Just package_dir) (Just ghcpath) [("GHC_ENVIRONMENT", "-")]+  ExceptT . pure . eitherDecodeStrict' $ C.pack stdout  data Import = Import   { _local :: Maybe Text

@@ -1,3 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}  -- Features of https://microsoft.github.io/language-server-protocol/specification.html module HsInspect.LSP.Impl where@@ -8,10 +11,12 @@ import Control.Monad.Trans.Except (throwE) import Data.Cache (Cache) import qualified Data.Cache as C-import qualified Data.List as L-import Data.Maybe (mapMaybe)+import Data.List.Extra (firstJust)+import Data.Maybe (listToMaybe)+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)@@ -20,50 +25,84 @@ import qualified Lexer as GHC import qualified SrcLoc as GHC import qualified StringBuffer as GHC+import System.FilePath (takeDirectory) --- TODO consider more advanced cache keys, e.g. Import could be cached on a---      checksum of the file's header plus a checksum of the .ghc.* files.+-- TODO consider invalidation strategies, e.g. Import could use the file's+--      header, and the Context use the .ghc.* files. The index might also want+--      to hash the .ghc.flags contents plus any changes to exported symbols in+--      the current package. But beware that often it is better to have a stale+--      cache and respond with *something* than to be slow and redo the work. data Caches = Caches-  (Cache FilePath Context) -- ^ by the package_dir+  (Cache FilePath Context) -- ^ by source root   (Cache FilePath [Import]) -- ^ by source filename+  (Cache FilePath [Package]) -- ^ by source root +-- 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-  let discover = mkDiscoverContext tool-  key <- discoverPackageDir discover file+cachedContext (Caches cache _ _) tool file = do+  key <- takeDirectory <$> discoverGhcflags file   let work = do-        ctx <- findContext discover file+        ctx <- findContext file tool         liftIO $ C.insert cache key ctx         pure ctx   fromMaybeM work . liftIO $ C.lookup cache key  cachedImports :: Caches -> Context -> FilePath -> ExceptT String IO [Import]-cachedImports (Caches _ cache) ctx file =-  C.fetchWithCache cache file $ imports mkHsInspect ctx+cachedImports (Caches _ cache _) ctx file =+  C.fetchWithCache cache file $ hsinspect_imports ctx --- FIXME return all hits, not just the first one--- TODO docs / parameter info-signatureHelpProvider :: Caches -> BuildTool -> FilePath -> (Int, Int) -> ExceptT String IO [Text]-signatureHelpProvider caches tool file position = do-  ctx <- cachedContext caches tool file-  symbols <- cachedImports caches ctx file-  sym <- symbolAtPoint file position+cachedIndex :: Caches -> Context -> ExceptT String IO [Package]+cachedIndex (Caches _ _ cache) ctx =+  C.fetchWithCache cache (srcdir ctx) $ \_ -> hsinspect_index ctx -  -- TODO include type information by consulting the index+-- only lookup the index, don't try to populate it+cachedIndex' :: Caches -> Context -> ExceptT String IO [Package]+cachedIndex' (Caches _ _ cache) ctx = liftIO $+  fromMaybe [] <$> C.lookup cache (srcdir ctx) -  let-    matcher imp =-      if _local imp == Just sym || _qual imp == Just sym || _full imp == sym-      then Just $ _full imp-      else Nothing+-- zero indexed+data Span = Span Int Int Int Int -- line, col, line, col -  pure $ mapMaybe matcher symbols+findType :: Text -> [Package] -> Maybe Text+findType qual pkgs = listToMaybe $ do+  let (T.init -> module', sym) = T.breakOnEnd "." qual+  let flatten Nothing = []+      flatten (Just as) = as+  pkg <- pkgs+  Module module'' entries <- flatten . _modules $ pkg+  if module'' /= module'+  then []+  else do+    e <- traceShowId $ flatten entries+    let matcher name typ = if name == sym && name /= typ then [typ] else []+    case e of+      Id _ name typ -> matcher name typ+      Con _ name typ -> matcher name typ+      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+  symbols <- cachedImports caches ctx file+  index <- cachedIndex' caches ctx+  found <- symbolAtPoint file position+  pure $ case found of+    Nothing -> Nothing+    Just (range, sym) ->+      let matcher imp = if _local imp == Just sym || _qual imp == Just sym || _full imp == sym+                        then Just $ case findType (_full imp) index of+                          Just typ -> _full imp <> " :: " <> typ+                          Nothing -> _full imp+                        else Nothing+       in (range,) <$> firstJust matcher symbols+ -- c.f. haskell-tng--hsinspect-symbol-at-point -- -- TODO consider replacing this (inefficient) ghc api usage with a regexp or -- calling the specific lexer functions directly for the symbols we support.-symbolAtPoint :: FilePath -> (Int, Int) -> ExceptT String IO Text+symbolAtPoint :: FilePath -> (Int, Int) -> ExceptT String IO (Maybe (Span, Text)) symbolAtPoint file (line, col) = do   buf' <- liftIO $ GHC.hGetStringBuffer file   -- TODO for performance, and language extension reliability, find out how to@@ -81,11 +120,16 @@   -- lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]   case GHC.lexTokenStream buf startLoc dflags of     GHC.POk _ ts  ->-      let containsPoint :: GHC.SrcSpan -> Bool-          containsPoint (GHC.UnhelpfulSpan _) = False-          containsPoint (GHC.RealSrcSpan s) = GHC.containsSpan s point-       in maybe (throwE "could not find a token") (pure . T.pack . snd) .-            L.find (containsPoint . GHC.getLoc . fst) $-            GHC.addSourceToTokens startLoc buf 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

@@ -2,9 +2,9 @@ module HsInspect.LSP.Util where  import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT(..)) import Data.List (intercalate)+import qualified Data.List as L import System.Directory (listDirectory) import System.Environment (getEnvironment) import System.Exit (ExitCode(..))@@ -13,15 +13,22 @@ import qualified System.Process as P  -- the first parent directory where a file or directory name matches the predicate-locateDominating :: (String -> Bool) -> FilePath -> ExceptT String IO FilePath-locateDominating p dir = do-  files <- lift $ listDirectory dir+locateDominatingDir :: (String -> Bool) -> FilePath -> IO (Maybe FilePath)+locateDominatingDir p dir = do+  file' <- locateDominatingFile p dir+  pure $ takeDirectory <$> file'++-- same as locateDominating but returns the first file that matches the predicate+locateDominatingFile :: (String -> Bool) -> FilePath -> IO (Maybe FilePath)+locateDominatingFile p dir = do+  files <- listDirectory dir   let parent = takeDirectory dir-  if any p $ takeFileName <$> files-  then pure dir-  else if parent == dir-       then ExceptT . pure . Left $ "locateDominating"-       else locateDominating p parent+  case L.find p $ takeFileName <$> files of+    Just file -> pure . Just $ dir </> file+    Nothing ->+      if parent == dir+       then pure Nothing+       else locateDominatingFile p parent  shell :: String -> [String] -> Maybe FilePath -> Maybe String -> [(String, String)] -> ExceptT String IO String shell command args cwd path env_extra = ExceptT $ do