haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-17 11:47:09 +03:00
Code Issues Projects Releases Wiki Activity

Break out HoverProvider into separate handler config

Browse Source
This commit is contained in:
Alan Zimmerman 2020-02-18 22:05:38 +00:00
parent 3088e6da0a
commit 94f8009228
8 changed files with 178 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
exe/Main.hs
View File

@ -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 RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# 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,14 +115,13 @@ 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"
@ -117,7 +129,7 @@ main = do
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:

2
ghcide

@ -1 +1 @@
Subproject commit 286635bac84c573ca2fbafc6a65d633302b152d1
Subproject commit 5bea92f9d3f835098b9aea4109165611e9186eef

4
haskell-language-server.cabal
View File

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

77
src/Ide/Plugin.hs
View File

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

9
src/Ide/Plugin/Example.hs
View File

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

8
src/Ide/Plugin/Example2.hs
View File

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

31
src/Ide/Plugin/Formatter.hs
View File

@ -7,7 +7,9 @@
module Ide.Plugin.Formatter
(
formatterPlugins
formatting
, rangeFormatting
, noneProvider
, responseError
, extractRange
, fullRange
@ -18,39 +20,20 @@ import qualified Data.Map as Map
import qualified Data.Text as T
import Development.IDE.Core.FileStore
import Development.IDE.Core.Rules
import Development.IDE.LSP.Server
import Development.IDE.Plugin
-- import Development.IDE.LSP.Server
-- import Development.IDE.Plugin
import Development.IDE.Types.Diagnostics as D
import Development.IDE.Types.Location
import Development.Shake hiding ( Diagnostic )
-- import Development.Shake hiding ( Diagnostic )
import Ide.Types
import Ide.Plugin.Config
import qualified Language.Haskell.LSP.Core as LSP
import Language.Haskell.LSP.Messages
-- import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import Text.Regex.TDFA.Text()
-- ---------------------------------------------------------------------
formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config
formatterPlugins providers = Plugin rules (handlers (Map.fromList (("none",noneProvider):providers)))
-- ---------------------------------------------------------------------
-- New style plugin
rules :: Rules ()
rules = mempty
handlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config
handlers providers = PartialHandlers $ \WithMessage{..} x -> return x
{ LSP.documentFormattingHandler
= withResponse RspDocumentFormatting (formatting providers)
, LSP.documentRangeFormattingHandler
= withResponse RspDocumentRangeFormatting (rangeFormatting providers)
}
-- ---------------------------------------------------------------------
formatting :: Map.Map T.Text (FormattingProvider IO)
-> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams
-> IO (Either ResponseError (List TextEdit))

6
src/Ide/Types.hs
View File

@ -10,6 +10,7 @@ module Ide.Types
, DiagnosticProviderFunc(..)
, FormattingType(..)
, FormattingProvider
, HoverProvider
) where
import Data.Aeson hiding (defaultOptions)
@ -23,8 +24,6 @@ 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 Ide.Plugin.Config
-- ---------------------------------------------------------------------
@ -90,7 +89,8 @@ data DiagnosticTrigger = DiagnosticOnOpen
| DiagnosticOnSave
deriving (Show,Ord,Eq)
type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover])
-- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover])
type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
type SymbolProvider = Uri -> IO (Either ResponseError [DocumentSymbol])