Break out HoverProvider into separate handler config

Author: alanz

exe/Main.hs

@@ -1,19 +1,26 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Main(main) where
 
 import Arguments
 import Control.Concurrent.Extra
+import Control.DeepSeq (NFData)
 import Control.Exception
 import Control.Monad.Extra
 import Control.Monad.IO.Class
+import Data.Binary (Binary)
 import Data.Default
+import Data.Dynamic (Typeable)
+import qualified Data.HashSet as HashSet
+import Data.Hashable (Hashable)
 import Data.List.Extra
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -34,16 +41,21 @@ import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
-import Development.Shake (Action, action)
+import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)
 import GHC hiding (def)
+import GHC.Generics (Generic)
+-- import qualified GHC.Paths
 import HIE.Bios
-import Ide.Plugin.Formatter
+import HIE.Bios.Cradle
+import HIE.Bios.Types
+import Ide.Plugin
 import Ide.Plugin.Config
+-- import Ide.Plugin.Formatter
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types (LspId(IdInt))
 import Linker
-import qualified Data.HashSet as HashSet
-import System.Directory.Extra as IO
+import qualified System.Directory.Extra as IO
+-- import System.Environment
 import System.Exit
 import System.FilePath
 import System.IO
@@ -70,6 +82,7 @@ idePlugins includeExample
     CodeAction.plugin <>
     formatterPlugins [("ormolu",   Ormolu.provider)
                      ,("floskell", Floskell.provider)] <>
+    hoverPlugins [Example.hover, Example2.hover] <>
     if includeExample then Example.plugin <> Example2.plugin
                       else mempty
 
@@ -89,9 +102,9 @@ main = do
     let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
             T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
 
-    whenJust argsCwd setCurrentDirectory
+    whenJust argsCwd IO.setCurrentDirectory
 
-    dir <- getCurrentDirectory
+    dir <- IO.getCurrentDirectory
 
     let plugins = idePlugins argsExamplePlugin
 
@@ -102,22 +115,21 @@ main = do
         runLanguageServer def (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-            -- very important we only call loadSession once, and it's fast, so just do it before starting
-            session <- loadSession dir
-            let options = (defaultIdeOptions $ return session)
+            let options = (defaultIdeOptions $ loadSession dir)
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs
+            initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)
+                getLspId event (logger minBound) debouncer options vfs
     else do
         putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "."
         putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues"
 
         putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
         files <- expandFiles (argFiles ++ ["." | null argFiles])
         -- LSP works with absolute file paths, so try and behave similarly
-        files <- nubOrd <$> mapM canonicalizePath files
+        files <- nubOrd <$> mapM IO.canonicalizePath files
         putStrLn $ "Found " ++ show (length files) ++ " files"
 
         putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
@@ -131,7 +143,8 @@ main = do
             cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
             when (isNothing x) $ print cradle
             putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
-            cradleToSession cradle
+            opts <- getComponentOptions cradle
+            createSession opts
 
         putStrLn "\nStep 5/6: Initializing the IDE"
         vfs <- makeVFSHandle
@@ -144,7 +157,7 @@ main = do
         let options =
               (defaultIdeOptions $ return $ return . grab)
                     { optShakeProfiling = argsShakeProfiling }
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
+        ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
@@ -166,7 +179,7 @@ expandFiles = concatMapM $ \x -> do
         let recurse "." = True
             recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
             recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
-        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
+        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
         when (null files) $
             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
         return files
@@ -185,15 +198,42 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
 showEvent lock e = withLock lock $ print e
 
 
