From 27543d12ea47438580a1097dd892a3a2ebe17a5d Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 10 Mar 2024 20:44:31 +0800 Subject: [PATCH 1/6] Init inlay hints plugin Fixity information is now available in the inlay hints plugin --- haskell-language-server.cabal | 46 ++++++ hls-plugin-api/src/Ide/Types.hs | 8 +- .../src/Ide/Plugin/InlayHints.hs | 150 ++++++++++++++++++ plugins/hls-inlay-hints-plugin/test/Main.hs | 4 + .../test/testdata/Hover.hs | 40 +++++ .../test/testdata/HoverImport.hs | 5 + .../test/testdata/hie.yaml | 3 + src/HlsPlugins.hs | 7 + 8 files changed, 262 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs create mode 100644 plugins/hls-inlay-hints-plugin/test/Main.hs create mode 100644 plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs create mode 100644 plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs create mode 100644 plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3f38abe391..a6fd226f2e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1188,6 +1188,51 @@ test-suite hls-gadt-plugin-tests , hls-test-utils == 2.7.0.0 , text + +----------------------------- +-- inlay hints plugin +----------------------------- + +flag inlayHints + description: Enable inlayHints plugin + default: True + manual: True + +common inlayHints + if flag(inlayHints) + build-depends: haskell-language-server:hls-inlay-hints-plugin + cpp-options: -DinlayHints + +library hls-inlay-hints-plugin + import: defaults, pedantic, warnings + exposed-modules: Ide.Plugin.InlayHints + hs-source-dirs: plugins/hls-inlay-hints-plugin/src + build-depends: + base >=4.12 && <5 + , containers + , deepseq + , extra + , ghcide == 2.7.0.0 + , hashable + , hls-plugin-api == 2.7.0.0 + , lsp >=2.4 + , transformers + , text + + default-extensions: DataKinds + +test-suite hls-inlay-hints-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-inlay-hints-plugin/test + main-is: Main.hs + build-depends: + , base + , filepath + , haskell-language-server:hls-inlay-hints-plugin + , hls-test-utils == 2.7.0.0 + , text + ----------------------------- -- explicit fixity plugin ----------------------------- @@ -1777,6 +1822,7 @@ library , overloadedRecordDot , semanticTokens , notes + , inlayHints exposed-modules: Ide.Arguments diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 9ed6fd19b9..8843d14449 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -541,7 +541,10 @@ instance PluginMethod Request Method_CallHierarchyOutgoingCalls where <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf instance PluginMethod Request Method_WorkspaceExecuteCommand where - handlesRequest _ _ _ _= HandlesRequest + handlesRequest _ _ _ _ = HandlesRequest + +instance PluginMethod Request Method_TextDocumentInlayHint where + handlesRequest _ _ _ _ = HandlesRequest instance PluginMethod Request (Method_CustomMethod m) where handlesRequest _ _ _ _ = HandlesRequest @@ -766,6 +769,9 @@ instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentInlayHint where + combineResponses _ _ _ _ (x :| _) = x + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs new file mode 100644 index 0000000000..20f8529ca0 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Ide.Plugin.InlayHints(descriptor) where + +import Control.DeepSeq (NFData (rnf), rwhnf) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (isRight) +import Data.Hashable (Hashable) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import Development.IDE (GhcSessionDeps (GhcSessionDeps), + HieAstResult (HAR, refMap), + IdeState, + Position (Position), + Pretty (pretty), + RuleResult, Rules, + TcModuleResult (tmrTypechecked), + TypeCheck (TypeCheck), + cmapWithPrio, define, + hscEnv, printOutputable, + use_) +import Development.IDE.Core.PluginUtils (runActionE, + useWithStaleE) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes (GetHieAst (GetHieAst)) +import Development.IDE.Core.Shake (addPersistentRule) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (Fixity (Fixity), Name, + TcGblEnv, defaultFixity, + initTcWithGbl, + lookupFixityRn, + mkRealSrcLoc, + realSrcLocSpan, + realSrcSpanEnd, + realSrcSpanStart, + srcLocCol, srcLocLine) +import Development.IDE.GHC.Compat.Core (HscEnv) +import qualified Development.IDE.GHC.Compat.Util as Util +import GHC.Generics (Generic) +import Ide.Logger (Recorder, WithPriority) +import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), + PluginId, + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Protocol.Message (Method (Method_TextDocumentInlayHint), + SMethod (SMethod_TextDocumentInlayHint)) +import Language.LSP.Protocol.Types (InlayHint (InlayHint), + InlayHintParams (InlayHintParams), + TextDocumentIdentifier (TextDocumentIdentifier), + maybeToNull, + type (|?) (InL)) + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info in Inlay Hints") + { + pluginRules = fixityRule recorder, + pluginHandlers = mkPluginHandler SMethod_TextDocumentInlayHint inlayHint + } + +inlayHint :: PluginMethodHandler IdeState Method_TextDocumentInlayHint +inlayHint state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _range) = do + nfp <- getNormalizedFilePathE uri + runActionE "InlayHints" state $ do + (FixityMap fixmap, _) <- useWithStaleE GetFixity nfp + pure $ maybeToNull $ toAbsInlayHints fixmap + where + toAbsInlayHints :: M.Map Position Fixity -> Maybe [InlayHint] + toAbsInlayHints fixmap = + Just (M.elems $ M.mapWithKey (\(Position x y) (Fixity _ pre direction) -> + InlayHint + (Position (x - 1) (y - 1)) + (InL (printOutputable direction <> printOutputable pre)) + Nothing Nothing Nothing Nothing Nothing Nothing + ) fixmap) + +newtype Log = LogShake Shake.Log + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +newtype FixityMap = FixityMap (M.Map Position Fixity) +instance Show FixityMap where + show _ = "FixityMap" + +instance NFData FixityMap where + rnf (FixityMap xs) = rnf xs + +instance NFData Fixity where + rnf = rwhnf + +data GetFixity = GetFixity deriving (Show, Eq, Generic) + +instance Hashable GetFixity +instance NFData GetFixity + +type instance RuleResult GetFixity = FixityMap + +fixityRule :: Recorder (WithPriority Log) -> Rules () +fixityRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do + HAR{refMap} <- use_ GetHieAst nfp + -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates + env <- hscEnv <$> use_ GhcSessionDeps nfp + tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp + fs <- lookupFixities env tcGblEnv $ + M.mapKeys (\(Right x) -> x) + $ M.filterWithKey (\k _ -> isRight k) + $ M.map + (fmap ( + (\loc -> Position (fromIntegral $ srcLocLine loc) (fromIntegral $ srcLocCol loc)) + . realSrcSpanEnd + . fst)) + refMap + pure ([], Just (FixityMap fs)) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetFixity $ const $ pure $ Just (FixityMap M.empty, idDelta, Nothing) + +-- | Convert a HieAST to FixityTree with fixity info gathered +lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> M.Map Name [Position] -> m (M.Map Position Fixity) +lookupFixities hscEnv tcGblEnv names + = liftIO + $ fmap (fromMaybe M.empty . snd) + $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 0 0) + $ M.traverseMaybeWithKey (\_ v -> v) + $ M.fromList + $ concat + $ M.elems + $ M.mapWithKey lookupFixity names + where + lookupFixity name positions = + fmap (,fixity) positions + where + fixity = do + f <- Util.handleGhcException + (const $ pure Nothing) + (Just <$> lookupFixityRn name) + if f == Just defaultFixity + then pure Nothing + else pure f diff --git a/plugins/hls-inlay-hints-plugin/test/Main.hs b/plugins/hls-inlay-hints-plugin/test/Main.hs new file mode 100644 index 0000000000..e32ad03bf4 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = print "ok" diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs b/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs new file mode 100644 index 0000000000..f5fd50a501 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +module Hover where +import Control.Monad +import Data.Function (on) +import Control.Applicative ((<|>)) +f1 = (++) +f2 = ($) +f3 = (.) +f4 = (+) +f5 = 1 - 2 +f6 = (<>) +f7 = (>>=) +f8 = (>=>) +f9 = elem +f10 = on +f11 = (||) +f12 = mod +f13 = (**) +f14 = (^) +f15 = (<$) +f16 = seq +f17 = (<|>) + +infixr 7 >>: +infix 9 >>:: +data F = G + { (>>:) :: Int -> Int -> Int + , c :: Int + , (>>::) :: Char + } +f G{..} = undefined + +infixl 1 `f` + +infixr 9 >>>: +(>>>:) :: Int -> Int +(>>>:) x = 3 + +infixl 3 ~\: +(~\:) x y = 3 diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs b/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs new file mode 100644 index 0000000000..e3474eb0c3 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs @@ -0,0 +1,5 @@ +module HoverImport where + +import Hover + +g = (>>>:) diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml b/plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..824558147d --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 1f5d091dc5..8dafd4e320 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -85,6 +85,10 @@ import qualified Ide.Plugin.GADT as GADT import qualified Ide.Plugin.ExplicitFixity as ExplicitFixity #endif +#if inlayHints +import qualified Ide.Plugin.InlayHints as InlayHints +#endif + #if explicitFields import qualified Ide.Plugin.ExplicitFields as ExplicitFields #endif @@ -238,6 +242,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if explicitFixity let pId = "explicit-fixity" in ExplicitFixity.descriptor (pluginRecorder pId) pId : #endif +#if inlayHints + let pId = "inlay-hints" in InlayHints.descriptor (pluginRecorder pId) pId : +#endif #if explicitFields let pId = "explicit-fields" in ExplicitFields.descriptor (pluginRecorder pId) pId : #endif From e9adf9022122926897d45e08718a8507b4b6688b Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 11 Mar 2024 16:06:03 +0800 Subject: [PATCH 2/6] Fmt & cleanup --- .../src/Ide/Plugin/InlayHints.hs | 3 --- plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs | 10 +++++----- .../test/testdata/HoverImport.hs | 2 +- 3 files changed, 6 insertions(+), 9 deletions(-) diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs index 20f8529ca0..2ef7550f50 100644 --- a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs @@ -13,8 +13,6 @@ import Data.Either (isRight) import Data.Hashable (Hashable) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) -import Data.String (IsString (fromString)) -import Data.Text (Text) import Development.IDE (GhcSessionDeps (GhcSessionDeps), HieAstResult (HAR, refMap), IdeState, @@ -39,7 +37,6 @@ import Development.IDE.GHC.Compat (Fixity (Fixity), Name, mkRealSrcLoc, realSrcLocSpan, realSrcSpanEnd, - realSrcSpanStart, srcLocCol, srcLocLine) import Development.IDE.GHC.Compat.Core (HscEnv) import qualified Development.IDE.GHC.Compat.Util as Util diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs b/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs index f5fd50a501..d7fa47220c 100644 --- a/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs +++ b/plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs @@ -1,8 +1,8 @@ {-# LANGUAGE RecordWildCards #-} module Hover where -import Control.Monad -import Data.Function (on) -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) +import Control.Monad +import Data.Function (on) f1 = (++) f2 = ($) f3 = (.) @@ -24,8 +24,8 @@ f17 = (<|>) infixr 7 >>: infix 9 >>:: data F = G - { (>>:) :: Int -> Int -> Int - , c :: Int + { (>>:) :: Int -> Int -> Int + , c :: Int , (>>::) :: Char } f G{..} = undefined diff --git a/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs b/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs index e3474eb0c3..95a7de10cd 100644 --- a/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs +++ b/plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs @@ -1,5 +1,5 @@ module HoverImport where -import Hover +import Hover g = (>>>:) From 437f437a073fcd44532f2fde2ff60da90b9806e9 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Fri, 5 Apr 2024 14:36:37 +0800 Subject: [PATCH 3/6] hls-inlay-hints-plugin: Add local binding inlay hints --- haskell-language-server.cabal | 9 +- .../src/Ide/Plugin/InlayHints.hs | 173 ++++------------ .../src/Ide/Plugin/InlayHints/Fixity.hs | 130 +++++++++++++ .../src/Ide/Plugin/InlayHints/LocalBinding.hs | 184 ++++++++++++++++++ .../src/Ide/Plugin/InlayHints/Types.hs | 13 ++ 5 files changed, 368 insertions(+), 141 deletions(-) create mode 100644 plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs create mode 100644 plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs create mode 100644 plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a6fd226f2e..27e98f3121 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1205,8 +1205,14 @@ common inlayHints library hls-inlay-hints-plugin import: defaults, pedantic, warnings - exposed-modules: Ide.Plugin.InlayHints hs-source-dirs: plugins/hls-inlay-hints-plugin/src + exposed-modules: + Ide.Plugin.InlayHints + Ide.Plugin.InlayHints.Types + + Ide.Plugin.InlayHints.Fixity + Ide.Plugin.InlayHints.LocalBinding + other-modules: build-depends: base >=4.12 && <5 , containers @@ -1216,6 +1222,7 @@ library hls-inlay-hints-plugin , hashable , hls-plugin-api == 2.7.0.0 , lsp >=2.4 + , mtl , transformers , text diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs index 2ef7550f50..fc95b7f5f8 100644 --- a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs @@ -1,147 +1,40 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module Ide.Plugin.InlayHints(descriptor) where -import Control.DeepSeq (NFData (rnf), rwhnf) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (isRight) -import Data.Hashable (Hashable) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Development.IDE (GhcSessionDeps (GhcSessionDeps), - HieAstResult (HAR, refMap), - IdeState, - Position (Position), - Pretty (pretty), - RuleResult, Rules, - TcModuleResult (tmrTypechecked), - TypeCheck (TypeCheck), - cmapWithPrio, define, - hscEnv, printOutputable, - use_) -import Development.IDE.Core.PluginUtils (runActionE, - useWithStaleE) -import Development.IDE.Core.PositionMapping (idDelta) -import Development.IDE.Core.RuleTypes (GetHieAst (GetHieAst)) -import Development.IDE.Core.Shake (addPersistentRule) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (Fixity (Fixity), Name, - TcGblEnv, defaultFixity, - initTcWithGbl, - lookupFixityRn, - mkRealSrcLoc, - realSrcLocSpan, - realSrcSpanEnd, - srcLocCol, srcLocLine) -import Development.IDE.GHC.Compat.Core (HscEnv) -import qualified Development.IDE.GHC.Compat.Util as Util -import GHC.Generics (Generic) -import Ide.Logger (Recorder, WithPriority) -import Ide.Plugin.Error (getNormalizedFilePathE) -import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), - PluginId, - PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Protocol.Message (Method (Method_TextDocumentInlayHint), - SMethod (SMethod_TextDocumentInlayHint)) -import Language.LSP.Protocol.Types (InlayHint (InlayHint), - InlayHintParams (InlayHintParams), - TextDocumentIdentifier (TextDocumentIdentifier), - maybeToNull, - type (|?) (InL)) - -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +import Development.IDE (IdeState) +import Development.IDE.Core.PluginUtils (runActionE) +import Ide.Logger (Recorder, WithPriority) +import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Plugin.InlayHints.Fixity (fixityInlayHints, + fixityRule) +import Ide.Plugin.InlayHints.LocalBinding (localBindingInlayHints, + localBindingRule) +import Ide.Plugin.InlayHints.Types (InlayHintLog) +import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Protocol.Message (SMethod (SMethod_TextDocumentInlayHint)) +import Language.LSP.Protocol.Types (InlayHintParams (InlayHintParams), + Null (Null), + TextDocumentIdentifier (TextDocumentIdentifier), + type (|?) (InR)) + +descriptor :: Recorder (WithPriority InlayHintLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info in Inlay Hints") - { - pluginRules = fixityRule recorder, - pluginHandlers = mkPluginHandler SMethod_TextDocumentInlayHint inlayHint + { pluginRules = do + fixityRule recorder + localBindingRule recorder + , pluginHandlers = + mkPluginHandler SMethod_TextDocumentInlayHint + $ \state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _) -> do + nfp <- getNormalizedFilePathE uri + runActionE "InlayHints" state $ do + fmap (foldr (<>) (InR Null)) $ traverse ($ nfp) + [ + fixityInlayHints + , localBindingInlayHints + ] } - -inlayHint :: PluginMethodHandler IdeState Method_TextDocumentInlayHint -inlayHint state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _range) = do - nfp <- getNormalizedFilePathE uri - runActionE "InlayHints" state $ do - (FixityMap fixmap, _) <- useWithStaleE GetFixity nfp - pure $ maybeToNull $ toAbsInlayHints fixmap - where - toAbsInlayHints :: M.Map Position Fixity -> Maybe [InlayHint] - toAbsInlayHints fixmap = - Just (M.elems $ M.mapWithKey (\(Position x y) (Fixity _ pre direction) -> - InlayHint - (Position (x - 1) (y - 1)) - (InL (printOutputable direction <> printOutputable pre)) - Nothing Nothing Nothing Nothing Nothing Nothing - ) fixmap) - -newtype Log = LogShake Shake.Log - -instance Pretty Log where - pretty = \case - LogShake log -> pretty log - -newtype FixityMap = FixityMap (M.Map Position Fixity) -instance Show FixityMap where - show _ = "FixityMap" - -instance NFData FixityMap where - rnf (FixityMap xs) = rnf xs - -instance NFData Fixity where - rnf = rwhnf - -data GetFixity = GetFixity deriving (Show, Eq, Generic) - -instance Hashable GetFixity -instance NFData GetFixity - -type instance RuleResult GetFixity = FixityMap - -fixityRule :: Recorder (WithPriority Log) -> Rules () -fixityRule recorder = do - define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do - HAR{refMap} <- use_ GetHieAst nfp - -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates - env <- hscEnv <$> use_ GhcSessionDeps nfp - tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp - fs <- lookupFixities env tcGblEnv $ - M.mapKeys (\(Right x) -> x) - $ M.filterWithKey (\k _ -> isRight k) - $ M.map - (fmap ( - (\loc -> Position (fromIntegral $ srcLocLine loc) (fromIntegral $ srcLocCol loc)) - . realSrcSpanEnd - . fst)) - refMap - pure ([], Just (FixityMap fs)) - - -- Ensure that this plugin doesn't block on startup - addPersistentRule GetFixity $ const $ pure $ Just (FixityMap M.empty, idDelta, Nothing) - --- | Convert a HieAST to FixityTree with fixity info gathered -lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> M.Map Name [Position] -> m (M.Map Position Fixity) -lookupFixities hscEnv tcGblEnv names - = liftIO - $ fmap (fromMaybe M.empty . snd) - $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 0 0) - $ M.traverseMaybeWithKey (\_ v -> v) - $ M.fromList - $ concat - $ M.elems - $ M.mapWithKey lookupFixity names - where - lookupFixity name positions = - fmap (,fixity) positions - where - fixity = do - f <- Util.handleGhcException - (const $ pure Nothing) - (Just <$> lookupFixityRn name) - if f == Just defaultFixity - then pure Nothing - else pure f diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs new file mode 100644 index 0000000000..e6f3c98844 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Fixity.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Ide.Plugin.InlayHints.Fixity(fixityRule, fixityInlayHints) where + +import Control.DeepSeq (NFData (rnf), rwhnf) +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (isRight) +import Data.Hashable (Hashable) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Development.IDE (Action, + GhcSessionDeps (GhcSessionDeps), + HieAstResult (HAR, refMap), + NormalizedFilePath, + Position (Position), + RuleResult, Rules, + TcModuleResult (tmrTypechecked), + TypeCheck (TypeCheck), + cmapWithPrio, define, + hscEnv, use_) +import Development.IDE.Core.PluginUtils (useWithStaleE) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes (GetHieAst (GetHieAst)) +import Development.IDE.Core.Shake (addPersistentRule) +import Development.IDE.GHC.Compat (Fixity (Fixity), Name, + TcGblEnv, defaultFixity, + initTcWithGbl, + lookupFixityRn, + mkRealSrcLoc, + realSrcLocSpan, + realSrcSpanEnd, + srcLocCol, srcLocLine) +import Development.IDE.GHC.Compat.Core (HscEnv) +import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.Util (printOutputable) +import GHC.Generics (Generic) +import Ide.Logger (Recorder, WithPriority) +import Ide.Plugin.Error (PluginError) +import Ide.Plugin.InlayHints.Types (InlayHintLog (LogShake)) +import Language.LSP.Protocol.Types (InlayHint (InlayHint), + Null, maybeToNull, + type (|?) (InL)) + +------- + +fixityInlayHints :: NormalizedFilePath -> ExceptT PluginError Action ([InlayHint] |? Null) +fixityInlayHints nfp = do + (FixityMap fixmap, _) <- useWithStaleE GetFixity nfp + pure $ maybeToNull $ toAbsInlayHints fixmap + where + toAbsInlayHints :: M.Map Position Fixity -> Maybe [InlayHint] + toAbsInlayHints fixmap = + Just (M.elems $ M.mapWithKey (\(Position x y) (Fixity _ pre direction) -> + InlayHint + (Position (x - 1) (y - 1)) + -- infixr => r + (InL ((T.takeEnd 1 $ printOutputable direction) + <> printOutputable pre)) + Nothing Nothing Nothing Nothing Nothing Nothing + ) fixmap) + +------- + +newtype FixityMap = FixityMap (M.Map Position Fixity) +instance Show FixityMap where + show _ = "FixityMap" + +instance NFData FixityMap where + rnf (FixityMap xs) = rnf xs + +instance NFData Fixity where + rnf = rwhnf + +data GetFixity = GetFixity deriving (Show, Eq, Generic) + +instance Hashable GetFixity +instance NFData GetFixity + +type instance RuleResult GetFixity = FixityMap + +fixityRule :: Recorder (WithPriority InlayHintLog) -> Rules () +fixityRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do + HAR{refMap} <- use_ GetHieAst nfp + -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates + env <- hscEnv <$> use_ GhcSessionDeps nfp + tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp + fs <- lookupFixities env tcGblEnv $ + M.mapKeys (\(Right x) -> x) + $ M.filterWithKey (\k _ -> isRight k) + $ M.map + (fmap $ (\loc -> + Position (fromIntegral $ srcLocLine loc) + (fromIntegral $ srcLocCol loc)) + . realSrcSpanEnd + . fst) + refMap + pure ([], Just (FixityMap fs)) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetFixity $ const $ pure $ Just (FixityMap M.empty, idDelta, Nothing) + +-- | Convert a HieAST to FixityTree with fixity info gathered +lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> M.Map Name [Position] -> m (M.Map Position Fixity) +lookupFixities hscEnv tcGblEnv names + = liftIO + $ fmap (fromMaybe M.empty . snd) + $ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) + $ M.traverseMaybeWithKey (\_ v -> v) + $ M.fromList + $ concat + $ M.elems + $ M.mapWithKey lookupFixity names + where + lookupFixity name positions = + fmap (,fixity) positions + where + fixity = do + f <- Util.handleGhcException + (const $ pure Nothing) + (Just <$> lookupFixityRn name) + if f == Just defaultFixity + then pure Nothing + else pure f diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs new file mode 100644 index 0000000000..47cba074b0 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/LocalBinding.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ide.Plugin.InlayHints.LocalBinding (localBindingRule, localBindingInlayHints) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData (rnf)) +import Control.Monad.Except (ExceptT) +import qualified Control.Monad.Extra as M +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Hashable (Hashable) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T +import Development.IDE (Action, + DocAndTyThingMap (DKMap), + GetDocMap (GetDocMap), + GetHieAst (GetHieAst), + HieKind (HieFresh, HieFromDisk), + Position, Range (_end), + Recorder, RuleResult, + Rules, WithPriority, + cmapWithPrio, define, + printOutputable, + realSrcSpanToRange) +import Development.IDE.Core.PluginUtils (useE, useWithStaleMT) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes (HieAstResult (..)) +import Development.IDE.Core.Shake (addPersistentRule) +import Development.IDE.GHC.Compat (BindType (RegularBind), + ContextInfo (TyDecl, ValBind), + HieAST (..), + HieASTs (..), + HieFile (hie_types), + Identifier, + IdentifierDetails (..), + NodeInfo (..), + Scope (LocalScope), + hieTypeToIface, + lookupNameEnv, nodeInfo, + nodeInfo', + recoverFullType) +import Development.IDE.Spans.Common (TyThingMap, + safeTyThingType) +import Development.IDE.Types.Location (NormalizedFilePath) +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError) +import Ide.Plugin.InlayHints.Types (InlayHintLog (LogShake)) +import Language.LSP.Protocol.Types (InlayHint (InlayHint), + Null, type (|?) (InL)) + +------- + +localBindingInlayHints :: NormalizedFilePath -> ExceptT PluginError Action ([InlayHint] |? Null) +localBindingInlayHints nfp = do + (LocalBindingMap hmap) <- useE GetLocalBinding nfp + pure $ InL $ toAbsInlayHints hmap + where + toAbsInlayHints :: M.Map Position T.Text -> [InlayHint] + toAbsInlayHints hmap = + M.elems $ M.mapWithKey (\pos content -> + InlayHint pos (InL $ " :: " <> content) + Nothing Nothing Nothing Nothing Nothing Nothing) hmap + +------- + +localBindingRule :: Recorder (WithPriority InlayHintLog) -> Rules () +localBindingRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetLocalBinding nfp -> do + bindings <- lookupLocalBindings nfp + pure ([], Just bindings) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetLocalBinding $ const $ pure $ Just (LocalBindingMap M.empty, idDelta, Nothing) + +newtype LocalBindingMap = LocalBindingMap (M.Map Position T.Text) +instance Show LocalBindingMap where + show _ = "LocalBindingMap" + +instance NFData LocalBindingMap where + rnf (LocalBindingMap map) = rnf map + +data GetLocalBinding = GetLocalBinding deriving (Show, Eq, Generic) + +instance Hashable GetLocalBinding +instance NFData GetLocalBinding + +type instance RuleResult GetLocalBinding = LocalBindingMap + +lookupLocalBindings + :: NormalizedFilePath + -> Action LocalBindingMap +lookupLocalBindings nfp + = flip fmap (getAtPoints nfp) $ \case + Just hm -> hm + Nothing -> LocalBindingMap M.empty + +getAtPoints + :: NormalizedFilePath + -> Action (Maybe LocalBindingMap) +getAtPoints nfp = runMaybeT $ do + (har, _) <- useWithStaleMT GetHieAst nfp + (DKMap _ km) <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleMT GetDocMap nfp) + + MaybeT + $ liftIO + $ Just . LocalBindingMap + <$> atPoints har km + + +atPoints + :: HieAstResult + -> TyThingMap + -> IO (M.Map Position T.Text) +atPoints (HAR _ hf _ _ (kind :: HieKind hietype)) km = + fmap M.fromList $ M.concatMapM inlayHintInfo $ M.elems (getAsts hf) + where + inlayHintInfo :: HieAST hietype -> IO [(Position, T.Text)] + inlayHintInfo = return . inlayHintInfo' + where + inlayHintInfo' :: HieAST hietype -> [(Position, T.Text)] + inlayHintInfo' ast = + M.toList $ M.mapMaybe id $ M.map prettyName (filteredIdentifiers (flattenAST ast)) + + flattenAST :: HieAST hietype -> [HieAST hietype] + flattenAST ast = case nodeChildren ast of + [] -> [ast] + asts -> concatMap flattenAST asts + + pos :: HieAST hietype -> Position + pos ast = _end (realSrcSpanToRange $ nodeSpan ast) + + info :: HieAST hietype -> NodeInfo hietype + info ast = nodeInfoH kind ast + + -- TODO: This is damn messy, but I don't know how to do it better + filteredIdentifiers :: [HieAST hietype] -> M.Map Position (Identifier, IdentifierDetails hietype) + filteredIdentifiers asts = M.fromList $ fmap (\(idr, (pos, idrd)) -> (pos, (idr, idrd))) $ M.toList $ + (M.fromList $ fmap (\((idr, idrd), pos) -> (idr, (pos, idrd))) localBindList) + `M.difference` + (M.fromList $ fmap (\((idr, idrd), pos) -> (idr, (pos, idrd))) hasSigDeclList) + where + allNodeIdentifiers' = fmap (\ast -> + (case M.toList $ nodeIdentifiers $ info ast of + [(k, v)] -> Just (k, v) + _ -> Nothing + , pos ast) + ) asts + localBindList = + mapMaybe + (\(a, b) -> fmap (,b) a) + [ (node, pos) | (node, pos) <- allNodeIdentifiers', any (any bindLocal . identInfo . snd) node ] + hasSigDeclList = + mapMaybe + (\(a, b) -> fmap (,b) a) + [ (node, pos) | (node, pos) <- allNodeIdentifiers', any (any hasSigDecl . identInfo . snd) node ] + + bindLocal, hasSigDecl :: ContextInfo -> Bool + bindLocal (ValBind RegularBind (LocalScope _) _) = True + bindLocal _ = False + hasSigDecl TyDecl = True + hasSigDecl _ = False + + prettyName :: (Identifier, IdentifierDetails hietype) -> Maybe T.Text + prettyName (Right n, dets) = + Just $ fromMaybe "?" ((prettyType <$> identType dets) <|> maybeKind) + where + maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + prettyName (Left _, _) = Nothing + + prettyType :: hietype -> T.Text + prettyType t = case kind of + HieFresh -> printOutputable t + HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + +-- In ghc9, nodeInfo is monomorphic, so we need a case split here +nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a +nodeInfoH (HieFromDisk _) = nodeInfo' +nodeInfoH HieFresh = nodeInfo diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs new file mode 100644 index 0000000000..27a58fa98e --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LambdaCase #-} + +module Ide.Plugin.InlayHints.Types(InlayHintLog(LogShake)) where + +import Development.IDE (Pretty (pretty)) +import qualified Development.IDE.Core.Shake as Shake + +newtype InlayHintLog = LogShake Shake.Log + +instance Pretty InlayHintLog where + pretty = \case + LogShake log -> pretty log + From 0cf171d19af7cdc64718121023df5501b98fee09 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 20 Apr 2024 06:19:40 +0800 Subject: [PATCH 4/6] hls-inlay-hints-plugin: Add inlay hints for holes --- haskell-language-server.cabal | 1 + .../src/Ide/Plugin/InlayHints.hs | 11 +- .../src/Ide/Plugin/InlayHints/Hole.hs | 153 ++++++++++++++++++ plugins/hls-inlay-hints-plugin/test/Main.hs | 12 +- 4 files changed, 172 insertions(+), 5 deletions(-) create mode 100644 plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 27e98f3121..8078f42651 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1211,6 +1211,7 @@ library hls-inlay-hints-plugin Ide.Plugin.InlayHints.Types Ide.Plugin.InlayHints.Fixity + Ide.Plugin.InlayHints.Hole Ide.Plugin.InlayHints.LocalBinding other-modules: build-depends: diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs index fc95b7f5f8..8551000318 100644 --- a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs @@ -3,12 +3,14 @@ module Ide.Plugin.InlayHints(descriptor) where +import Data.Foldable (sequenceA_, traverse_) import Development.IDE (IdeState) import Development.IDE.Core.PluginUtils (runActionE) import Ide.Logger (Recorder, WithPriority) import Ide.Plugin.Error (getNormalizedFilePathE) import Ide.Plugin.InlayHints.Fixity (fixityInlayHints, fixityRule) +import Ide.Plugin.InlayHints.Hole (holeInlayHints, holeRule) import Ide.Plugin.InlayHints.LocalBinding (localBindingInlayHints, localBindingRule) import Ide.Plugin.InlayHints.Types (InlayHintLog) @@ -24,9 +26,11 @@ import Language.LSP.Protocol.Types (InlayHintParams (InlayHintP descriptor :: Recorder (WithPriority InlayHintLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info in Inlay Hints") - { pluginRules = do - fixityRule recorder - localBindingRule recorder + { pluginRules = traverse_ ($ recorder) [ + fixityRule + , holeRule + , localBindingRule + ] , pluginHandlers = mkPluginHandler SMethod_TextDocumentInlayHint $ \state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _) -> do @@ -35,6 +39,7 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info fmap (foldr (<>) (InR Null)) $ traverse ($ nfp) [ fixityInlayHints + , holeInlayHints , localBindingInlayHints ] } diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs new file mode 100644 index 0000000000..0018e03ec7 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Avoid restricted function" #-} + +module Ide.Plugin.InlayHints.Hole (holeInlayHints, holeRule) where + +import Control.DeepSeq (NFData (rnf)) +import Control.Monad.Except (ExceptT) +import qualified Control.Monad.Extra as M +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Data.Hashable (Hashable) +import qualified Data.Map as M +import Data.Maybe (maybeToList) +import qualified Data.Text as T +import qualified Debug.Trace as Debug +import Development.IDE (Action, + GetHieAst (GetHieAst), + HieKind (HieFresh, HieFromDisk), + Position, Range (_end), + Recorder, RuleResult, + Rules, WithPriority, + cmapWithPrio, define, + printOutputable, + realSrcSpanToRange) +import Development.IDE.Core.PluginUtils (useE, useWithStaleMT) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes (HieAstResult (..)) +import Development.IDE.Core.Shake (addPersistentRule) +import Development.IDE.GHC.Compat (HieAST (..), + HieASTs (..), + HieFile (hie_types), + NodeInfo (..), + hieTypeToIface, + nodeAnnotations, + nodeInfo, nodeInfo', + recoverFullType) +import Development.IDE.Types.Location (NormalizedFilePath) +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError) +import Ide.Plugin.InlayHints.Types (InlayHintLog (LogShake)) +import Language.LSP.Protocol.Types (InlayHint (InlayHint), + Null, type (|?) (InL)) + +------- + +holeInlayHints :: NormalizedFilePath -> ExceptT PluginError Action ([InlayHint] |? Null) +holeInlayHints nfp = do + (HoleMap hmap) <- useE GetHoles nfp + pure $ InL $ toAbsInlayHints hmap + where + toAbsInlayHints :: M.Map Position T.Text -> [InlayHint] + toAbsInlayHints hmap = + M.elems $ M.mapWithKey (\pos content -> + InlayHint pos (InL $ " :: " <> content) + Nothing Nothing Nothing Nothing Nothing Nothing) hmap + +------- + +holeRule :: Recorder (WithPriority InlayHintLog) -> Rules () +holeRule recorder = do + define (cmapWithPrio LogShake recorder) $ \GetHoles nfp -> do + holes <- lookupHoles nfp + pure ([], Just holes) + + -- Ensure that this plugin doesn't block on startup + addPersistentRule GetHoles $ const $ pure $ Just (HoleMap M.empty, idDelta, Nothing) + +------- + +newtype HoleMap = HoleMap (M.Map Position T.Text) +instance Show HoleMap where + show _ = "LocalBindingMap" + +instance NFData HoleMap where + rnf (HoleMap map) = rnf map + +data GetHoles = GetHoles deriving (Show, Eq, Generic) + +instance Hashable GetHoles +instance NFData GetHoles + +type instance RuleResult GetHoles = HoleMap + +lookupHoles + :: NormalizedFilePath + -> Action HoleMap +lookupHoles nfp + = flip fmap (getAtPoints nfp) $ \case + Just hm -> hm + Nothing -> HoleMap M.empty + +getAtPoints + :: NormalizedFilePath + -> Action (Maybe HoleMap) +getAtPoints nfp = runMaybeT $ do + (har, _) <- useWithStaleMT GetHieAst nfp + MaybeT $ liftIO $ Just . HoleMap <$> atPoints har + + +atPoints + :: HieAstResult + -> IO (M.Map Position T.Text) +atPoints (HAR _ hf _ _ (kind :: HieKind hietype)) = + fmap M.fromList $ M.concatMapM inlayHintInfo $ M.elems (getAsts hf) + where + inlayHintInfo :: HieAST hietype -> IO [(Position, T.Text)] + inlayHintInfo = return . inlayHintInfo' + where + inlayHintInfo' :: HieAST hietype -> [(Position, T.Text)] + inlayHintInfo' ast = case nodeChildren ast of + [] -> maybeToList (toPrettyName ast) + asts -> concatMap inlayHintInfo' asts + + toPrettyName :: HieAST hietype -> Maybe (Position, T.Text) + toPrettyName ast = (pos ast,) <$> toPrettyType ast + + pos :: HieAST hietype -> Position + pos ast = _end (realSrcSpanToRange $ nodeSpan ast) + + info :: HieAST hietype -> NodeInfo hietype + info ast = nodeInfoH kind ast + + prettyType :: hietype -> T.Text + prettyType t = case kind of + HieFresh -> printOutputable t + HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + + firstHole :: HieAST hietype -> Maybe hietype + firstHole ast = + let astInfo = info ast + -- TODO: need ONLY hole + -- Maybe there's only one solution left: regex diagnostic :( + isHole a = (==) "HsUnboundVar" $ fst $ Debug.trace (case M.toList + $ nodeIdentifiers astInfo of + [x] -> show $ printOutputable $ fst x + _ -> "oops" + ) id $ Debug.traceShowId a + nullIds = M.null $ nodeIdentifiers astInfo + in case nodeType astInfo of + (x:_) | (any isHole $ nodeAnnotations astInfo) && nullIds -> Just x + _ -> Nothing + + toPrettyType :: HieAST hietype -> Maybe T.Text + toPrettyType = fmap prettyType . firstHole + +-- In ghc9, nodeInfo is monomorphic, so we need a case split here +nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a +nodeInfoH (HieFromDisk _) = nodeInfo' +nodeInfoH HieFresh = nodeInfo diff --git a/plugins/hls-inlay-hints-plugin/test/Main.hs b/plugins/hls-inlay-hints-plugin/test/Main.hs index e32ad03bf4..9e4e9db2e7 100644 --- a/plugins/hls-inlay-hints-plugin/test/Main.hs +++ b/plugins/hls-inlay-hints-plugin/test/Main.hs @@ -1,4 +1,12 @@ -module Main where +module Main (main) where main :: IO () -main = print "ok" +main = + let + greeting :: String + greeting = "Bonjour" + greetings = unwords $ replicate times greeting; + who = "Tom" + times = 123; + in + putStrLn $ unwords [ greetings, who ] From f4ea2e3a1637f2ff531e710794cb303c5f317769 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 20 Apr 2024 06:32:23 +0800 Subject: [PATCH 5/6] haskell-language-server: drop Debug.Trace --- .../src/Ide/Plugin/InlayHints/Hole.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs index 0018e03ec7..57193b054b 100644 --- a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Hole.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Avoid restricted function" #-} module Ide.Plugin.InlayHints.Hole (holeInlayHints, holeRule) where @@ -16,7 +15,6 @@ import Data.Hashable (Hashable) import qualified Data.Map as M import Data.Maybe (maybeToList) import qualified Data.Text as T -import qualified Debug.Trace as Debug import Development.IDE (Action, GetHieAst (GetHieAst), HieKind (HieFresh, HieFromDisk), @@ -134,11 +132,7 @@ atPoints (HAR _ hf _ _ (kind :: HieKind hietype)) = let astInfo = info ast -- TODO: need ONLY hole -- Maybe there's only one solution left: regex diagnostic :( - isHole a = (==) "HsUnboundVar" $ fst $ Debug.trace (case M.toList - $ nodeIdentifiers astInfo of - [x] -> show $ printOutputable $ fst x - _ -> "oops" - ) id $ Debug.traceShowId a + isHole = (==) "HsUnboundVar" . fst nullIds = M.null $ nodeIdentifiers astInfo in case nodeType astInfo of (x:_) | (any isHole $ nodeAnnotations astInfo) && nullIds -> Just x From 9888d2b0c1581d098664a5ddd24dac7e340a39e5 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 20 Apr 2024 08:57:57 +0800 Subject: [PATCH 6/6] hls-inlay-hints-plugin: Add configuration support --- haskell-language-server.cabal | 1 + .../src/Ide/Plugin/InlayHints.hs | 32 +++++++++---- .../src/Ide/Plugin/InlayHints/Config.hs | 45 +++++++++++++++++++ 3 files changed, 69 insertions(+), 9 deletions(-) create mode 100644 plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8078f42651..93843e501e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1214,6 +1214,7 @@ library hls-inlay-hints-plugin Ide.Plugin.InlayHints.Hole Ide.Plugin.InlayHints.LocalBinding other-modules: + Ide.Plugin.InlayHints.Config build-depends: base >=4.12 && <5 , containers diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs index 8551000318..05a32f4ab7 100644 --- a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs @@ -3,26 +3,33 @@ module Ide.Plugin.InlayHints(descriptor) where -import Data.Foldable (sequenceA_, traverse_) -import Development.IDE (IdeState) +import Control.Monad.Cont (MonadIO (liftIO)) +import Data.Foldable (traverse_) +import Development.IDE (IdeState, runAction) import Development.IDE.Core.PluginUtils (runActionE) import Ide.Logger (Recorder, WithPriority) import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Plugin.InlayHints.Config (InlayHintsConfig (..), + getInlayHintsConfig, + properties) import Ide.Plugin.InlayHints.Fixity (fixityInlayHints, fixityRule) import Ide.Plugin.InlayHints.Hole (holeInlayHints, holeRule) import Ide.Plugin.InlayHints.LocalBinding (localBindingInlayHints, localBindingRule) import Ide.Plugin.InlayHints.Types (InlayHintLog) -import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), +import Ide.Types (ConfigDescriptor (configCustomConfig), + PluginDescriptor (pluginConfigDescriptor, pluginHandlers, pluginRules), PluginId, + defaultConfigDescriptor, defaultPluginDescriptor, + mkCustomConfig, mkPluginHandler) import Language.LSP.Protocol.Message (SMethod (SMethod_TextDocumentInlayHint)) import Language.LSP.Protocol.Types (InlayHintParams (InlayHintParams), Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InR)) + type (|?) (InL, InR)) descriptor :: Recorder (WithPriority InlayHintLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info in Inlay Hints") @@ -36,10 +43,17 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info $ \state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _) -> do nfp <- getNormalizedFilePathE uri runActionE "InlayHints" state $ do - fmap (foldr (<>) (InR Null)) $ traverse ($ nfp) - [ - fixityInlayHints - , holeInlayHints - , localBindingInlayHints + inlayHintsCfg <- liftIO $ runAction "inlay hints: config" state $ getInlayHintsConfig pluginId + let optional p x = if any ($ inlayHintsCfg) [p, enableAll] + then x + else const $ pure (InL []) + + fmap (foldr (<>) (InR Null)) $ traverse (($ nfp) . uncurry optional) [ + (enableFixity, fixityInlayHints) + , (enableHole, holeInlayHints) + , (enableLocalBinding, localBindingInlayHints) ] + , pluginConfigDescriptor = defaultConfigDescriptor + { configCustomConfig = mkCustomConfig properties + } } diff --git a/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs new file mode 100644 index 0000000000..e35ce84c19 --- /dev/null +++ b/plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints/Config.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.InlayHints.Config ( + InlayHintsConfig(..), + getInlayHintsConfig, + properties +) where + +import Development.IDE (Action, usePropertyAction) +import Ide.Plugin.Properties +import Ide.Types (PluginId) + +-- | The Inlay Hints plugin configuration. (see 'properties') +data InlayHintsConfig = InlayHintsConfig + { enableAll :: Bool + , enableFixity :: Bool + , enableHole :: Bool + , enableLocalBinding :: Bool + } + deriving (Eq, Ord, Show) + +properties :: Properties + '[ 'PropertyKey "all" 'TBoolean + , 'PropertyKey "fixity" 'TBoolean + , 'PropertyKey "hole" 'TBoolean + , 'PropertyKey "localBinding" 'TBoolean + ] +properties = emptyProperties + & defineBooleanProperty #localBinding + "Enable the local binding type (e.g. `let`) inlay hints" False + & defineBooleanProperty #hole + "Enable the hole type inlay hints" False + & defineBooleanProperty #fixity + "Enable the operator fixity inlay hints" False + & defineBooleanProperty #all + "Enable ALL inlay hints" False + +getInlayHintsConfig :: PluginId -> Action InlayHintsConfig +getInlayHintsConfig plId = + InlayHintsConfig + <$> usePropertyAction #all plId properties + <*> usePropertyAction #fixity plId properties + <*> usePropertyAction #hole plId properties + <*> usePropertyAction #localBinding plId properties