From ba2d544a84235f6c5a993fc5e771101bde1a673b Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Fri, 17 Jun 2022 18:36:47 +0800 Subject: [PATCH 01/24] Add sig lens for where clauses --- .../src/Development/IDE/Plugin/TypeLenses.hs | 189 +++++++++++++++--- ghcide/test/exe/Main.hs | 47 +++++ 2 files changed, 213 insertions(+), 23 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index ecfdd35449..0d3f4d572a 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-} - -- | An HLS plugin to provide code lenses for type signatures module Development.IDE.Plugin.TypeLenses ( descriptor, @@ -15,23 +15,28 @@ module Development.IDE.Plugin.TypeLenses ( import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) -import Control.Monad (mzero) +import Control.Lens ((^.)) +import Control.Monad (forM, mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson.Types (Value (..), toJSON) import qualified Data.Aeson.Types as A +import Data.Generics (GenericQ, everything, mkQ, + something) import qualified Data.HashMap.Strict as Map import Data.List (find) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe, + mapMaybe, maybeToList) +import Data.String (IsString) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, define, srcSpanToRange) import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), TypeCheck (TypeCheck)) -import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use) import qualified Development.IDE.Core.Shake as Shake @@ -49,13 +54,16 @@ import Development.IDE.Types.Logger (Pretty (pretty), Recorder, import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties -import Ide.PluginUtils (mkLspCommand, +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybeM, + mkLspCommand, + pluginResponse, usePropertyLsp) import Ide.Types (CommandFunction, - CommandId (CommandId), PluginCommand (PluginCommand), PluginDescriptor (..), PluginId, + PluginMethodHandler, configCustomConfig, defaultConfigDescriptor, defaultPluginDescriptor, @@ -66,38 +74,46 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), - List (..), ResponseError, + List (..), + Method (TextDocumentCodeLens), + ResponseError, SMethod (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) +import qualified Language.LSP.Types.Lens as L import Text.Regex.TDFA ((=~), (=~~)) data Log = LogShake Shake.Log deriving Show - instance Pretty Log where pretty = \case LogShake log -> pretty log -typeLensCommandId :: T.Text +typeLensCommandId :: IsString s => s typeLensCommandId = "typesignature.add" descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider - , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] + <> mkPluginHandler STextDocumentCodeLens whereClauseCodeLens + , pluginCommands = [PluginCommand typeLensCommandId "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } -properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)] +properties :: Properties + '[ 'PropertyKey "whereLensOn" 'TBoolean, + 'PropertyKey "mode" ('TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" [ (Always, "Always displays type lenses of global bindings") , (Exported, "Only display type lenses of exported global bindings") , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always + & defineBooleanProperty #whereLensOn + "Enable type lens on instance methods" + True codeLensProvider :: IdeState -> @@ -134,15 +150,15 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif case mode of Always -> - pure (catMaybes $ generateLensForGlobal <$> gblSigs') + pure (mapMaybe generateLensForGlobal gblSigs') <> generateLensFromDiags (suggestLocalSignature False env tmr bindings) -- we still need diagnostics for local bindings - Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' + Exported -> pure $ mapMaybe generateLensForGlobal (filter gbExported gblSigs') Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings Nothing -> pure [] generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens generateLens pId _range title edit = - let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) + let cId = mkLspCommand pId typeLensCommandId title (Just [toJSON edit]) in CodeLens _range (Just cId) Nothing commandHandler :: CommandFunction IdeState WorkspaceEdit @@ -170,7 +186,7 @@ suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} - | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- + | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier] :: [T.Text]) <- (T.unwords . T.words $ _message) =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) , Just bindings <- mBindings @@ -228,6 +244,9 @@ instance A.FromJSON Mode where showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String showDocRdrEnv env rdrEnv = showSDocForUser' env (mkPrintUnqualifiedDefault env rdrEnv) +ghostSpan :: RealSrcSpan +ghostSpan = realSrcLocSpan $ mkRealSrcLoc "" 1 1 + data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData) @@ -259,6 +278,14 @@ rules recorder = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) +-- | Get the type string of a binding id +bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) String +bindToSig id hsc rdrEnv = do + env <- tcInitTidyEnv + let name = idName id + (_, ty) = tidyOpenType env (idType id) + pure $ printName name <> " :: " <> showDocRdrEnv hsc rdrEnv (pprSigmaType ty) + gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) gblBindingType (Just hsc) (Just gblEnv) = do let exports = availsToNameSet $ tcg_exports gblEnv @@ -266,19 +293,22 @@ gblBindingType (Just hsc) (Just gblEnv) = do binds = collectHsBindsBinders $ tcg_binds gblEnv patSyns = tcg_patsyns gblEnv rdrEnv = tcg_rdr_env gblEnv - showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) - hasSig name f = whenMaybe (name `elemNameSet` sigs) f - bindToSig id = do + hasSig name = whenMaybe (name `elemNameSet` sigs) + renderBind id = do let name = idName id hasSig name $ do - env <- tcInitTidyEnv - let (_, ty) = tidyOpenType env (idType id) - pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + sig <- bindToSig id hsc rdrEnv + pure $ GlobalBindingTypeSig name sig (name `elemNameSet` exports) patToSig p = do let name = patSynName p - hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprPatSynTypeWithoutForalls p)) (name `elemNameSet` exports) - (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) $ mapM bindToSig binds + hasSig name + $ pure + $ GlobalBindingTypeSig + name + ("pattern " <> printName name <> " :: " <> showDocRdrEnv hsc rdrEnv (pprPatSynTypeWithoutForalls p)) + (name `elemNameSet` exports) + (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv ghostSpan $ mapM renderBind binds patterns <- catMaybes <$> mapM patToSig patSyns pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns gblBindingType _ _ = pure Nothing @@ -294,3 +324,116 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables builder = patSynBuilder p field_labels = patSynFieldLabels p orig_args' = map scaledThing orig_args + +-- -------------------------------------------------------------------------------- + +-- | A binding expression with its id(s) and location. +data WhereBinding = WhereBinding + { bindingId :: [Id] + -- ^ There may multiple ids for one expression. + -- e.g. @(a,b) = (1,True)@ + , bindingLoc :: SrcSpan + -- ^ Location for the whole binding. + -- Here we use the this to render the type signature at the proper place. + -- + -- Example: For @(a,b) = (1,True)@, it will print the signature after the + -- open parenthesis instead of the above of the whole expression. + } + +-- | Existed bindings in a where clause. +data WhereBindings = WhereBindings + { bindings :: [WhereBinding] + , existedSigNames :: [Name] + -- ^ Names of existing signatures. + -- It is used to hide type lens for existing signatures. + } + +-- | All where clauses from type checked source. +findWhereQ :: GenericQ [LHsLocalBinds GhcTc] +findWhereQ = everything (<>) $ mkQ [] (pure . findWhere) + where + findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> LHsLocalBinds GhcTc + findWhere = grhssLocalBinds + +-- | Find all bindings for **one** where clasure. +findBindingsQ :: GenericQ (Maybe WhereBindings) +findBindingsQ = something (mkQ Nothing findBindings) + where + findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings + findBindings (NValBinds binds sigs) = + Just $ WhereBindings + { bindings = mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds + , existedSigNames = concatMap findSigIds sigs + } + + findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding + findBindingIds (L l FunBind{..}) = Just $ WhereBinding (pure $ unLoc fun_id) l + findBindingIds (L l PatBind{..}) = + let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs + in Just $ WhereBinding ids l + findBindingIds _ = Nothing + + -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ + findIdFromPat :: Pat GhcTc -> Maybe Id + findIdFromPat (VarPat _ (L _ id)) = Just id + findIdFromPat _ = Nothing + + findSigIds (L _ (TypeSig _ names _)) = map unLoc names + findSigIds _ = [] + +-- | Provide code lens for where bindings. +whereClauseCodeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +whereClauseCodeLens state plId CodeLensParams{..} = do + enabled <- usePropertyLsp #whereLensOn plId properties + if not enabled then pure $ pure $ List [] else pluginResponse $ do + nfp <- getNormalizedFilePath plId uri + tmr <- handleMaybeM "Unable to typechecking" + $ liftIO + $ runAction "codeLens.local.TypeCheck" state + $ use TypeCheck nfp + (hscEnv -> hsc) <- handleMaybeM "Unable to get GhcSession" + $ liftIO + $ runAction "codeLens.local.GhcSession" state + $ use GhcSession nfp + let tcGblEnv = tmrTypechecked tmr + rdrEnv = tcg_rdr_env tcGblEnv + typeCheckedSource = tcg_binds tcGblEnv + + wheres = findWhereQ typeCheckedSource + localBindings = mapMaybe findBindingsQ wheres + + -- | Note there may multi ids for one binding + bindingToLenses ids span = case srcSpanToRange span of + Nothing -> pure [] + Just range -> forM ids $ \id -> do + (_, fromMaybe [] -> sig) <- liftIO + $ initTcWithGbl hsc tcGblEnv ghostSpan + $ bindToSig id hsc rdrEnv + pure $ generateWhereLens plId range (T.pack sig) + + lenses <- concat <$> sequence + [ bindingToLenses idsWithoutSig bindingLoc + | WhereBindings{..} <- localBindings + , let sigSpans = getSrcSpan <$> existedSigNames + , WhereBinding{..} <- bindings + , let idsWithoutSig = filter (\x -> getSrcSpan (idName x) `notElem` sigSpans) bindingId + ] + + pure $ List lenses + where + uri = _textDocument ^. L.uri + + generateWhereLens :: PluginId -> Range -> T.Text -> CodeLens + generateWhereLens plId range title = + let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON (makeEdit range title)]) + in CodeLens range (Just cmd) Nothing + + makeEdit :: Range -> T.Text -> WorkspaceEdit + makeEdit range text = + let startPos = range ^. L.start + insertChar = startPos ^. L.character + insertRange = Range startPos startPos + in WorkspaceEdit + (pure [(uri, List [TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ")])]) + Nothing + Nothing diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index b91af99c74..432464f4a7 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -848,6 +848,7 @@ codeActionHelperFunctionTests = testGroup "code action helpers" codeLensesTests :: TestTree codeLensesTests = testGroup "code lenses" [ addSigLensesTests + , addSigLensesForWhereClausesTests ] watchedFilesTests :: TestTree @@ -4230,6 +4231,52 @@ addSigLensesTests = ] ] +addSigLensesForWhereClausesTests :: TestTree +addSigLensesForWhereClausesTests = testGroup + "add signature for where clauses" + [ testSession "Disbled" $ do + let content = T.unlines + [ "module Sigs where" + , "f :: b" + , "f = undefined" + , " where" + , " g = True" + ] + sendNotification SWorkspaceDidChangeConfiguration + $ DidChangeConfigurationParams + $ A.object + ["haskell" A..= A.object + ["plugin" A..= A.object + ["ghcide-type-lenses" A..= A.object + ["config" A..= A.object + ["whereLensOn" A..= A.Bool False]]]]] + doc <- createDoc "Sigs.hs" "haskell" content + waitForProgressDone + lenses <- getCodeLenses doc + liftIO $ length lenses @?= 0 + , test "Simple" " g = True" " g :: Bool\n g = True" + , test "Tuple" " (g,h) = (id, True)" " g :: a -> a\n (g,h) = (id, True)" + , test "Operator" " g = ($)" " g :: (a -> b) -> a -> b\n g = ($)" + , test "Infix" " a `g` b = a" " g :: p1 -> p -> p1\n a `g` b = a" + , expectFail $ test "Typeclass" " g a b = a + b" " g :: Num a :: a -> a -> a\n g a b = a + b" + ] + where + test title clauses expected = testSession title $ do + let baseContent = T.unlines + [ "module Sigs where" + , "f :: b" + , "f = undefined" + , " where" + ] + doc <- createDoc "Sigs.hs" "haskell" (baseContent <> clauses) + waitForProgressDone + lenses <- getCodeLenses doc + executeCommand $ fromJust $ head lenses ^. L.command + void $ skipManyTill anyMessage (getDocumentEdit doc) + contents <- documentContents doc + liftIO $ contents @?= baseContent <> expected + closeDoc doc + linkToLocation :: [LocationLink] -> [Location] linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) From 7bf07ca37bb541b5fe58fc1f83b3283270088338 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sun, 19 Jun 2022 23:46:08 +0800 Subject: [PATCH 02/24] Compat --- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 10 ++++++++++ .../src/Development/IDE/Plugin/TypeLenses.hs | 19 +++++++++++-------- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 9d4cf17e6f..b5812b7057 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -315,7 +315,9 @@ module Development.IDE.GHC.Compat.Core ( gre_par, #if MIN_VERSION_ghc(9,2,0) collectHsBindsBinders, + NHsValBindsLR(..), #endif + grhssLocalBindsCompat, -- * Util Module re-exports #if MIN_VERSION_ghc(9,0,0) module GHC.Builtin.Names, @@ -482,6 +484,7 @@ import GHC.Types.Unique.FM #if MIN_VERSION_ghc(9,2,0) import GHC.Data.Bag import GHC.Core.Multiplicity (scaledThing) +import GHC.Hs.Binds (NHsValBindsLR(..)) #else import GHC.Core.Ppr.TyThing hiding (pprFamInst) import GHC.Core.TyCo.Rep (scaledThing) @@ -1084,3 +1087,10 @@ pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds) rationalFromFractionalLit :: FractionalLit -> Rational rationalFromFractionalLit = fl_value #endif + +grhssLocalBindsCompat :: GRHSs p body -> HsLocalBinds p +#if MIN_VERSION_ghc(9,2,0) +grhssLocalBindsCompat = grhssLocalBinds +#else +grhssLocalBindsCompat = SrcLoc.unLoc . grhssLocalBinds +#endif diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 0d3f4d572a..f91d05066c 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -349,11 +349,11 @@ data WhereBindings = WhereBindings } -- | All where clauses from type checked source. -findWhereQ :: GenericQ [LHsLocalBinds GhcTc] +findWhereQ :: GenericQ [HsLocalBinds GhcTc] findWhereQ = everything (<>) $ mkQ [] (pure . findWhere) where - findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> LHsLocalBinds GhcTc - findWhere = grhssLocalBinds + findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> HsLocalBinds GhcTc + findWhere = grhssLocalBindsCompat -- | Find all bindings for **one** where clasure. findBindingsQ :: GenericQ (Maybe WhereBindings) @@ -367,11 +367,14 @@ findBindingsQ = something (mkQ Nothing findBindings) } findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding - findBindingIds (L l FunBind{..}) = Just $ WhereBinding (pure $ unLoc fun_id) l - findBindingIds (L l PatBind{..}) = - let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs - in Just $ WhereBinding ids l - findBindingIds _ = Nothing + findBindingIds bind = case unLoc bind of + FunBind{..} -> Just $ WhereBinding (pure $ unLoc fun_id) l + PatBind{..} -> + let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs + in Just $ WhereBinding ids l + _ -> Nothing + where + l = getLoc bind -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ findIdFromPat :: Pat GhcTc -> Maybe Id From 51ef2319f50c4d5159cb5fedd9a4045a1f4f424c Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Mon, 20 Jun 2022 16:43:15 +0800 Subject: [PATCH 03/24] Golden tests --- .../src/Development/IDE/Plugin/TypeLenses.hs | 210 ++++++++++-------- .../data/local-sig-lens/Infix.expected.hs | 7 + ghcide/test/data/local-sig-lens/Infix.hs | 6 + .../data/local-sig-lens/Inline.expected.hs | 6 + ghcide/test/data/local-sig-lens/Inline.hs | 5 + .../test/data/local-sig-lens/Nest.expected.hs | 10 + ghcide/test/data/local-sig-lens/Nest.hs | 7 + .../data/local-sig-lens/NoLens.expected.hs | 13 ++ ghcide/test/data/local-sig-lens/NoLens.hs | 13 ++ .../data/local-sig-lens/Operator.expected.hs | 7 + ghcide/test/data/local-sig-lens/Operator.hs | 6 + .../data/local-sig-lens/Qualified.expected.hs | 9 + ghcide/test/data/local-sig-lens/Qualified.hs | 8 + .../ScopedTypeVariables.expected.hs | 8 + .../local-sig-lens/ScopedTypeVariables.hs | 7 + .../data/local-sig-lens/Simple.expected.hs | 7 + ghcide/test/data/local-sig-lens/Simple.hs | 6 + .../data/local-sig-lens/Tuple.expected.hs | 8 + ghcide/test/data/local-sig-lens/Tuple.hs | 6 + .../data/local-sig-lens/Typeclass.expected.hs | 7 + ghcide/test/data/local-sig-lens/Typeclass.hs | 6 + ghcide/test/exe/Main.hs | 49 ++-- 22 files changed, 293 insertions(+), 118 deletions(-) create mode 100644 ghcide/test/data/local-sig-lens/Infix.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Infix.hs create mode 100644 ghcide/test/data/local-sig-lens/Inline.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Inline.hs create mode 100644 ghcide/test/data/local-sig-lens/Nest.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Nest.hs create mode 100644 ghcide/test/data/local-sig-lens/NoLens.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/NoLens.hs create mode 100644 ghcide/test/data/local-sig-lens/Operator.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Operator.hs create mode 100644 ghcide/test/data/local-sig-lens/Qualified.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Qualified.hs create mode 100644 ghcide/test/data/local-sig-lens/ScopedTypeVariables.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/ScopedTypeVariables.hs create mode 100644 ghcide/test/data/local-sig-lens/Simple.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Simple.hs create mode 100644 ghcide/test/data/local-sig-lens/Tuple.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Tuple.hs create mode 100644 ghcide/test/data/local-sig-lens/Typeclass.expected.hs create mode 100644 ghcide/test/data/local-sig-lens/Typeclass.hs diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index f91d05066c..a00808676d 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -112,7 +112,7 @@ properties = emptyProperties , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always & defineBooleanProperty #whereLensOn - "Enable type lens on instance methods" + "Display type lenses of where bindings" True codeLensProvider :: @@ -329,114 +329,128 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables -- | A binding expression with its id(s) and location. data WhereBinding = WhereBinding - { bindingId :: [Id] - -- ^ There may multiple ids for one expression. - -- e.g. @(a,b) = (1,True)@ - , bindingLoc :: SrcSpan - -- ^ Location for the whole binding. - -- Here we use the this to render the type signature at the proper place. - -- - -- Example: For @(a,b) = (1,True)@, it will print the signature after the - -- open parenthesis instead of the above of the whole expression. - } + { bindingId :: [Id] + -- ^ There may multiple ids for one expression. + -- e.g. @(a,b) = (1,True)@ + , bindingLoc :: SrcSpan + -- ^ Location for the whole binding. + -- Here we use the this to render the type signature at the proper place. + -- + -- Example: For @(a,b) = (1,True)@, it will print the signature after the + -- open parenthesis instead of the above of the whole expression + -- if we don't use the binding span. + } -- | Existed bindings in a where clause. data WhereBindings = WhereBindings - { bindings :: [WhereBinding] - , existedSigNames :: [Name] - -- ^ Names of existing signatures. - -- It is used to hide type lens for existing signatures. - } + { bindings :: [WhereBinding] + , existedSigNames :: [Name] + -- ^ Names of existing signatures. + -- It is used to hide type lens for existing signatures. + -- + -- NOTE: The location of this name is equal to + -- the binding name. + -- + -- Example: + -- @ + -- f :: Int + -- f = 42 + -- @ + -- The location of signature name `f`(first line) is equal to + -- the definition of `f`(second line). + } -- | All where clauses from type checked source. findWhereQ :: GenericQ [HsLocalBinds GhcTc] findWhereQ = everything (<>) $ mkQ [] (pure . findWhere) - where - findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> HsLocalBinds GhcTc - findWhere = grhssLocalBindsCompat + where + findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> HsLocalBinds GhcTc + findWhere = grhssLocalBindsCompat --- | Find all bindings for **one** where clasure. +-- | Find all bindings for **one** where clause. findBindingsQ :: GenericQ (Maybe WhereBindings) findBindingsQ = something (mkQ Nothing findBindings) - where - findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings - findBindings (NValBinds binds sigs) = - Just $ WhereBindings - { bindings = mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds - , existedSigNames = concatMap findSigIds sigs - } - - findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding - findBindingIds bind = case unLoc bind of - FunBind{..} -> Just $ WhereBinding (pure $ unLoc fun_id) l - PatBind{..} -> - let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs - in Just $ WhereBinding ids l - _ -> Nothing - where - l = getLoc bind - - -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ - findIdFromPat :: Pat GhcTc -> Maybe Id - findIdFromPat (VarPat _ (L _ id)) = Just id - findIdFromPat _ = Nothing - - findSigIds (L _ (TypeSig _ names _)) = map unLoc names - findSigIds _ = [] + where + findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings + findBindings (NValBinds binds sigs) = + Just $ WhereBindings + { bindings = mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds + , existedSigNames = concatMap findSigIds sigs + } + + findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding + findBindingIds bind = case unLoc bind of + FunBind{..} -> Just $ WhereBinding (pure $ unLoc fun_id) l + PatBind{..} -> + let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs + in Just $ WhereBinding ids l + _ -> Nothing + where + l = getLoc bind + + -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ + findIdFromPat :: Pat GhcTc -> Maybe Id + findIdFromPat (VarPat _ (L _ id)) = Just id + findIdFromPat _ = Nothing + + findSigIds (L _ (TypeSig _ names _)) = map unLoc names + findSigIds _ = [] -- | Provide code lens for where bindings. whereClauseCodeLens :: PluginMethodHandler IdeState TextDocumentCodeLens whereClauseCodeLens state plId CodeLensParams{..} = do - enabled <- usePropertyLsp #whereLensOn plId properties - if not enabled then pure $ pure $ List [] else pluginResponse $ do - nfp <- getNormalizedFilePath plId uri - tmr <- handleMaybeM "Unable to typechecking" - $ liftIO - $ runAction "codeLens.local.TypeCheck" state - $ use TypeCheck nfp - (hscEnv -> hsc) <- handleMaybeM "Unable to get GhcSession" - $ liftIO - $ runAction "codeLens.local.GhcSession" state - $ use GhcSession nfp - let tcGblEnv = tmrTypechecked tmr - rdrEnv = tcg_rdr_env tcGblEnv - typeCheckedSource = tcg_binds tcGblEnv - - wheres = findWhereQ typeCheckedSource - localBindings = mapMaybe findBindingsQ wheres - - -- | Note there may multi ids for one binding - bindingToLenses ids span = case srcSpanToRange span of - Nothing -> pure [] - Just range -> forM ids $ \id -> do - (_, fromMaybe [] -> sig) <- liftIO - $ initTcWithGbl hsc tcGblEnv ghostSpan - $ bindToSig id hsc rdrEnv - pure $ generateWhereLens plId range (T.pack sig) - - lenses <- concat <$> sequence - [ bindingToLenses idsWithoutSig bindingLoc - | WhereBindings{..} <- localBindings - , let sigSpans = getSrcSpan <$> existedSigNames - , WhereBinding{..} <- bindings - , let idsWithoutSig = filter (\x -> getSrcSpan (idName x) `notElem` sigSpans) bindingId - ] - - pure $ List lenses - where - uri = _textDocument ^. L.uri - - generateWhereLens :: PluginId -> Range -> T.Text -> CodeLens - generateWhereLens plId range title = - let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON (makeEdit range title)]) - in CodeLens range (Just cmd) Nothing - - makeEdit :: Range -> T.Text -> WorkspaceEdit - makeEdit range text = - let startPos = range ^. L.start - insertChar = startPos ^. L.character - insertRange = Range startPos startPos - in WorkspaceEdit - (pure [(uri, List [TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ")])]) - Nothing - Nothing + enabled <- usePropertyLsp #whereLensOn plId properties + if not enabled then pure $ pure $ List [] else pluginResponse $ do + nfp <- getNormalizedFilePath plId uri + tmr <- handleMaybeM "Unable to typechecking" + $ liftIO + $ runAction "codeLens.local.TypeCheck" state + $ use TypeCheck nfp + (hscEnv -> hsc) <- handleMaybeM "Unable to get GhcSession" + $ liftIO + $ runAction "codeLens.local.GhcSession" state + $ use GhcSession nfp + let tcGblEnv = tmrTypechecked tmr + rdrEnv = tcg_rdr_env tcGblEnv + typeCheckedSource = tcg_binds tcGblEnv + + wheres = findWhereQ typeCheckedSource + localBindings = mapMaybe findBindingsQ wheres + + -- | Note there may multi ids for one binding, + -- like @(a, b) = (42, True)@, there are `a` and `b` + -- in one binding. + bindingToLenses ids span = case srcSpanToRange span of + Nothing -> pure [] + Just range -> forM ids $ \id -> do + (_, fromMaybe [] -> sig) <- liftIO + $ initTcWithGbl hsc tcGblEnv ghostSpan + $ bindToSig id hsc rdrEnv + pure $ generateWhereLens plId range (T.pack sig) + + lenses <- concat <$> sequence + [ bindingToLenses idsWithoutSig bindingLoc + | WhereBindings{..} <- localBindings + , let sigSpans = getSrcSpan <$> existedSigNames + , WhereBinding{..} <- bindings + , let idsWithoutSig = filter (\x -> getSrcSpan (idName x) `notElem` sigSpans) bindingId + ] + + pure $ List lenses + where + uri = _textDocument ^. L.uri + + generateWhereLens :: PluginId -> Range -> T.Text -> CodeLens + generateWhereLens plId range title = + let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON (makeEdit range title)]) + in CodeLens range (Just cmd) Nothing + + makeEdit :: Range -> T.Text -> WorkspaceEdit + makeEdit range text = + let startPos = range ^. L.start + insertChar = startPos ^. L.character + insertRange = Range startPos startPos + in WorkspaceEdit + (pure [(uri, List [TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ")])]) + Nothing + Nothing diff --git a/ghcide/test/data/local-sig-lens/Infix.expected.hs b/ghcide/test/data/local-sig-lens/Infix.expected.hs new file mode 100644 index 0000000000..bef11e0565 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Infix.expected.hs @@ -0,0 +1,7 @@ +module Infix where + +f :: a +f = undefined + where + g :: p1 -> p -> p1 + a `g` b = a diff --git a/ghcide/test/data/local-sig-lens/Infix.hs b/ghcide/test/data/local-sig-lens/Infix.hs new file mode 100644 index 0000000000..cf29c31010 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Infix.hs @@ -0,0 +1,6 @@ +module Infix where + +f :: a +f = undefined + where + a `g` b = a diff --git a/ghcide/test/data/local-sig-lens/Inline.expected.hs b/ghcide/test/data/local-sig-lens/Inline.expected.hs new file mode 100644 index 0000000000..f9b32f84a5 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Inline.expected.hs @@ -0,0 +1,6 @@ +module Inline where + +f :: a +f = undefined + where g :: Bool + g = True diff --git a/ghcide/test/data/local-sig-lens/Inline.hs b/ghcide/test/data/local-sig-lens/Inline.hs new file mode 100644 index 0000000000..3adcb786a7 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Inline.hs @@ -0,0 +1,5 @@ +module Inline where + +f :: a +f = undefined + where g = True diff --git a/ghcide/test/data/local-sig-lens/Nest.expected.hs b/ghcide/test/data/local-sig-lens/Nest.expected.hs new file mode 100644 index 0000000000..ef2883c23c --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Nest.expected.hs @@ -0,0 +1,10 @@ +module Nest where + +f :: Int +f = g + where + g :: Int + g = h + h :: Int + h = k where k :: Int + k = 3 diff --git a/ghcide/test/data/local-sig-lens/Nest.hs b/ghcide/test/data/local-sig-lens/Nest.hs new file mode 100644 index 0000000000..9da7ea6e7e --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Nest.hs @@ -0,0 +1,7 @@ +module Nest where + +f :: Int +f = g + where + g = h + h = k where k = 3 diff --git a/ghcide/test/data/local-sig-lens/NoLens.expected.hs b/ghcide/test/data/local-sig-lens/NoLens.expected.hs new file mode 100644 index 0000000000..9a01a17762 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/NoLens.expected.hs @@ -0,0 +1,13 @@ +module NoLens where + +f :: a +f = undefined + where + g = 3 + + + + + + + g :: Int diff --git a/ghcide/test/data/local-sig-lens/NoLens.hs b/ghcide/test/data/local-sig-lens/NoLens.hs new file mode 100644 index 0000000000..9a01a17762 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/NoLens.hs @@ -0,0 +1,13 @@ +module NoLens where + +f :: a +f = undefined + where + g = 3 + + + + + + + g :: Int diff --git a/ghcide/test/data/local-sig-lens/Operator.expected.hs b/ghcide/test/data/local-sig-lens/Operator.expected.hs new file mode 100644 index 0000000000..0bae866b6b --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Operator.expected.hs @@ -0,0 +1,7 @@ +module Operator where + +f :: a +f = undefined + where + g :: (a -> b) -> a -> b + g = ($) diff --git a/ghcide/test/data/local-sig-lens/Operator.hs b/ghcide/test/data/local-sig-lens/Operator.hs new file mode 100644 index 0000000000..4708de5966 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Operator.hs @@ -0,0 +1,6 @@ +module Operator where + +f :: a +f = undefined + where + g = ($) diff --git a/ghcide/test/data/local-sig-lens/Qualified.expected.hs b/ghcide/test/data/local-sig-lens/Qualified.expected.hs new file mode 100644 index 0000000000..7b3623a4ee --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Qualified.expected.hs @@ -0,0 +1,9 @@ +module Qualified where + +import qualified Data.Map as Map + +f :: a +f = undefined + where + g :: Map.Map Bool Char + g = Map.singleton True 'c' diff --git a/ghcide/test/data/local-sig-lens/Qualified.hs b/ghcide/test/data/local-sig-lens/Qualified.hs new file mode 100644 index 0000000000..82c69893a3 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Qualified.hs @@ -0,0 +1,8 @@ +module Qualified where + +import qualified Data.Map as Map + +f :: a +f = undefined + where + g = Map.singleton True 'c' diff --git a/ghcide/test/data/local-sig-lens/ScopedTypeVariables.expected.hs b/ghcide/test/data/local-sig-lens/ScopedTypeVariables.expected.hs new file mode 100644 index 0000000000..e7aa4b18b8 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/ScopedTypeVariables.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitForAll #-} +module ScopedTypeVariables where + +f :: forall a b. a -> b -> (a, b) +f aa bb = (aa, ida bb) + where + ida :: b -> b + ida = id diff --git a/ghcide/test/data/local-sig-lens/ScopedTypeVariables.hs b/ghcide/test/data/local-sig-lens/ScopedTypeVariables.hs new file mode 100644 index 0000000000..48fe48e41d --- /dev/null +++ b/ghcide/test/data/local-sig-lens/ScopedTypeVariables.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExplicitForAll #-} +module ScopedTypeVariables where + +f :: forall a b. a -> b -> (a, b) +f aa bb = (aa, ida bb) + where + ida = id diff --git a/ghcide/test/data/local-sig-lens/Simple.expected.hs b/ghcide/test/data/local-sig-lens/Simple.expected.hs new file mode 100644 index 0000000000..23d55a326d --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Simple.expected.hs @@ -0,0 +1,7 @@ +module Simple where + +f :: a +f = undefined + where + g :: Bool + g = True diff --git a/ghcide/test/data/local-sig-lens/Simple.hs b/ghcide/test/data/local-sig-lens/Simple.hs new file mode 100644 index 0000000000..952a08ace6 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Simple.hs @@ -0,0 +1,6 @@ +module Simple where + +f :: a +f = undefined + where + g = True diff --git a/ghcide/test/data/local-sig-lens/Tuple.expected.hs b/ghcide/test/data/local-sig-lens/Tuple.expected.hs new file mode 100644 index 0000000000..354bc35f34 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Tuple.expected.hs @@ -0,0 +1,8 @@ +module Typle where + +f :: a +f = undefined + where + g :: Integer + h :: Bool + (g, h) = (1, True) diff --git a/ghcide/test/data/local-sig-lens/Tuple.hs b/ghcide/test/data/local-sig-lens/Tuple.hs new file mode 100644 index 0000000000..27d6a19d3b --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Tuple.hs @@ -0,0 +1,6 @@ +module Typle where + +f :: a +f = undefined + where + (g, h) = (1, True) diff --git a/ghcide/test/data/local-sig-lens/Typeclass.expected.hs b/ghcide/test/data/local-sig-lens/Typeclass.expected.hs new file mode 100644 index 0000000000..4e8d58e895 --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Typeclass.expected.hs @@ -0,0 +1,7 @@ +module Typeclass where + +f :: a +f = undefined + where + g :: Num a => a -> a -> a + g a b = a + b diff --git a/ghcide/test/data/local-sig-lens/Typeclass.hs b/ghcide/test/data/local-sig-lens/Typeclass.hs new file mode 100644 index 0000000000..8ea9361bfb --- /dev/null +++ b/ghcide/test/data/local-sig-lens/Typeclass.hs @@ -0,0 +1,6 @@ +module Typeclass where + +f :: a +f = undefined + where + g a b = a + b diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 432464f4a7..e041c57aa7 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4234,7 +4234,7 @@ addSigLensesTests = addSigLensesForWhereClausesTests :: TestTree addSigLensesForWhereClausesTests = testGroup "add signature for where clauses" - [ testSession "Disbled" $ do + [ testSession "No lens if disbled" $ do let content = T.unlines [ "module Sigs where" , "f :: b" @@ -4254,28 +4254,37 @@ addSigLensesForWhereClausesTests = testGroup waitForProgressDone lenses <- getCodeLenses doc liftIO $ length lenses @?= 0 - , test "Simple" " g = True" " g :: Bool\n g = True" - , test "Tuple" " (g,h) = (id, True)" " g :: a -> a\n (g,h) = (id, True)" - , test "Operator" " g = ($)" " g :: (a -> b) -> a -> b\n g = ($)" - , test "Infix" " a `g` b = a" " g :: p1 -> p -> p1\n a `g` b = a" - , expectFail $ test "Typeclass" " g a b = a + b" " g :: Num a :: a -> a -> a\n g a b = a + b" + , test "Simple" "Simple" + , test "Tuple" "Tuple" + , test "Inline" "Inline" + , test "Infix" "Infix" + , test "Operator" "Operator" + , expectFail $ test "ScopedTypeVariables" "ScopedTypeVariables" + , test "Nest" "Nest" + , test "No lens" "NoLens" + , expectFail $ test "Typeclass" "Typeclass" + , test "Quqlified" "Qualified" ] where - test title clauses expected = testSession title $ do - let baseContent = T.unlines - [ "module Sigs where" - , "f :: b" - , "f = undefined" - , " where" - ] - doc <- createDoc "Sigs.hs" "haskell" (baseContent <> clauses) - waitForProgressDone + test :: String -> FilePath -> TestTree + test title file = testSessionWithExtraFiles "local-sig-lens" title $ \dir -> do + doc <- openDoc (dir file ++ ".hs") "haskell" + executeAllLens doc + real <- documentContents doc + expectedDoc <- openDoc (dir file ++ ".expected.hs") "haskell" + expected <- documentContents expectedDoc + liftIO $ real @?= expected + + executeAllLens :: TextDocumentIdentifier -> Session () + executeAllLens doc = do + void $ waitForTypecheck doc lenses <- getCodeLenses doc - executeCommand $ fromJust $ head lenses ^. L.command - void $ skipManyTill anyMessage (getDocumentEdit doc) - contents <- documentContents doc - liftIO $ contents @?= baseContent <> expected - closeDoc doc + let cmds = mapMaybe (^. L.command) lenses + unless (null cmds) $ do + let cmd = head cmds + executeCommand cmd + void $ skipManyTill anyMessage (getDocumentEdit doc) + executeAllLens doc linkToLocation :: [LocationLink] -> [Location] linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) From f401ff23bad8c8662b51a9b02dadd67741f7726f Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Tue, 30 Jul 2024 16:26:46 +0800 Subject: [PATCH 04/24] Provide where sigs in inlay hints --- .../src/Development/IDE/Plugin/TypeLenses.hs | 143 ++++++++++-------- 1 file changed, 77 insertions(+), 66 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 0faaff167c..f9e99e8195 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RecordPuns #-} {-# LANGUAGE TypeFamilies #-} -- | An HLS plugin to provide code lenses for type signatures @@ -15,8 +17,9 @@ module Development.IDE.Plugin.TypeLenses ( import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) -import Control.Lens ((?~), (^.)) -import Control.Monad (forM, mzero) +import Control.Lens (Bifunctor (bimap), (?~), + (^.)) +import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) @@ -26,8 +29,8 @@ import Data.Generics (GenericQ, everything, mkQ, something) import Data.List (find) import qualified Data.Map as Map -import Data.Maybe (catMaybes, fromMaybe, - mapMaybe, maybeToList) +import Data.Maybe (catMaybes, mapMaybe, + maybeToList) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), @@ -48,10 +51,11 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes -import Development.IDE.Types.Location (Position (Position, _line), +import Development.IDE.Types.Location (Position (Position, _character, _line), Range (Range, _end, _start)) import GHC.Exts (IsString) import GHC.Generics (Generic) +import GHC.Hs (realSrcSpan) import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) @@ -72,16 +76,19 @@ import Ide.Types (CommandFunction, mkResolveHandler, pluginSendRequest) import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens), +import Language.LSP.Protocol.Message (Method (..), SMethod (..)) import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), CodeLens (..), CodeLensParams (CodeLensParams, _textDocument), Command, Diagnostic (..), + InlayHint (..), + InlayHintParams (InlayHintParams), Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), + isSubrangeOf, type (|?) (..)) import Text.Regex.TDFA ((=~)) @@ -100,7 +107,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider - <> mkPluginHandler SMethod_TextDocumentCodeLens whereClauseCodeLens + <> mkPluginHandler SMethod_TextDocumentInlayHint whereClauseInlayHints , pluginCommands = [PluginCommand typeLensCommandId "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -109,7 +116,7 @@ descriptor recorder plId = desc = "Provides code lenses type signatures" properties :: Properties - '[ 'PropertyKey "whereLensOn" 'TBoolean, + '[ 'PropertyKey "whereInlayHintOn" 'TBoolean, 'PropertyKey "mode" ('TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" @@ -117,7 +124,7 @@ properties = emptyProperties , (Exported, "Only display type lenses of exported global bindings") , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always - & defineBooleanProperty #whereLensOn + & defineBooleanProperty #whereInlayHintOn "Enable type lens on instance methods" True @@ -317,12 +324,12 @@ rules recorder = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) -bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) String +bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) (Name, String) bindToSig id hsc rdrEnv = do env <- tcInitTidyEnv let name = idName id (_, ty) = tidyOpenType env (idType id) - pure $ printName name <> " :: " <> showDocRdrEnv hsc rdrEnv (pprSigmaType ty) + pure (name, showDocRdrEnv hsc rdrEnv (pprSigmaType ty)) gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) gblBindingType (Just hsc) (Just gblEnv) = do @@ -336,7 +343,7 @@ gblBindingType (Just hsc) (Just gblEnv) = do renderBind id = do let name = idName id hasSig name $ do - sig <- bindToSig id hsc rdrEnv + (_, sig) <- bindToSig id hsc rdrEnv pure $ GlobalBindingTypeSig name sig (name `elemNameSet` exports) patToSig p = do let name = patSynName p @@ -365,17 +372,19 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables -- -------------------------------------------------------------------------------- --- | A binding expression with its id(s) and location. +-- | A binding expression with its id and location. data WhereBinding = WhereBinding - { bindingId :: [Id] - -- ^ There may multiple ids for one expression. - -- e.g. @(a,b) = (1,True)@ + { bindingId :: Id + -- ^ Each WhereBinding represents a id in binding expression. , bindingLoc :: SrcSpan - -- ^ Location for the whole binding. - -- Here we use the this to render the type signature at the proper place. + -- ^ Location for a individual binding in a pattern. + -- Here we use the this and offset to render the type signature at the proper place. + , offset :: Int + -- ^ Column offset between whole binding and individual binding in a pattern. -- - -- Example: For @(a,b) = (1,True)@, it will print the signature after the - -- open parenthesis instead of the above of the whole expression. + -- Example: For @(a, b) = (1, True)@, there will be two `WhereBinding`s: + -- - `a`: WhereBinding id_a loc_a 0 + -- - `b`: WhereBinding id_b loc_b 4 } -- | Existed bindings in a where clause. @@ -411,42 +420,36 @@ findBindingsQ = something (mkQ Nothing findBindings) findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings findBindings (NValBinds binds sigs) = Just $ WhereBindings - { bindings = mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds + { bindings = concat $ mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds , existedSigNames = concatMap findSigIds sigs } - findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe WhereBinding + findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe [WhereBinding] findBindingIds bind = case unLoc bind of - FunBind{..} -> Just $ WhereBinding (pure $ unLoc fun_id) l - PatBind{..} -> - let ids = (everything (<>) $ mkQ [] (maybeToList . findIdFromPat)) pat_lhs - in Just $ WhereBinding ids l + FunBind{..} -> Just $ pure $ WhereBinding (unLoc fun_id) (getLoc fun_id) 0 + PatBind{..} -> Just $ (everything (<>) $ mkQ [] (fmap (uncurry wb) . maybeToList . findIdFromPat)) pat_lhs + where + col = srcSpanStartCol . realSrcSpan + wb id srcSpan = WhereBinding id srcSpan (col srcSpan - col (getLoc pat_lhs)) _ -> Nothing - where - l = getLoc bind -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ - findIdFromPat :: Pat GhcTc -> Maybe Id - findIdFromPat (VarPat _ (L _ id)) = Just id - findIdFromPat _ = Nothing + findIdFromPat :: Pat GhcTc -> Maybe (Id, SrcSpan) + findIdFromPat (VarPat _ located) = Just (unLoc located, getLoc located) + findIdFromPat _ = Nothing + findSigIds :: GenLocated l (Sig GhcRn) -> [IdP GhcRn] findSigIds (L _ (TypeSig _ names _)) = map unLoc names findSigIds _ = [] -- | Provide code lens for where bindings. -whereClauseCodeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -whereClauseCodeLens state plId CodeLensParams{..} = do - enabled <- liftIO $ runAction "codeLens.config" state $ usePropertyAction #whereLensOn plId properties +whereClauseInlayHints :: PluginMethodHandler IdeState Method_TextDocumentInlayHint +whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) visibleRange) = do + enabled <- liftIO $ runAction "inlayHint.config" state $ usePropertyAction #whereInlayHintOn plId properties if not enabled then pure $ InL [] else do nfp <- getNormalizedFilePathE uri - tmr <- handleMaybeM (PluginInternalError "Unable to typechecking") - $ liftIO - $ runAction "codeLens.local.TypeCheck" state - $ use TypeCheck nfp - (hscEnv -> hsc) <- handleMaybeM (PluginInternalError "Unable to get GhcSession") - $ liftIO - $ runAction "codeLens.local.GhcSession" state - $ use GhcSession nfp + (tmr, _) <- runActionE "inlayHint.local.TypeCheck" state $ useWithStaleE TypeCheck nfp + (hscEnv -> hsc, _) <- runActionE "InlayHint.local.GhcSession" state $ useWithStaleE GhcSession nfp let tcGblEnv = tmrTypechecked tmr rdrEnv = tcg_rdr_env tcGblEnv typeCheckedSource = tcg_binds tcGblEnv @@ -457,37 +460,45 @@ whereClauseCodeLens state plId CodeLensParams{..} = do -- | Note there may multi ids for one binding, -- like @(a, b) = (42, True)@, there are `a` and `b` -- in one binding. - bindingToLenses ids span = case srcSpanToRange span of - Nothing -> pure [] - Just range -> forM ids $ \id -> do - (_, fromMaybe [] -> sig) <- liftIO + bindingToInlayHints id span offset = case srcSpanToRange span of + Nothing -> pure Nothing + Just range -> do + (_, sig) <- liftIO $ initTcWithGbl hsc tcGblEnv ghostSpan $ bindToSig id hsc rdrEnv - pure $ generateWhereLens plId range (T.pack sig) + pure $ Just $ generateWhereInlayHints range (maybe ("", "") (bimap (T.pack . printName) T.pack) sig) offset - lenses <- concat <$> sequence - [ bindingToLenses idsWithoutSig bindingLoc + inlayHints <- catMaybes <$> sequence + [ bindingToInlayHints bindingId bindingLoc offset | WhereBindings{..} <- localBindings , let sigSpans = getSrcSpan <$> existedSigNames , WhereBinding{..} <- bindings - , let idsWithoutSig = filter (\x -> getSrcSpan (idName x) `notElem` sigSpans) bindingId + , let bindingSpan = getSrcSpan (idName bindingId) + , bindingSpan `notElem` sigSpans + -- Show inlay hints only within visible range + , Just True <- [flip isSubrangeOf visibleRange <$> srcSpanToRange bindingSpan] ] - pure $ InL lenses + pure $ InL inlayHints where - uri = _textDocument ^. L.uri - - generateWhereLens :: PluginId -> Range -> T.Text -> CodeLens - generateWhereLens plId range title = - let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON (makeEdit range title)]) - in CodeLens range (Just cmd) Nothing - - makeEdit :: Range -> T.Text -> WorkspaceEdit - makeEdit range text = + generateWhereInlayHints :: Range -> (T.Text, T.Text) -> Int -> InlayHint + generateWhereInlayHints range (name, ty) offset = + let edit = makeEdit range (name <> " :: " <> ty) offset + in InlayHint { _textEdits = Just [edit] + , _paddingRight = Nothing + , _paddingLeft = Just True + , _tooltip = Nothing + , _position = _end range + , _kind = Nothing + , _label = InL $ ":: " <> ty + , _data_ = Nothing + } + + makeEdit :: Range -> T.Text -> Int -> TextEdit + makeEdit range text offset = let startPos = range ^. L.start - insertChar = startPos ^. L.character - insertRange = Range startPos startPos - in WorkspaceEdit - (pure $ Map.fromList [(uri, [TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ")])]) - Nothing - Nothing + -- Subtract the offset to align with the whole binding expression + startPos' = startPos { _character = _character startPos - fromIntegral offset } + insertChar = startPos' ^. L.character + insertRange = Range startPos' startPos' + in TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ") From 287f7fa8c6b7d9739f17a8ad4d76f730fd12d8e7 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 31 Jul 2024 18:18:37 +0800 Subject: [PATCH 05/24] add offset for FunBind since infix function --- .../src/Development/IDE/Plugin/TypeLenses.hs | 35 ++++++++++--------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index f9e99e8195..b6027e1259 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RecordPuns #-} {-# LANGUAGE TypeFamilies #-} -- | An HLS plugin to provide code lenses for type signatures @@ -426,12 +425,16 @@ findBindingsQ = something (mkQ Nothing findBindings) findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe [WhereBinding] findBindingIds bind = case unLoc bind of - FunBind{..} -> Just $ pure $ WhereBinding (unLoc fun_id) (getLoc fun_id) 0 + FunBind{..} -> + let whereBinding = WhereBinding (unLoc fun_id) (getLoc fun_id) + (col (getLoc fun_id) - col (getLoc bind)) + in Just $ pure whereBinding PatBind{..} -> Just $ (everything (<>) $ mkQ [] (fmap (uncurry wb) . maybeToList . findIdFromPat)) pat_lhs where - col = srcSpanStartCol . realSrcSpan wb id srcSpan = WhereBinding id srcSpan (col srcSpan - col (getLoc pat_lhs)) _ -> Nothing + where + col = srcSpanStartCol . realSrcSpan -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ findIdFromPat :: Pat GhcTc -> Maybe (Id, SrcSpan) @@ -460,23 +463,23 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) -- | Note there may multi ids for one binding, -- like @(a, b) = (42, True)@, there are `a` and `b` -- in one binding. - bindingToInlayHints id span offset = case srcSpanToRange span of - Nothing -> pure Nothing - Just range -> do - (_, sig) <- liftIO - $ initTcWithGbl hsc tcGblEnv ghostSpan - $ bindToSig id hsc rdrEnv - pure $ Just $ generateWhereInlayHints range (maybe ("", "") (bimap (T.pack . printName) T.pack) sig) offset - - inlayHints <- catMaybes <$> sequence - [ bindingToInlayHints bindingId bindingLoc offset + bindingToInlayHints id range offset = do + (_, sig) <- liftIO + $ initTcWithGbl hsc tcGblEnv ghostSpan + $ bindToSig id hsc rdrEnv + pure $ generateWhereInlayHints range (maybe ("", "") (bimap (T.pack . printName) T.pack) sig) offset + + inlayHints <- sequence + [ bindingToInlayHints bindingId bindingRange offset | WhereBindings{..} <- localBindings , let sigSpans = getSrcSpan <$> existedSigNames , WhereBinding{..} <- bindings , let bindingSpan = getSrcSpan (idName bindingId) , bindingSpan `notElem` sigSpans + -- , Just bindingRange <- maybeToList $ toCurrentRange pm <$> srcSpanToRange bindingLoc + , Just bindingRange <- [srcSpanToRange bindingLoc] -- Show inlay hints only within visible range - , Just True <- [flip isSubrangeOf visibleRange <$> srcSpanToRange bindingSpan] + , isSubrangeOf bindingRange visibleRange ] pure $ InL inlayHints @@ -498,7 +501,7 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) makeEdit range text offset = let startPos = range ^. L.start -- Subtract the offset to align with the whole binding expression - startPos' = startPos { _character = _character startPos - fromIntegral offset } - insertChar = startPos' ^. L.character + insertChar = _character startPos - fromIntegral offset + startPos' = startPos { _character = insertChar } insertRange = Range startPos' startPos' in TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ") From 228d6696bfd775b33c5f1298c6e9da8eecf96cb2 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 31 Jul 2024 18:19:15 +0800 Subject: [PATCH 06/24] add ghcide InlayHintTests --- ghcide/test/exe/InlayHintTests.hs | 88 +++++++++++++++++++++++++++++++ ghcide/test/exe/Main.hs | 2 + haskell-language-server.cabal | 1 + 3 files changed, 91 insertions(+) create mode 100644 ghcide/test/exe/InlayHintTests.hs diff --git a/ghcide/test/exe/InlayHintTests.hs b/ghcide/test/exe/InlayHintTests.hs new file mode 100644 index 0000000000..3146408149 --- /dev/null +++ b/ghcide/test/exe/InlayHintTests.hs @@ -0,0 +1,88 @@ +module InlayHintTests (tests) where + +import Config (mkIdeTestFs, testWithDummyPlugin, + testWithDummyPluginEmpty) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Aeson as A +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Language.LSP.Protocol.Types (InlayHint (_textEdits), + Position (Position), + Range (Range, _end, _start), + TextDocumentIdentifier (TextDocumentIdentifier), + VersionedTextDocumentIdentifier (_uri)) +import Language.LSP.Test (applyEdit, createDoc, + documentContents, getInlayHints, + openDoc, setConfigSection) +import Test.Hls (Session, expectFail, + waitForTypecheck) +import Test.Hls.FileSystem (copyDir) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=)) + +tests :: TestTree +tests = testGroup "inlay hints" + [ whereInlayHintsTests + ] + +whereInlayHintsTests :: TestTree +whereInlayHintsTests = testGroup "add signature for where clauses" + [ testWithDummyPluginEmpty "No where inlay hints if disabled" $ do + let content = T.unlines + [ "module Sigs where" + , "f :: b" + , "f = undefined" + , " where" + , " g = True" + ] + range = Range { _start = Position 4 0 + , _end = Position 4 1000 + } + doc <- createDoc "Sigs.hs" "haskell" content + setConfigSection "haskell" (createConfig False) + inlayHints <- getInlayHints doc range + liftIO $ length inlayHints @?= 0 + , editTest "Simple" "Simple" + , editTest "Tuple" "Tuple" + , editTest "Inline" "Inline" + , editTest "Infix" "Infix" + , editTest "Operator" "Operator" + , expectFail $ editTest "ScopedTypeVariables" "ScopedTypeVariables" + , editTest "Nest" "Nest" + , editTest "No lens" "NoLens" + , expectFail $ editTest "Typeclass" "Typeclass" + , editTest "Quqlified" "Qualified" + ] + where + createConfig on = + A.object [ "plugin" + A..= A.object [ "ghcide-type-lenses" + A..= A.object [ "config" + A..= A.object [ "whereInlayHintOn" A..= A.Bool on ]]]] + + editTest title file = + testWithDummyPlugin title (mkIdeTestFs [copyDir "local-sig-lens"]) $ do + doc <- openDoc (file ++ ".hs") "haskell" + executeAllHints doc globalRange + real <- documentContents doc + expectedDoc <- openDoc (file ++ ".expected.hs") "haskell" + expected <- documentContents expectedDoc + liftIO $ real @?= expected + + executeAllHints :: TextDocumentIdentifier -> Range -> Session () + executeAllHints doc range = do + void $ waitForTypecheck doc + hints <- getInlayHints doc range + let edits = concat $ mapMaybe _textEdits hints + case edits of + [] -> pure () + edit : _ -> do + newDoc <- applyEdit doc edit + -- pure () + executeAllHints (TextDocumentIdentifier $ _uri newDoc) range + +globalRange :: Range +globalRange = Range { _start = Position 0 0 + , _end = Position 1000 0 + } diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6c8091840d..5f4263f4dc 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,6 +50,7 @@ import HaddockTests import HighlightTests import IfaceTests import InitializeResponseTests +import InlayHintTests import LogType () import NonLspCommandLine import OpenCloseTest @@ -99,4 +100,5 @@ main = do , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests + , InlayHintTests.tests ] diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 24f7c9b8ba..4c3b73a6f7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2180,6 +2180,7 @@ test-suite ghcide-tests THTests UnitTests WatchedFileTests + InlayHintTests -- Tests that have been pulled out of the main file default-extensions: From 52ea29fd729221081fa95e3bc37e24d43f581f78 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Wed, 31 Jul 2024 19:35:49 +0800 Subject: [PATCH 07/24] use liftZonkM in GHC > 9.7.0 --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index b6027e1259..d24ef02e6a 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -325,7 +325,11 @@ rules recorder = do bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) (Name, String) bindToSig id hsc rdrEnv = do - env <- tcInitTidyEnv + env <- +#if MIN_VERSION_ghc(9,7,0) + liftZonkM +#endif + tcInitTidyEnv let name = idName id (_, ty) = tidyOpenType env (idType id) pure (name, showDocRdrEnv hsc rdrEnv (pprSigmaType ty)) From e61663d0f27ed782e855ccc1baaf10ada9667ebb Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Thu, 1 Aug 2024 14:27:04 +0800 Subject: [PATCH 08/24] Fix accidentally broken codeLens --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index d24ef02e6a..4183055ecf 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -106,7 +106,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider - <> mkPluginHandler SMethod_TextDocumentInlayHint whereClauseInlayHints + <> mkPluginHandler SMethod_TextDocumentInlayHint whereClauseInlayHints , pluginCommands = [PluginCommand typeLensCommandId "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -346,8 +346,8 @@ gblBindingType (Just hsc) (Just gblEnv) = do renderBind id = do let name = idName id hasSig name $ do - (_, sig) <- bindToSig id hsc rdrEnv - pure $ GlobalBindingTypeSig name sig (name `elemNameSet` exports) + (name', sig) <- bindToSig id hsc rdrEnv + pure $ GlobalBindingTypeSig name (printName name' <> " :: " <> sig) (name `elemNameSet` exports) patToSig p = do let name = patSynName p hasSig name From 8b6f15ea801d80376818b8c82fa67f2fb98c6f5e Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Thu, 1 Aug 2024 14:29:08 +0800 Subject: [PATCH 09/24] Add Inlay Hints payload test for type lens --- ghcide/test/exe/InlayHintTests.hs | 169 +++++++++++++++++++++++------- 1 file changed, 130 insertions(+), 39 deletions(-) diff --git a/ghcide/test/exe/InlayHintTests.hs b/ghcide/test/exe/InlayHintTests.hs index 3146408149..d78a21f3ea 100644 --- a/ghcide/test/exe/InlayHintTests.hs +++ b/ghcide/test/exe/InlayHintTests.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ExplicitNamespaces #-} + module InlayHintTests (tests) where import Config (mkIdeTestFs, testWithDummyPlugin, @@ -7,19 +9,22 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A import Data.Maybe (mapMaybe) import qualified Data.Text as T -import Language.LSP.Protocol.Types (InlayHint (_textEdits), +import Language.LSP.Protocol.Types (InlayHint (..), Position (Position), Range (Range, _end, _start), TextDocumentIdentifier (TextDocumentIdentifier), - VersionedTextDocumentIdentifier (_uri)) + TextEdit (TextEdit, _newText, _range), + UInt, + VersionedTextDocumentIdentifier (_uri), + type (|?) (..)) import Language.LSP.Test (applyEdit, createDoc, documentContents, getInlayHints, openDoc, setConfigSection) -import Test.Hls (Session, expectFail, +import Test.Hls (Assertion, Session, expectFail, waitForTypecheck) import Test.Hls.FileSystem (copyDir) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit ((@?=)) +import Test.Tasty.HUnit ((@=?), (@?=)) tests :: TestTree tests = testGroup "inlay hints" @@ -43,44 +48,130 @@ whereInlayHintsTests = testGroup "add signature for where clauses" setConfigSection "haskell" (createConfig False) inlayHints <- getInlayHints doc range liftIO $ length inlayHints @?= 0 - , editTest "Simple" "Simple" - , editTest "Tuple" "Tuple" - , editTest "Inline" "Inline" - , editTest "Infix" "Infix" - , editTest "Operator" "Operator" - , expectFail $ editTest "ScopedTypeVariables" "ScopedTypeVariables" - , editTest "Nest" "Nest" - , editTest "No lens" "NoLens" - , expectFail $ editTest "Typeclass" "Typeclass" - , editTest "Quqlified" "Qualified" + , testGroup "apply EditText" + [ editTest "Simple" + , editTest "Tuple" + , editTest "Inline" + , editTest "Infix" + , editTest "Operator" + , expectFail $ editTest "ScopedTypeVariables" + , editTest "Nest" + , editTest "NoLens" + , expectFail $ editTest "Typeclass" + , editTest "Qualified" + ] + , testGroup "apply EditText" + [ hintTest "Simple" $ (@=?) + [defInlayHint { _position = Position 5 9 + , _label = InL ":: Bool" + , _textEdits = Just [mkTextEdit 5 8 "g :: Bool\n "] + }] + , hintTest "Tuple" $ (@=?) + [ defInlayHint { _position = Position 5 10 + , _label = InL ":: Integer" + , _textEdits = Just [mkTextEdit 5 8 "g :: Integer\n "] + } + , defInlayHint { _position = Position 5 13 + , _label = InL ":: Bool" + , _textEdits = Just [mkTextEdit 5 8 "h :: Bool\n "] + } + ] + , hintTest "Inline" $ (@=?) + [defInlayHint { _position = Position 4 11 + , _label = InL ":: Bool" + , _textEdits = Just [mkTextEdit 4 10 "g :: Bool\n "] + }] + , hintTest "Infix" $ (@=?) + [defInlayHint { _position = Position 5 13 + , _label = InL ":: p1 -> p -> p1" + , _textEdits = Just [mkTextEdit 5 8 "g :: p1 -> p -> p1\n "] + }] + , hintTest "Operator" $ (@=?) + [defInlayHint { _position = Position 5 9 + , _label = InL ":: (a -> b) -> a -> b" + , _textEdits = Just [mkTextEdit 5 8 "g :: (a -> b) -> a -> b\n "] + }] + , hintTest "Nest" $ (@=?) + [ defInlayHint { _position = Position 6 9 + , _label = InL ":: Int" + , _textEdits = Just [mkTextEdit 6 8 "h :: Int\n "] + } + , defInlayHint { _position = Position 5 9 + , _label = InL ":: Int" + , _textEdits = Just [mkTextEdit 5 8 "g :: Int\n "] + } + , defInlayHint { _position = Position 6 21 + , _label = InL ":: Int" + , _textEdits = Just [mkTextEdit 6 20 "k :: Int\n "] + } + ] + , hintTest "NoLens" $ (@=?) [] + , hintTest "Qualified" $ (@=?) + [ defInlayHint { _position = Position 7 10 + , _label = InL ":: Map.Map Bool Char" + , _textEdits = Just [mkTextEdit 7 9 "g :: Map.Map Bool Char\n "] + } + ] + ] ] - where - createConfig on = - A.object [ "plugin" - A..= A.object [ "ghcide-type-lenses" - A..= A.object [ "config" - A..= A.object [ "whereInlayHintOn" A..= A.Bool on ]]]] - editTest title file = - testWithDummyPlugin title (mkIdeTestFs [copyDir "local-sig-lens"]) $ do - doc <- openDoc (file ++ ".hs") "haskell" - executeAllHints doc globalRange - real <- documentContents doc - expectedDoc <- openDoc (file ++ ".expected.hs") "haskell" - expected <- documentContents expectedDoc - liftIO $ real @?= expected +editTest :: String -> TestTree +editTest file = + testWithDummyPlugin (file <> " (InlayHint EditText)") (mkIdeTestFs [copyDir "local-sig-lens"]) $ do + doc <- openDoc (file ++ ".hs") "haskell" + executeAllHints doc globalRange + real <- documentContents doc + expectedDoc <- openDoc (file ++ ".expected.hs") "haskell" + expected <- documentContents expectedDoc + liftIO $ real @?= expected + +hintTest :: String -> ([InlayHint] -> Assertion) -> TestTree +hintTest file assert = + testWithDummyPlugin (file <> " (InlayHint)") (mkIdeTestFs [copyDir "local-sig-lens"]) $ do + doc <- openDoc (file ++ ".hs") "haskell" + hints <- getInlayHints doc globalRange + liftIO $ assert hints + + +createConfig :: Bool -> A.Value +createConfig on = + A.object [ "plugin" + A..= A.object [ "ghcide-type-lenses" + A..= A.object [ "config" + A..= A.object [ "whereInlayHintOn" A..= A.Bool on ]]]] + + +executeAllHints :: TextDocumentIdentifier -> Range -> Session () +executeAllHints doc range = do + void $ waitForTypecheck doc + hints <- getInlayHints doc range + let edits = concat $ mapMaybe _textEdits hints + case edits of + [] -> pure () + edit : _ -> do + newDoc <- applyEdit doc edit + executeAllHints (TextDocumentIdentifier $ _uri newDoc) range + +defInlayHint :: InlayHint +defInlayHint = + InlayHint { _position = Position 0 0 + , _label = InL "" + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + } + +mkTextEdit :: UInt -> UInt -> T.Text -> TextEdit +mkTextEdit x y text = + TextEdit { _range = pointRange x y + , _newText = text + } - executeAllHints :: TextDocumentIdentifier -> Range -> Session () - executeAllHints doc range = do - void $ waitForTypecheck doc - hints <- getInlayHints doc range - let edits = concat $ mapMaybe _textEdits hints - case edits of - [] -> pure () - edit : _ -> do - newDoc <- applyEdit doc edit - -- pure () - executeAllHints (TextDocumentIdentifier $ _uri newDoc) range +pointRange :: UInt -> UInt -> Range +pointRange x y = Range (Position x y) (Position x y) globalRange :: Range globalRange = Range { _start = Position 0 0 From e5441874272bac2478e1358515c350e1fd43020d Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Thu, 1 Aug 2024 18:05:34 +0800 Subject: [PATCH 10/24] update testdata schema --- .../schema/ghc94/default-config.golden.json | 6 ++++-- .../ghc94/vscode-extension-schema.golden.json | 16 ++++++++++++++-- .../schema/ghc96/default-config.golden.json | 6 ++++-- .../ghc96/vscode-extension-schema.golden.json | 16 ++++++++++++++-- .../schema/ghc98/default-config.golden.json | 6 ++++-- .../ghc98/vscode-extension-schema.golden.json | 16 ++++++++++++++-- 6 files changed, 54 insertions(+), 12 deletions(-) diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 2612bdba87..d919b4654a 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -79,10 +79,12 @@ "symbolsOn": true }, "ghcide-type-lenses": { + "codeLensOn": true, "config": { - "mode": "always" + "mode": "always", + "whereInlayHintOn": true }, - "globalOn": true + "inlayHintsOn": true }, "hlint": { "codeActionsOn": true, diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 03371d21e7..6babc589f0 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -161,6 +161,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.ghcide-type-lenses.codeLensOn": { + "default": true, + "description": "Enables ghcide-type-lenses code lenses", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -177,9 +183,15 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.globalOn": { + "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { + "default": true, + "markdownDescription": "Enable type lens on instance methods", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.inlayHintsOn": { "default": true, - "description": "Enables ghcide-type-lenses plugin", + "description": "Enables ghcide-type-lenses inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 2612bdba87..d919b4654a 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -79,10 +79,12 @@ "symbolsOn": true }, "ghcide-type-lenses": { + "codeLensOn": true, "config": { - "mode": "always" + "mode": "always", + "whereInlayHintOn": true }, - "globalOn": true + "inlayHintsOn": true }, "hlint": { "codeActionsOn": true, diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 03371d21e7..6babc589f0 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -161,6 +161,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.ghcide-type-lenses.codeLensOn": { + "default": true, + "description": "Enables ghcide-type-lenses code lenses", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -177,9 +183,15 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.globalOn": { + "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { + "default": true, + "markdownDescription": "Enable type lens on instance methods", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.inlayHintsOn": { "default": true, - "description": "Enables ghcide-type-lenses plugin", + "description": "Enables ghcide-type-lenses inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 2612bdba87..d919b4654a 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -79,10 +79,12 @@ "symbolsOn": true }, "ghcide-type-lenses": { + "codeLensOn": true, "config": { - "mode": "always" + "mode": "always", + "whereInlayHintOn": true }, - "globalOn": true + "inlayHintsOn": true }, "hlint": { "codeActionsOn": true, diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 03371d21e7..6babc589f0 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -161,6 +161,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.ghcide-type-lenses.codeLensOn": { + "default": true, + "description": "Enables ghcide-type-lenses code lenses", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -177,9 +183,15 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.globalOn": { + "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { + "default": true, + "markdownDescription": "Enable type lens on instance methods", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.inlayHintsOn": { "default": true, - "description": "Enables ghcide-type-lenses plugin", + "description": "Enables ghcide-type-lenses inlay hints", "scope": "resource", "type": "boolean" }, From 5fa456db6188519b2d4947ba8388233215be1ae2 Mon Sep 17 00:00:00 2001 From: jinser Date: Fri, 16 Aug 2024 21:46:02 +0800 Subject: [PATCH 11/24] Apply suggestions from code review Co-authored-by: fendor --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 4183055ecf..59905ba359 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -50,8 +50,8 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes -import Development.IDE.Types.Location (Position (Position, _character, _line), - Range (Range, _end, _start)) +import Development.IDE.Types.Location (Position (..), + Range (..)) import GHC.Exts (IsString) import GHC.Generics (Generic) import GHC.Hs (realSrcSpan) @@ -378,10 +378,10 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables -- | A binding expression with its id and location. data WhereBinding = WhereBinding { bindingId :: Id - -- ^ Each WhereBinding represents a id in binding expression. + -- ^ Each WhereBinding represents an id in binding expression. , bindingLoc :: SrcSpan - -- ^ Location for a individual binding in a pattern. - -- Here we use the this and offset to render the type signature at the proper place. + -- ^ Location for an individual binding in a pattern. + -- Here we use the 'bindingLoc' and offset to render the type signature at the proper place. , offset :: Int -- ^ Column offset between whole binding and individual binding in a pattern. -- @@ -390,10 +390,10 @@ data WhereBinding = WhereBinding -- - `b`: WhereBinding id_b loc_b 4 } --- | Existed bindings in a where clause. +-- | Existing bindings in a where clause. data WhereBindings = WhereBindings { bindings :: [WhereBinding] - , existedSigNames :: [Name] + , existingSigNames :: [Name] -- ^ Names of existing signatures. -- It is used to hide type lens for existing signatures. -- From 561d08281e1b6a6331083bd6312543f187ec3c90 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 17 Aug 2024 17:23:19 +0800 Subject: [PATCH 12/24] refactor: bindToSig just return signature string --- .../src/Development/IDE/Plugin/TypeLenses.hs | 25 ++++++++++--------- 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 59905ba359..8faebac732 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -16,8 +16,7 @@ module Development.IDE.Plugin.TypeLenses ( import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) -import Control.Lens (Bifunctor (bimap), (?~), - (^.)) +import Control.Lens ((?~), (^.)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -268,7 +267,7 @@ data Mode Always | -- | similar to 'Always', but only displays for exported global bindings Exported - | -- | follows error messages produced by GHC + | -- | follows error messages produced by GHC Diagnostics deriving (Eq, Ord, Show, Read, Enum) @@ -323,16 +322,16 @@ rules recorder = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) -bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) (Name, String) +-- | Converts a given haskell bind to its corresponding type signature. +bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) String bindToSig id hsc rdrEnv = do env <- #if MIN_VERSION_ghc(9,7,0) liftZonkM #endif tcInitTidyEnv - let name = idName id - (_, ty) = tidyOpenType env (idType id) - pure (name, showDocRdrEnv hsc rdrEnv (pprSigmaType ty)) + let (_, ty) = tidyOpenType env (idType id) + pure (showDocRdrEnv hsc rdrEnv (pprSigmaType ty)) gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) gblBindingType (Just hsc) (Just gblEnv) = do @@ -346,8 +345,9 @@ gblBindingType (Just hsc) (Just gblEnv) = do renderBind id = do let name = idName id hasSig name $ do - (name', sig) <- bindToSig id hsc rdrEnv - pure $ GlobalBindingTypeSig name (printName name' <> " :: " <> sig) (name `elemNameSet` exports) + -- convert from bind id to its signature + sig <- bindToSig id hsc rdrEnv + pure $ GlobalBindingTypeSig name (printName name <> " :: " <> sig) (name `elemNameSet` exports) patToSig p = do let name = patSynName p hasSig name @@ -471,7 +471,8 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) (_, sig) <- liftIO $ initTcWithGbl hsc tcGblEnv ghostSpan $ bindToSig id hsc rdrEnv - pure $ generateWhereInlayHints range (maybe ("", "") (bimap (T.pack . printName) T.pack) sig) offset + let name = idName id + pure $ generateWhereInlayHints range (T.pack $ printName name) (maybe "_" T.pack sig) offset inlayHints <- sequence [ bindingToInlayHints bindingId bindingRange offset @@ -488,8 +489,8 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) pure $ InL inlayHints where - generateWhereInlayHints :: Range -> (T.Text, T.Text) -> Int -> InlayHint - generateWhereInlayHints range (name, ty) offset = + generateWhereInlayHints :: Range -> T.Text -> T.Text -> Int -> InlayHint + generateWhereInlayHints range name ty offset = let edit = makeEdit range (name <> " :: " <> ty) offset in InlayHint { _textEdits = Just [edit] , _paddingRight = Nothing From b22666191ff38ace4845ab9f323278176b26354f Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 17 Aug 2024 18:04:39 +0800 Subject: [PATCH 13/24] fix: renamed existingSigNames --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 8faebac732..a861c390ae 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -392,7 +392,7 @@ data WhereBinding = WhereBinding -- | Existing bindings in a where clause. data WhereBindings = WhereBindings - { bindings :: [WhereBinding] + { bindings :: [WhereBinding] , existingSigNames :: [Name] -- ^ Names of existing signatures. -- It is used to hide type lens for existing signatures. @@ -424,7 +424,7 @@ findBindingsQ = something (mkQ Nothing findBindings) findBindings (NValBinds binds sigs) = Just $ WhereBindings { bindings = concat $ mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds - , existedSigNames = concatMap findSigIds sigs + , existingSigNames = concatMap findSigIds sigs } findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe [WhereBinding] @@ -477,7 +477,7 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) inlayHints <- sequence [ bindingToInlayHints bindingId bindingRange offset | WhereBindings{..} <- localBindings - , let sigSpans = getSrcSpan <$> existedSigNames + , let sigSpans = getSrcSpan <$> existingSigNames , WhereBinding{..} <- bindings , let bindingSpan = getSrcSpan (idName bindingId) , bindingSpan `notElem` sigSpans From 837ee451f3a737218081033683ef92f49902d702 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 17 Aug 2024 18:10:44 +0800 Subject: [PATCH 14/24] chore: correct schema property `whereInlayHintOn` --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 2 +- test/testdata/schema/ghc94/vscode-extension-schema.golden.json | 2 +- test/testdata/schema/ghc96/vscode-extension-schema.golden.json | 2 +- test/testdata/schema/ghc98/vscode-extension-schema.golden.json | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index a861c390ae..ad56e91ef1 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -123,7 +123,7 @@ properties = emptyProperties , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always & defineBooleanProperty #whereInlayHintOn - "Enable type lens on instance methods" + "Display type lenses of where bindings" True codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 6babc589f0..d1ee27a4c8 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -185,7 +185,7 @@ }, "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { "default": true, - "markdownDescription": "Enable type lens on instance methods", + "markdownDescription": "Display type lenses of where bindings", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 6babc589f0..d1ee27a4c8 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -185,7 +185,7 @@ }, "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { "default": true, - "markdownDescription": "Enable type lens on instance methods", + "markdownDescription": "Display type lenses of where bindings", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 6babc589f0..d1ee27a4c8 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -185,7 +185,7 @@ }, "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { "default": true, - "markdownDescription": "Enable type lens on instance methods", + "markdownDescription": "Display type lenses of where bindings", "scope": "resource", "type": "boolean" }, From 96417e07407c9031ad6f9c36011f6d55f057a99a Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sat, 17 Aug 2024 18:15:17 +0800 Subject: [PATCH 15/24] fix: typo --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index ad56e91ef1..3673a659b6 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -322,7 +322,7 @@ rules recorder = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) --- | Converts a given haskell bind to its corresponding type signature. +-- | Convert a given haskell bind to its corresponding type signature. bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) String bindToSig id hsc rdrEnv = do env <- From 20e127488ce1a5e5d6bfb3f9fe279235c3bba797 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Sun, 18 Aug 2024 17:59:26 +0800 Subject: [PATCH 16/24] refactor: rewrite where bindings sig as Rules --- .../src/Development/IDE/Plugin/TypeLenses.hs | 102 +++++++++++------- 1 file changed, 63 insertions(+), 39 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 3673a659b6..2871d5bb12 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -27,8 +27,8 @@ import Data.Generics (GenericQ, everything, mkQ, something) import Data.List (find) import qualified Data.Map as Map -import Data.Maybe (catMaybes, mapMaybe, - maybeToList) +import Data.Maybe (catMaybes, fromMaybe, + mapMaybe, maybeToList) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), @@ -107,7 +107,7 @@ descriptor recorder plId = <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider <> mkPluginHandler SMethod_TextDocumentInlayHint whereClauseInlayHints , pluginCommands = [PluginCommand typeLensCommandId "adds a signature" commandHandler] - , pluginRules = rules recorder + , pluginRules = globalBindingRules recorder *> whereBindingRules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } where @@ -306,15 +306,15 @@ gbSrcSpan GlobalBindingTypeSig{gbName} = getSrcSpan gbName newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig] instance Show GlobalBindingTypeSigsResult where - show _ = "" + show _ = "" instance NFData GlobalBindingTypeSigsResult where rnf = rwhnf type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult -rules :: Recorder (WithPriority Log) -> Rules () -rules recorder = do +globalBindingRules :: Recorder (WithPriority Log) -> Rules () +globalBindingRules recorder = do define (cmapWithPrio LogShake recorder) $ \GetGlobalBindingTypeSigs nfp -> do tmr <- use TypeCheck nfp -- we need session here for tidying types @@ -323,8 +323,8 @@ rules recorder = do pure ([], result) -- | Convert a given haskell bind to its corresponding type signature. -bindToSig :: Id -> HscEnv -> GlobalRdrEnv -> IOEnv (Env TcGblEnv TcLclEnv) String -bindToSig id hsc rdrEnv = do +bindToSig :: HscEnv -> GlobalRdrEnv -> Id -> IOEnv (Env TcGblEnv TcLclEnv) String +bindToSig hsc rdrEnv id = do env <- #if MIN_VERSION_ghc(9,7,0) liftZonkM @@ -346,7 +346,7 @@ gblBindingType (Just hsc) (Just gblEnv) = do let name = idName id hasSig name $ do -- convert from bind id to its signature - sig <- bindToSig id hsc rdrEnv + sig <- bindToSig hsc rdrEnv id pure $ GlobalBindingTypeSig name (printName name <> " :: " <> sig) (name `elemNameSet` exports) patToSig p = do let name = patSynName p @@ -409,6 +409,42 @@ data WhereBindings = WhereBindings -- the definition of `f`(second line). } +data GetWhereBindingTypeSigs = GetWhereBindingTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData) + +type BindingSigMap = Map.Map Id String + +newtype WhereBindingTypeSigsResult = WhereBindingTypeSigsResult ([WhereBindings], BindingSigMap) + +instance Show WhereBindingTypeSigsResult where + show _ = "" + +instance NFData WhereBindingTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetWhereBindingTypeSigs = WhereBindingTypeSigsResult + +whereBindingRules :: Recorder (WithPriority Log) -> Rules () +whereBindingRules recorder = do + define (cmapWithPrio LogShake recorder) $ \GetWhereBindingTypeSigs nfp -> do + tmr <- use TypeCheck nfp + -- we need session here for tidying types + hsc <- use GhcSession nfp + result <- liftIO $ whereBindingType (tmrTypechecked <$> tmr) (hscEnv <$> hsc) + pure ([], result) + +whereBindingType :: Maybe TcGblEnv -> Maybe HscEnv -> IO (Maybe WhereBindingTypeSigsResult) +whereBindingType (Just gblEnv) (Just hsc) = do + let wheres = findWhereQ (tcg_binds gblEnv) + localBindings = mapMaybe findBindingsQ wheres + bindToSig' = bindToSig hsc (tcg_rdr_env gblEnv) + findSigs (WhereBindings bindings _) = fmap findSig bindings + where findSig (WhereBinding bindingId _ _) = sequence (bindingId, bindToSig' bindingId) + (_, Map.fromList . fromMaybe [] -> sigMap) <- + initTcWithGbl hsc gblEnv ghostSpan $ sequence $ concatMap findSigs localBindings + pure $ Just (WhereBindingTypeSigsResult (localBindings, sigMap)) +whereBindingType _ _ = pure Nothing + -- | All where clauses from type checked source. findWhereQ :: GenericQ [HsLocalBinds GhcTc] findWhereQ = everything (<>) $ mkQ [] (pure . findWhere) @@ -455,42 +491,30 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) enabled <- liftIO $ runAction "inlayHint.config" state $ usePropertyAction #whereInlayHintOn plId properties if not enabled then pure $ InL [] else do nfp <- getNormalizedFilePathE uri - (tmr, _) <- runActionE "inlayHint.local.TypeCheck" state $ useWithStaleE TypeCheck nfp - (hscEnv -> hsc, _) <- runActionE "InlayHint.local.GhcSession" state $ useWithStaleE GhcSession nfp - let tcGblEnv = tmrTypechecked tmr - rdrEnv = tcg_rdr_env tcGblEnv - typeCheckedSource = tcg_binds tcGblEnv - - wheres = findWhereQ typeCheckedSource - localBindings = mapMaybe findBindingsQ wheres + (WhereBindingTypeSigsResult (localBindings, sigMap), pm) + <- runActionE "InlayHint.GetWhereBindingTypeSigs" state $ useWithStaleE GetWhereBindingTypeSigs nfp + let bindingToInlayHints id sig = generateWhereInlayHints (T.pack $ printName (idName id)) (maybe "_" T.pack sig) -- | Note there may multi ids for one binding, -- like @(a, b) = (42, True)@, there are `a` and `b` -- in one binding. - bindingToInlayHints id range offset = do - (_, sig) <- liftIO - $ initTcWithGbl hsc tcGblEnv ghostSpan - $ bindToSig id hsc rdrEnv - let name = idName id - pure $ generateWhereInlayHints range (T.pack $ printName name) (maybe "_" T.pack sig) offset - - inlayHints <- sequence - [ bindingToInlayHints bindingId bindingRange offset - | WhereBindings{..} <- localBindings - , let sigSpans = getSrcSpan <$> existingSigNames - , WhereBinding{..} <- bindings - , let bindingSpan = getSrcSpan (idName bindingId) - , bindingSpan `notElem` sigSpans - -- , Just bindingRange <- maybeToList $ toCurrentRange pm <$> srcSpanToRange bindingLoc - , Just bindingRange <- [srcSpanToRange bindingLoc] - -- Show inlay hints only within visible range - , isSubrangeOf bindingRange visibleRange - ] - + inlayHints = + [ bindingToInlayHints bindingId bindingSig bindingRange offset + | WhereBindings{..} <- localBindings + , let sigSpans = getSrcSpan <$> existingSigNames + , WhereBinding{..} <- bindings + , let bindingSpan = getSrcSpan (idName bindingId) + , let bindingSig = Map.lookup bindingId sigMap + , bindingSpan `notElem` sigSpans + , Just bindingRange <- maybeToList $ toCurrentRange pm <$> srcSpanToRange bindingLoc + -- , Just bindingRange <- [srcSpanToRange bindingLoc] + -- Show inlay hints only within visible range + , isSubrangeOf bindingRange visibleRange + ] pure $ InL inlayHints where - generateWhereInlayHints :: Range -> T.Text -> T.Text -> Int -> InlayHint - generateWhereInlayHints range name ty offset = + generateWhereInlayHints :: T.Text -> T.Text -> Range -> Int -> InlayHint + generateWhereInlayHints name ty range offset = let edit = makeEdit range (name <> " :: " <> ty) offset in InlayHint { _textEdits = Just [edit] , _paddingRight = Nothing From efc434b5c8c505bcc2b8af8159bd4b7d56e2501c Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 01:08:43 +0800 Subject: [PATCH 17/24] feat: show local binding instead of just where clause Now let and where clause will show binding type in inlay hints --- .../src/Development/IDE/Plugin/TypeLenses.hs | 120 ++++++++++-------- .../schema/ghc94/default-config.golden.json | 4 +- .../ghc94/vscode-extension-schema.golden.json | 12 +- .../schema/ghc96/default-config.golden.json | 4 +- .../ghc96/vscode-extension-schema.golden.json | 12 +- .../schema/ghc98/default-config.golden.json | 4 +- .../ghc98/vscode-extension-schema.golden.json | 12 +- 7 files changed, 91 insertions(+), 77 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 2871d5bb12..14cdcad55e 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -24,7 +24,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Aeson.Types (toJSON) import qualified Data.Aeson.Types as A import Data.Generics (GenericQ, everything, - mkQ, something) + extQ, mkQ, something) import Data.List (find) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, @@ -105,16 +105,16 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider - <> mkPluginHandler SMethod_TextDocumentInlayHint whereClauseInlayHints + <> mkPluginHandler SMethod_TextDocumentInlayHint localBindingInlayHints , pluginCommands = [PluginCommand typeLensCommandId "adds a signature" commandHandler] - , pluginRules = globalBindingRules recorder *> whereBindingRules recorder + , pluginRules = globalBindingRules recorder *> localBindingRules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } where desc = "Provides code lenses type signatures" properties :: Properties - '[ 'PropertyKey "whereInlayHintOn" 'TBoolean, + '[ 'PropertyKey "localBindingInlayHintOn" 'TBoolean, 'PropertyKey "mode" ('TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" @@ -122,8 +122,8 @@ properties = emptyProperties , (Exported, "Only display type lenses of exported global bindings") , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always - & defineBooleanProperty #whereInlayHintOn - "Display type lenses of where bindings" + & defineBooleanProperty #localBindingInlayHintOn + "Display type lenses of local bindings" True codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens @@ -376,23 +376,23 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables -- -------------------------------------------------------------------------------- -- | A binding expression with its id and location. -data WhereBinding = WhereBinding +data LocalBinding = LocalBinding { bindingId :: Id - -- ^ Each WhereBinding represents an id in binding expression. + -- ^ Each LocalBinding represents an id in binding expression. , bindingLoc :: SrcSpan -- ^ Location for an individual binding in a pattern. -- Here we use the 'bindingLoc' and offset to render the type signature at the proper place. , offset :: Int -- ^ Column offset between whole binding and individual binding in a pattern. -- - -- Example: For @(a, b) = (1, True)@, there will be two `WhereBinding`s: - -- - `a`: WhereBinding id_a loc_a 0 - -- - `b`: WhereBinding id_b loc_b 4 + -- Example: For @(a, b) = (1, True)@, there will be two `LocalBinding`s: + -- - `a`: LocalBinding id_a loc_a 0 + -- - `b`: LocalBinding id_b loc_b 4 } --- | Existing bindings in a where clause. -data WhereBindings = WhereBindings - { bindings :: [WhereBinding] +-- | Existing local bindings +data LocalBindings = LocalBindings + { bindings :: [LocalBinding] , existingSigNames :: [Name] -- ^ Names of existing signatures. -- It is used to hide type lens for existing signatures. @@ -409,69 +409,84 @@ data WhereBindings = WhereBindings -- the definition of `f`(second line). } -data GetWhereBindingTypeSigs = GetWhereBindingTypeSigs +data GetLocalBindingTypeSigs = GetLocalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData) type BindingSigMap = Map.Map Id String -newtype WhereBindingTypeSigsResult = WhereBindingTypeSigsResult ([WhereBindings], BindingSigMap) +newtype LocalBindingTypeSigsResult = LocalBindingTypeSigsResult ([LocalBindings], BindingSigMap) -instance Show WhereBindingTypeSigsResult where - show _ = "" +instance Show LocalBindingTypeSigsResult where + show _ = "" -instance NFData WhereBindingTypeSigsResult where +instance NFData LocalBindingTypeSigsResult where rnf = rwhnf -type instance RuleResult GetWhereBindingTypeSigs = WhereBindingTypeSigsResult +type instance RuleResult GetLocalBindingTypeSigs = LocalBindingTypeSigsResult -whereBindingRules :: Recorder (WithPriority Log) -> Rules () -whereBindingRules recorder = do - define (cmapWithPrio LogShake recorder) $ \GetWhereBindingTypeSigs nfp -> do +localBindingRules :: Recorder (WithPriority Log) -> Rules () +localBindingRules recorder = do + define (cmapWithPrio LogShake recorder) $ \GetLocalBindingTypeSigs nfp -> do tmr <- use TypeCheck nfp -- we need session here for tidying types hsc <- use GhcSession nfp - result <- liftIO $ whereBindingType (tmrTypechecked <$> tmr) (hscEnv <$> hsc) + result <- liftIO $ localBindingType (tmrTypechecked <$> tmr) (hscEnv <$> hsc) pure ([], result) -whereBindingType :: Maybe TcGblEnv -> Maybe HscEnv -> IO (Maybe WhereBindingTypeSigsResult) -whereBindingType (Just gblEnv) (Just hsc) = do - let wheres = findWhereQ (tcg_binds gblEnv) - localBindings = mapMaybe findBindingsQ wheres +localBindingType :: Maybe TcGblEnv -> Maybe HscEnv -> IO (Maybe LocalBindingTypeSigsResult) +localBindingType (Just gblEnv) (Just hsc) = do + let locals = findLocalQ (tcg_binds gblEnv) + localBindings = mapMaybe findBindingsQ locals bindToSig' = bindToSig hsc (tcg_rdr_env gblEnv) - findSigs (WhereBindings bindings _) = fmap findSig bindings - where findSig (WhereBinding bindingId _ _) = sequence (bindingId, bindToSig' bindingId) + findSigs (LocalBindings bindings _) = fmap findSig bindings + where findSig (LocalBinding bindingId _ _) = sequence (bindingId, bindToSig' bindingId) (_, Map.fromList . fromMaybe [] -> sigMap) <- initTcWithGbl hsc gblEnv ghostSpan $ sequence $ concatMap findSigs localBindings - pure $ Just (WhereBindingTypeSigsResult (localBindings, sigMap)) -whereBindingType _ _ = pure Nothing + pure $ Just (LocalBindingTypeSigsResult (localBindings, sigMap)) +localBindingType _ _ = pure Nothing --- | All where clauses from type checked source. -findWhereQ :: GenericQ [HsLocalBinds GhcTc] -findWhereQ = everything (<>) $ mkQ [] (pure . findWhere) +-- | All local bind expression from type checked source. +findLocalQ :: GenericQ [HsLocalBinds GhcTc] +findLocalQ = everything (<>) ([] `mkQ` (pure . findWhere) `extQ` findLet) where findWhere :: GRHSs GhcTc (LHsExpr GhcTc) -> HsLocalBinds GhcTc findWhere = grhssLocalBinds --- | Find all bindings for **one** where clause. -findBindingsQ :: GenericQ (Maybe WhereBindings) + findLet :: LHsExpr GhcTc -> [HsLocalBinds GhcTc] + findLet = findLetExpr . unLoc + + findLetExpr :: HsExpr GhcTc -> [HsLocalBinds GhcTc] + findLetExpr (HsLet _ _ binds _ _) = [binds] + findLetExpr (HsDo _ _ (unLoc -> stmts)) = concatMap (findLetStmt . unLoc) stmts + findLetExpr _ = [] + + findLetStmt :: ExprStmt GhcTc -> [HsLocalBinds GhcTc] + findLetStmt (LetStmt _ binds) = [binds] + -- TODO(jinser): why `foo <- expr` does not exist + -- findLetStmt (BindStmt _ _ expr) = findLetExpr (unLoc expr) + findLetStmt _ = [] + +-- | Find all bindings for **one** local bind expression. +findBindingsQ :: GenericQ (Maybe LocalBindings) findBindingsQ = something (mkQ Nothing findBindings) where - findBindings :: NHsValBindsLR GhcTc -> Maybe WhereBindings + findBindings :: NHsValBindsLR GhcTc -> Maybe LocalBindings findBindings (NValBinds binds sigs) = - Just $ WhereBindings + Just $ LocalBindings { bindings = concat $ mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds , existingSigNames = concatMap findSigIds sigs } - findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe [WhereBinding] + findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe [LocalBinding] findBindingIds bind = case unLoc bind of FunBind{..} -> - let whereBinding = WhereBinding (unLoc fun_id) (getLoc fun_id) + let localBinding = LocalBinding (unLoc fun_id) (getLoc fun_id) (col (getLoc fun_id) - col (getLoc bind)) - in Just $ pure whereBinding - PatBind{..} -> Just $ (everything (<>) $ mkQ [] (fmap (uncurry wb) . maybeToList . findIdFromPat)) pat_lhs + in Just $ pure localBinding + PatBind{..} -> + Just $ (everything (<>) $ mkQ [] (fmap (uncurry wb) . maybeToList . findIdFromPat)) pat_lhs where - wb id srcSpan = WhereBinding id srcSpan (col srcSpan - col (getLoc pat_lhs)) + wb id srcSpan = LocalBinding id srcSpan (col srcSpan - col (getLoc pat_lhs)) _ -> Nothing where col = srcSpanStartCol . realSrcSpan @@ -485,14 +500,14 @@ findBindingsQ = something (mkQ Nothing findBindings) findSigIds (L _ (TypeSig _ names _)) = map unLoc names findSigIds _ = [] --- | Provide code lens for where bindings. -whereClauseInlayHints :: PluginMethodHandler IdeState Method_TextDocumentInlayHint -whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) visibleRange) = do - enabled <- liftIO $ runAction "inlayHint.config" state $ usePropertyAction #whereInlayHintOn plId properties +-- | Provide code lens for local bindings. +localBindingInlayHints :: PluginMethodHandler IdeState Method_TextDocumentInlayHint +localBindingInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) visibleRange) = do + enabled <- liftIO $ runAction "inlayHint.config" state $ usePropertyAction #localBindingInlayHintOn plId properties if not enabled then pure $ InL [] else do nfp <- getNormalizedFilePathE uri - (WhereBindingTypeSigsResult (localBindings, sigMap), pm) - <- runActionE "InlayHint.GetWhereBindingTypeSigs" state $ useWithStaleE GetWhereBindingTypeSigs nfp + (LocalBindingTypeSigsResult (localBindings, sigMap), pm) + <- runActionE "InlayHint.GetWhereBindingTypeSigs" state $ useWithStaleE GetLocalBindingTypeSigs nfp let bindingToInlayHints id sig = generateWhereInlayHints (T.pack $ printName (idName id)) (maybe "_" T.pack sig) -- | Note there may multi ids for one binding, @@ -500,14 +515,13 @@ whereClauseInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri) -- in one binding. inlayHints = [ bindingToInlayHints bindingId bindingSig bindingRange offset - | WhereBindings{..} <- localBindings + | LocalBindings{..} <- localBindings , let sigSpans = getSrcSpan <$> existingSigNames - , WhereBinding{..} <- bindings + , LocalBinding{..} <- bindings , let bindingSpan = getSrcSpan (idName bindingId) , let bindingSig = Map.lookup bindingId sigMap , bindingSpan `notElem` sigSpans , Just bindingRange <- maybeToList $ toCurrentRange pm <$> srcSpanToRange bindingLoc - -- , Just bindingRange <- [srcSpanToRange bindingLoc] -- Show inlay hints only within visible range , isSubrangeOf bindingRange visibleRange ] diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index afe5691165..96618b550d 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -85,8 +85,8 @@ "ghcide-type-lenses": { "codeLensOn": true, "config": { - "mode": "always", - "whereInlayHintOn": true + "localBindingInlayHintOn": true, + "mode": "always" }, "inlayHintsOn": true }, diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index d714e54a57..6207cddbdd 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -179,6 +179,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.ghcide-type-lenses.config.localBindingInlayHintOn": { + "default": true, + "markdownDescription": "Display type lenses of local bindings", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -195,12 +201,6 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { - "default": true, - "markdownDescription": "Display type lenses of where bindings", - "scope": "resource", - "type": "boolean" - }, "haskell.plugin.ghcide-type-lenses.inlayHintsOn": { "default": true, "description": "Enables ghcide-type-lenses inlay hints", diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index afe5691165..96618b550d 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -85,8 +85,8 @@ "ghcide-type-lenses": { "codeLensOn": true, "config": { - "mode": "always", - "whereInlayHintOn": true + "localBindingInlayHintOn": true, + "mode": "always" }, "inlayHintsOn": true }, diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index d714e54a57..6207cddbdd 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -179,6 +179,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.ghcide-type-lenses.config.localBindingInlayHintOn": { + "default": true, + "markdownDescription": "Display type lenses of local bindings", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -195,12 +201,6 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { - "default": true, - "markdownDescription": "Display type lenses of where bindings", - "scope": "resource", - "type": "boolean" - }, "haskell.plugin.ghcide-type-lenses.inlayHintsOn": { "default": true, "description": "Enables ghcide-type-lenses inlay hints", diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index afe5691165..96618b550d 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -85,8 +85,8 @@ "ghcide-type-lenses": { "codeLensOn": true, "config": { - "mode": "always", - "whereInlayHintOn": true + "localBindingInlayHintOn": true, + "mode": "always" }, "inlayHintsOn": true }, diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index d714e54a57..6207cddbdd 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -179,6 +179,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.ghcide-type-lenses.config.localBindingInlayHintOn": { + "default": true, + "markdownDescription": "Display type lenses of local bindings", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -195,12 +201,6 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.config.whereInlayHintOn": { - "default": true, - "markdownDescription": "Display type lenses of where bindings", - "scope": "resource", - "type": "boolean" - }, "haskell.plugin.ghcide-type-lenses.inlayHintsOn": { "default": true, "description": "Enables ghcide-type-lenses inlay hints", From d065a0adaec813dc0424543a9d35e7dedd139640 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 01:19:40 +0800 Subject: [PATCH 18/24] refactor: correct comment location --- .../src/Development/IDE/Plugin/TypeLenses.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 14cdcad55e..666d109ce0 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -484,18 +484,20 @@ findBindingsQ = something (mkQ Nothing findBindings) (col (getLoc fun_id) - col (getLoc bind)) in Just $ pure localBinding PatBind{..} -> - Just $ (everything (<>) $ mkQ [] (fmap (uncurry wb) . maybeToList . findIdFromPat)) pat_lhs - where - wb id srcSpan = LocalBinding id srcSpan (col srcSpan - col (getLoc pat_lhs)) + let wb id srcSpan = LocalBinding id srcSpan (col srcSpan - col (getLoc pat_lhs)) + + -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ + findIdFromPat :: Pat GhcTc -> Maybe (Id, SrcSpan) + findIdFromPat (VarPat _ located) = Just (unLoc located, getLoc located) + findIdFromPat _ = Nothing + + findIdsFromPat :: LocatedA (Pat GhcTc) -> [LocalBinding] + findIdsFromPat = everything (<>) $ mkQ [] (fmap (uncurry wb) . maybeToList . findIdFromPat) + in Just $ findIdsFromPat pat_lhs _ -> Nothing where col = srcSpanStartCol . realSrcSpan - -- | Example: Find `a` and `b` from @(a,b) = (1,True)@ - findIdFromPat :: Pat GhcTc -> Maybe (Id, SrcSpan) - findIdFromPat (VarPat _ located) = Just (unLoc located, getLoc located) - findIdFromPat _ = Nothing - findSigIds :: GenLocated l (Sig GhcRn) -> [IdP GhcRn] findSigIds (L _ (TypeSig _ names _)) = map unLoc names findSigIds _ = [] From 2d221d8dbba6ac820aca5529eb17c11e2a4d3893 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 01:35:23 +0800 Subject: [PATCH 19/24] ignore things that don't have signatures --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 666d109ce0..afd0f2685b 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -510,12 +510,15 @@ localBindingInlayHints state plId (InlayHintParams _ (TextDocumentIdentifier uri nfp <- getNormalizedFilePathE uri (LocalBindingTypeSigsResult (localBindings, sigMap), pm) <- runActionE "InlayHint.GetWhereBindingTypeSigs" state $ useWithStaleE GetLocalBindingTypeSigs nfp - let bindingToInlayHints id sig = generateWhereInlayHints (T.pack $ printName (idName id)) (maybe "_" T.pack sig) + let bindingToInlayHints :: Id -> Maybe String -> Range -> Int -> Maybe InlayHint + bindingToInlayHints id (Just sig) range offset = + Just $ generateWhereInlayHints (T.pack $ printName (idName id)) (T.pack sig) range offset + bindingToInlayHints _ Nothing _ _ = Nothing -- | Note there may multi ids for one binding, -- like @(a, b) = (42, True)@, there are `a` and `b` -- in one binding. - inlayHints = + inlayHints = catMaybes [ bindingToInlayHints bindingId bindingSig bindingRange offset | LocalBindings{..} <- localBindings , let sigSpans = getSrcSpan <$> existingSigNames From 953db22f83251740975200b4c7c48bb1090bff22 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 02:54:24 +0800 Subject: [PATCH 20/24] refactor --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index afd0f2685b..da111d0f81 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -498,9 +498,9 @@ findBindingsQ = something (mkQ Nothing findBindings) where col = srcSpanStartCol . realSrcSpan - findSigIds :: GenLocated l (Sig GhcRn) -> [IdP GhcRn] - findSigIds (L _ (TypeSig _ names _)) = map unLoc names - findSigIds _ = [] + findSigIds :: LSig GhcRn -> [Name] + findSigIds (unLoc -> (TypeSig _ names _)) = map unLoc names + findSigIds _ = [] -- | Provide code lens for local bindings. localBindingInlayHints :: PluginMethodHandler IdeState Method_TextDocumentInlayHint From 0df54d2dac514ccf90618774947bf2709fa84233 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 03:00:20 +0800 Subject: [PATCH 21/24] update local-binding inlayHints config desc --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 2 +- test/testdata/schema/ghc94/vscode-extension-schema.golden.json | 2 +- test/testdata/schema/ghc96/vscode-extension-schema.golden.json | 2 +- test/testdata/schema/ghc98/vscode-extension-schema.golden.json | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index da111d0f81..bcfe081236 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -123,7 +123,7 @@ properties = emptyProperties , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always & defineBooleanProperty #localBindingInlayHintOn - "Display type lenses of local bindings" + "Display inlay hints of local bindings" True codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 6207cddbdd..77e52bb464 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -181,7 +181,7 @@ }, "haskell.plugin.ghcide-type-lenses.config.localBindingInlayHintOn": { "default": true, - "markdownDescription": "Display type lenses of local bindings", + "markdownDescription": "Display inlay hints of local bindings", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 6207cddbdd..77e52bb464 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -181,7 +181,7 @@ }, "haskell.plugin.ghcide-type-lenses.config.localBindingInlayHintOn": { "default": true, - "markdownDescription": "Display type lenses of local bindings", + "markdownDescription": "Display inlay hints of local bindings", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 6207cddbdd..77e52bb464 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -181,7 +181,7 @@ }, "haskell.plugin.ghcide-type-lenses.config.localBindingInlayHintOn": { "default": true, - "markdownDescription": "Display type lenses of local bindings", + "markdownDescription": "Display inlay hints of local bindings", "scope": "resource", "type": "boolean" }, From 59d56bc563ab3b0545ed1b366e328e1849fddffd Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 03:05:49 +0800 Subject: [PATCH 22/24] update TypeLenses plugin desc --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index bcfe081236..c32d5e280b 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -111,7 +111,7 @@ descriptor recorder plId = , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } where - desc = "Provides code lenses type signatures" + desc = "Provides type signatures through code lenses and inlay hints" properties :: Properties '[ 'PropertyKey "localBindingInlayHintOn" 'TBoolean, From 0e69f465eace23e86fa3af353bf90c4067054f21 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 03:11:41 +0800 Subject: [PATCH 23/24] update TypeLenses test/data dirname --- .../Infix.expected.hs | 0 .../data/{local-sig-lens => local-sig-inlay-hints}/Infix.hs | 0 .../Inline.expected.hs | 0 .../{local-sig-lens => local-sig-inlay-hints}/Inline.hs | 0 .../Nest.expected.hs | 0 .../data/{local-sig-lens => local-sig-inlay-hints}/Nest.hs | 0 .../NoLens.expected.hs | 0 .../{local-sig-lens => local-sig-inlay-hints}/NoLens.hs | 0 .../Operator.expected.hs | 0 .../{local-sig-lens => local-sig-inlay-hints}/Operator.hs | 0 .../Qualified.expected.hs | 0 .../{local-sig-lens => local-sig-inlay-hints}/Qualified.hs | 0 .../ScopedTypeVariables.expected.hs | 0 .../ScopedTypeVariables.hs | 0 .../Simple.expected.hs | 0 .../{local-sig-lens => local-sig-inlay-hints}/Simple.hs | 0 .../Tuple.expected.hs | 0 .../data/{local-sig-lens => local-sig-inlay-hints}/Tuple.hs | 0 .../Typeclass.expected.hs | 0 .../{local-sig-lens => local-sig-inlay-hints}/Typeclass.hs | 0 ghcide/test/exe/InlayHintTests.hs | 6 +++--- 21 files changed, 3 insertions(+), 3 deletions(-) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Infix.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Infix.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Inline.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Inline.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Nest.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Nest.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/NoLens.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/NoLens.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Operator.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Operator.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Qualified.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Qualified.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/ScopedTypeVariables.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/ScopedTypeVariables.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Simple.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Simple.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Tuple.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Tuple.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Typeclass.expected.hs (100%) rename ghcide/test/data/{local-sig-lens => local-sig-inlay-hints}/Typeclass.hs (100%) diff --git a/ghcide/test/data/local-sig-lens/Infix.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Infix.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Infix.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Infix.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Infix.hs b/ghcide/test/data/local-sig-inlay-hints/Infix.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Infix.hs rename to ghcide/test/data/local-sig-inlay-hints/Infix.hs diff --git a/ghcide/test/data/local-sig-lens/Inline.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Inline.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Inline.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Inline.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Inline.hs b/ghcide/test/data/local-sig-inlay-hints/Inline.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Inline.hs rename to ghcide/test/data/local-sig-inlay-hints/Inline.hs diff --git a/ghcide/test/data/local-sig-lens/Nest.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Nest.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Nest.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Nest.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Nest.hs b/ghcide/test/data/local-sig-inlay-hints/Nest.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Nest.hs rename to ghcide/test/data/local-sig-inlay-hints/Nest.hs diff --git a/ghcide/test/data/local-sig-lens/NoLens.expected.hs b/ghcide/test/data/local-sig-inlay-hints/NoLens.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/NoLens.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/NoLens.expected.hs diff --git a/ghcide/test/data/local-sig-lens/NoLens.hs b/ghcide/test/data/local-sig-inlay-hints/NoLens.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/NoLens.hs rename to ghcide/test/data/local-sig-inlay-hints/NoLens.hs diff --git a/ghcide/test/data/local-sig-lens/Operator.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Operator.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Operator.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Operator.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Operator.hs b/ghcide/test/data/local-sig-inlay-hints/Operator.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Operator.hs rename to ghcide/test/data/local-sig-inlay-hints/Operator.hs diff --git a/ghcide/test/data/local-sig-lens/Qualified.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Qualified.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Qualified.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Qualified.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Qualified.hs b/ghcide/test/data/local-sig-inlay-hints/Qualified.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Qualified.hs rename to ghcide/test/data/local-sig-inlay-hints/Qualified.hs diff --git a/ghcide/test/data/local-sig-lens/ScopedTypeVariables.expected.hs b/ghcide/test/data/local-sig-inlay-hints/ScopedTypeVariables.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/ScopedTypeVariables.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/ScopedTypeVariables.expected.hs diff --git a/ghcide/test/data/local-sig-lens/ScopedTypeVariables.hs b/ghcide/test/data/local-sig-inlay-hints/ScopedTypeVariables.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/ScopedTypeVariables.hs rename to ghcide/test/data/local-sig-inlay-hints/ScopedTypeVariables.hs diff --git a/ghcide/test/data/local-sig-lens/Simple.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Simple.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Simple.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Simple.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Simple.hs b/ghcide/test/data/local-sig-inlay-hints/Simple.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Simple.hs rename to ghcide/test/data/local-sig-inlay-hints/Simple.hs diff --git a/ghcide/test/data/local-sig-lens/Tuple.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Tuple.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Tuple.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Tuple.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Tuple.hs b/ghcide/test/data/local-sig-inlay-hints/Tuple.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Tuple.hs rename to ghcide/test/data/local-sig-inlay-hints/Tuple.hs diff --git a/ghcide/test/data/local-sig-lens/Typeclass.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Typeclass.expected.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Typeclass.expected.hs rename to ghcide/test/data/local-sig-inlay-hints/Typeclass.expected.hs diff --git a/ghcide/test/data/local-sig-lens/Typeclass.hs b/ghcide/test/data/local-sig-inlay-hints/Typeclass.hs similarity index 100% rename from ghcide/test/data/local-sig-lens/Typeclass.hs rename to ghcide/test/data/local-sig-inlay-hints/Typeclass.hs diff --git a/ghcide/test/exe/InlayHintTests.hs b/ghcide/test/exe/InlayHintTests.hs index d78a21f3ea..97b1ada422 100644 --- a/ghcide/test/exe/InlayHintTests.hs +++ b/ghcide/test/exe/InlayHintTests.hs @@ -117,7 +117,7 @@ whereInlayHintsTests = testGroup "add signature for where clauses" editTest :: String -> TestTree editTest file = - testWithDummyPlugin (file <> " (InlayHint EditText)") (mkIdeTestFs [copyDir "local-sig-lens"]) $ do + testWithDummyPlugin (file <> " (InlayHint EditText)") (mkIdeTestFs [copyDir "local-sig-inlay-hints"]) $ do doc <- openDoc (file ++ ".hs") "haskell" executeAllHints doc globalRange real <- documentContents doc @@ -127,7 +127,7 @@ editTest file = hintTest :: String -> ([InlayHint] -> Assertion) -> TestTree hintTest file assert = - testWithDummyPlugin (file <> " (InlayHint)") (mkIdeTestFs [copyDir "local-sig-lens"]) $ do + testWithDummyPlugin (file <> " (InlayHint)") (mkIdeTestFs [copyDir "local-sig-inlay-hints"]) $ do doc <- openDoc (file ++ ".hs") "haskell" hints <- getInlayHints doc globalRange liftIO $ assert hints @@ -138,7 +138,7 @@ createConfig on = A.object [ "plugin" A..= A.object [ "ghcide-type-lenses" A..= A.object [ "config" - A..= A.object [ "whereInlayHintOn" A..= A.Bool on ]]]] + A..= A.object [ "localBindingInlayHintOn" A..= A.Bool on ]]]] executeAllHints :: TextDocumentIdentifier -> Range -> Session () From 2f27e9acd6499f3ca218241a5a41948e0d9d1fe1 Mon Sep 17 00:00:00 2001 From: Jinser Kafka Date: Mon, 2 Sep 2024 08:39:06 +0800 Subject: [PATCH 24/24] HsLet compatible --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index c32d5e280b..98c201364f 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -456,7 +456,11 @@ findLocalQ = everything (<>) ([] `mkQ` (pure . findWhere) `extQ` findLet) findLet = findLetExpr . unLoc findLetExpr :: HsExpr GhcTc -> [HsLocalBinds GhcTc] +#if !MIN_VERSION_ghc(9,9,0) findLetExpr (HsLet _ _ binds _ _) = [binds] +#else + findLetExpr (HsLet _ binds _) = [binds] +#endif findLetExpr (HsDo _ _ (unLoc -> stmts)) = concatMap (findLetStmt . unLoc) stmts findLetExpr _ = []