-cradleToSession :: Cradle a -> IO HscEnvEq
-cradleToSession cradle = do
-    cradleRes <- getCompilerOptions "" cradle
-    opts <- case cradleRes of
+-- Rule type for caching GHC sessions.
+type instance RuleResult GetHscEnv = HscEnvEq
+
+data GetHscEnv = GetHscEnv
+    { hscenvOptions :: [String]        -- componentOptions from hie-bios
+    , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios
+    }
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetHscEnv
+instance NFData   GetHscEnv
+instance Binary   GetHscEnv
+
+
+loadGhcSessionIO :: Rules ()
+loadGhcSessionIO =
+    -- This rule is for caching the GHC session. E.g., even when the cabal file
+    -- changed, if the resulting flags did not change, we would continue to use
+    -- the existing session.
+    defineNoFile $ \(GetHscEnv opts deps) ->
+        liftIO $ createSession $ ComponentOptions opts deps
+
+
+getComponentOptions :: Cradle a -> IO ComponentOptions
+getComponentOptions cradle = do
+    let showLine s = putStrLn ("> " ++ s)
+    cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
+    case cradleRes of
         CradleSuccess r -> pure r
         CradleFail err -> throwIO err
         -- TODO Rather than failing here, we should ignore any files that use this cradle.
         -- That will require some more changes.
         CradleNone -> fail "'none' cradle is not yet supported"
+
+
+createSession :: ComponentOptions -> IO HscEnvEq
+createSession opts = do
     libdir <- getLibdir
     env <- runGhc (Just libdir) $ do
         _targets <- initSession opts
@@ -202,19 +242,34 @@ cradleToSession cradle = do
     newHscEnvEq env
 
 
-loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
-loadSession dir = do
+cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq
+cradleToSession mbYaml cradle = do
+    cmpOpts <- liftIO $ getComponentOptions cradle
+    let opts = componentOptions cmpOpts
+        deps = componentDependencies cmpOpts
+        deps' = case mbYaml of
+                  -- For direct cradles, the hie.yaml file itself must be watched.
+                  Just yaml | isDirectCradle cradle -> yaml : deps
+                  _ -> deps
+    existingDeps <- filterM doesFileExist deps'
+    need existingDeps
+    useNoFile_ $ GetHscEnv opts deps
+
+
+loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
+loadSession dir = liftIO $ do
     cradleLoc <- memoIO $ \v -> do
         res <- findCradle v
         -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
         -- try and normalise that
         -- e.g. see https://github.com/digital-asset/ghcide/issues/126
-        res' <- traverse makeAbsolute res
+        res' <- traverse IO.makeAbsolute res
         return $ normalise <$> res'
-    session <- memoIO $ \file -> do
-        c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
-        cradleToSession c
-    return $ \file -> liftIO $ session =<< cradleLoc file
+    let session :: Maybe FilePath -> Action HscEnvEq
+        session file = do
+          c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
+          cradleToSession file c
+    return $ \file -> session =<< liftIO (cradleLoc file)
 
 
 -- | Memoize an IO function, with the characteristics:

ghcide

@@ -62,6 +62,7 @@ library
     , haskell-lsp == 0.20.*
     , hie-bios >= 0.4
     , hslogger
+    , lens
     , optparse-simple
     , process
     , regex-tdfa >= 1.3.1.0
@@ -106,8 +107,10 @@ executable haskell-language-server
 
   build-depends:
       base >=4.7 && <5
+    , binary
     , containers
     , data-default
+    , deepseq
     , extra
     , filepath
      --------------------------------------------------------------
@@ -121,6 +124,7 @@ executable haskell-language-server
     , ghc-paths
     , ghcide
     , gitrev
+    , hashable
     , haskell-lsp
     , hie-bios >= 0.4
     , haskell-language-server

haskell-language-server.cabal

@@ -1,25 +1,38 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Ide.Plugin
     (
       asGhcIdePlugin
+    , formatterPlugins
+    , hoverPlugins
     ) where
 
-import           Data.Aeson                    hiding (defaultOptions)
+import           Control.Lens ( (^.) )
+import           Data.Either
+import           Data.Maybe
 import qualified Data.Map  as Map
-import qualified Data.Set                      as S
-import           Data.String
 import qualified Data.Text                     as T
-import           Data.Typeable
+import           Development.IDE.Core.FileStore
 import           Development.IDE.Core.Rules
+import           Development.IDE.LSP.Server
+import           Development.IDE.Plugin
 import           Development.IDE.Types.Diagnostics as D
 import           Development.IDE.Types.Location
-import           Language.Haskell.LSP.Types
-import           Text.Regex.TDFA.Text()
-import           Development.IDE.Plugin
+import           Development.Shake hiding ( Diagnostic )
 import           Ide.Plugin.Config
+import           Ide.Plugin.Formatter
 import           Ide.Types
+import qualified Language.Haskell.LSP.Core as LSP
+import           Language.Haskell.LSP.Messages
+import           Text.Regex.TDFA.Text()
+
+import qualified Language.Haskell.LSP.Core as LSP
+import           Language.Haskell.LSP.Messages
+import           Language.Haskell.LSP.Types
+import           Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)
 
 -- ---------------------------------------------------------------------
 
@@ -32,3 +45,53 @@ asGhcIdePlugin _ = Plugin mempty mempty
 -- First strp will be to bring the machinery from Ide.Plugin.Formatter over.
 
 -- ---------------------------------------------------------------------
+
+hoverPlugins :: [HoverProvider] -> Plugin Config
+hoverPlugins hs = Plugin hoverRules (hoverHandlers hs)
+
+hoverRules :: Rules ()
+hoverRules = mempty
+
+hoverHandlers :: [HoverProvider] -> PartialHandlers Config
+hoverHandlers hps = PartialHandlers $ \WithMessage{..} x ->
+  return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)}
+
+makeHover :: [HoverProvider]
+      -> LSP.LspFuncs Config -> IdeState
+      -> TextDocumentPositionParams
+      -> IO (Either ResponseError (Maybe Hover))
+makeHover hps lf ideState params
+  = do
+      mhs <- mapM (\p -> p ideState params) hps
+      -- TODO: We should support ServerCapabilities and declare that
+      -- we don't support hover requests during initialization if we
+      -- don't have any hover providers
+      -- TODO: maybe only have provider give MarkedString and
+      -- work out range here?
+      let hs = catMaybes (rights mhs)
+          r = listToMaybe $ mapMaybe (^. range) hs
+          h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of
+            HoverContentsMS (List []) -> Nothing
+            hh                        -> Just $ Hover hh r
+      return $ Right h
+
+-- ---------------------------------------------------------------------
+-- ---------------------------------------------------------------------
+
+formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config
+formatterPlugins providers
+    = Plugin formatterRules
+             (formatterHandlers (Map.fromList (("none",noneProvider):providers)))
+
+formatterRules :: Rules ()
+formatterRules = mempty
+
+formatterHandlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config
+formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x
+    { LSP.documentFormattingHandler
+        = withResponse RspDocumentFormatting (formatting providers)
+    , LSP.documentRangeFormattingHandler
+        = withResponse RspDocumentRangeFormatting (rangeFormatting providers)
+    }
+
+-- ---------------------------------------------------------------------

src/Ide/Plugin.hs

@@ -11,6 +11,7 @@
 module Ide.Plugin.Example
   (
     plugin
+  , hover
   ) where
 
 import Control.DeepSeq ( NFData )
@@ -52,12 +53,12 @@ hover = request "Hover" blah (Right Nothing) foundHover
 
 blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
 blah _ (Position line col)
-  = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"])
+  = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"])
 
 handlersExample :: PartialHandlers c
-handlersExample = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.hoverHandler = withResponse RspHover $ const hover}
-
+handlersExample = mempty
+-- handlersExample = PartialHandlers $ \WithMessage{..} x ->
+--   return x{LSP.hoverHandler = withResponse RspHover $ const hover}
 
 -- ---------------------------------------------------------------------
 

src/Ide/Plugin/Example.hs

@@ -11,6 +11,7 @@
 module Ide.Plugin.Example2
   (
     plugin
+  , hover
   ) where
 
 import Control.DeepSeq ( NFData )
@@ -52,11 +53,12 @@ hover = request "Hover" blah (Right Nothing) foundHover
 
 blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
 blah _ (Position line col)
-  = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"])
+  = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"])
 
 handlersExample2 :: PartialHandlers c
-handlersExample2 = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.hoverHandler = withResponse RspHover $ const hover}
+handlersExample2 = mempty
+-- handlersExample2 = PartialHandlers $ \WithMessage{..} x ->
+--   return x{LSP.hoverHandler = withResponse RspHover $ const hover}
 
 
 -- ---------------------------------------------------------------------