diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 51d25e995b..98c201364f 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -15,16 +16,19 @@ module Development.IDE.Plugin.TypeLenses ( import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) -import Control.Lens ((?~)) +import Control.Lens ((?~), (^.)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Aeson.Types (toJSON) import qualified Data.Aeson.Types as A +import Data.Generics (GenericQ, everything, + extQ, mkQ, something) import Data.List (find) import qualified Data.Map as Map -import Data.Maybe (catMaybes, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, + mapMaybe, maybeToList) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), @@ -45,9 +49,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), - Range (Range, _end, _start)) +import Development.IDE.Types.Location (Position (..), + Range (..)) +import GHC.Exts (IsString) import GHC.Generics (Generic) +import GHC.Hs (realSrcSpan) import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) @@ -55,7 +61,6 @@ import Ide.Plugin.Error import Ide.Plugin.Properties import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandFunction, - CommandId (CommandId), PluginCommand (PluginCommand), PluginDescriptor (..), PluginId, @@ -69,16 +74,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 ((=~)) @@ -89,7 +97,7 @@ instance Pretty Log where LogShake msg -> pretty msg -typeLensCommandId :: T.Text +typeLensCommandId :: IsString s => s typeLensCommandId = "typesignature.add" descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -97,20 +105,26 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider - , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] - , pluginRules = rules recorder + <> mkPluginHandler SMethod_TextDocumentInlayHint localBindingInlayHints + , pluginCommands = [PluginCommand typeLensCommandId "adds a signature" commandHandler] + , pluginRules = globalBindingRules recorder *> localBindingRules recorder , 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 "mode" (TEnum Mode)] +properties :: Properties + '[ 'PropertyKey "localBindingInlayHintOn" '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 #localBindingInlayHintOn + "Display inlay hints of local bindings" + True codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do @@ -184,7 +198,7 @@ codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command generateLensCommand pId uri title edit = let wEdit = WorkspaceEdit (Just $ Map.singleton uri [edit]) Nothing Nothing - in mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON wEdit]) + in mkLspCommand pId typeLensCommandId title (Just [toJSON wEdit]) -- Since the lenses are created with diagnostics, and since the globalTypeSig -- rule can't be changed as it is also used by the hls-refactor plugin, we can't @@ -253,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) @@ -274,6 +288,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) @@ -289,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 @@ -305,6 +322,17 @@ rules recorder = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) +-- | Convert a given haskell bind to its corresponding type signature. +bindToSig :: HscEnv -> GlobalRdrEnv -> Id -> IOEnv (Env TcGblEnv TcLclEnv) String +bindToSig hsc rdrEnv id = do + env <- +#if MIN_VERSION_ghc(9,7,0) + liftZonkM +#endif + tcInitTidyEnv + 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 let exports = availsToNameSet $ tcg_exports gblEnv @@ -312,19 +340,23 @@ 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 identifier = liftZonkM $ do - let name = idName identifier + hasSig name = whenMaybe (name `elemNameSet` sigs) + renderBind id = do + let name = idName id hasSig name $ do - env <- tcInitTidyEnv - let (_, ty) = tidyOpenType env (idType identifier) - pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + -- convert from bind id to its signature + sig <- bindToSig hsc rdrEnv id + pure $ GlobalBindingTypeSig name (printName 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 @@ -340,3 +372,188 @@ pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables builder = patSynBuilder p field_labels = patSynFieldLabels p orig_args' = map scaledThing orig_args + +-- -------------------------------------------------------------------------------- + +-- | A binding expression with its id and location. +data LocalBinding = LocalBinding + { bindingId :: Id + -- ^ 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 `LocalBinding`s: + -- - `a`: LocalBinding id_a loc_a 0 + -- - `b`: LocalBinding id_b loc_b 4 + } + +-- | Existing local bindings +data LocalBindings = LocalBindings + { bindings :: [LocalBinding] + , existingSigNames :: [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). + } + +data GetLocalBindingTypeSigs = GetLocalBindingTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData) + +type BindingSigMap = Map.Map Id String + +newtype LocalBindingTypeSigsResult = LocalBindingTypeSigsResult ([LocalBindings], BindingSigMap) + +instance Show LocalBindingTypeSigsResult where + show _ = "" + +instance NFData LocalBindingTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetLocalBindingTypeSigs = LocalBindingTypeSigsResult + +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 $ localBindingType (tmrTypechecked <$> tmr) (hscEnv <$> hsc) + pure ([], result) + +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 (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 (LocalBindingTypeSigsResult (localBindings, sigMap)) +localBindingType _ _ = pure Nothing + +-- | 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 + + findLet :: LHsExpr GhcTc -> [HsLocalBinds GhcTc] + 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 _ = [] + + 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 LocalBindings + findBindings (NValBinds binds sigs) = + Just $ LocalBindings + { bindings = concat $ mapMaybe (something (mkQ Nothing findBindingIds) . snd) binds + , existingSigNames = concatMap findSigIds sigs + } + + findBindingIds :: LHsBindLR GhcTc GhcTc -> Maybe [LocalBinding] + findBindingIds bind = case unLoc bind of + FunBind{..} -> + let localBinding = LocalBinding (unLoc fun_id) (getLoc fun_id) + (col (getLoc fun_id) - col (getLoc bind)) + in Just $ pure localBinding + PatBind{..} -> + 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 + + findSigIds :: LSig GhcRn -> [Name] + findSigIds (unLoc -> (TypeSig _ names _)) = map unLoc names + findSigIds _ = [] + +-- | 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 + (LocalBindingTypeSigsResult (localBindings, sigMap), pm) + <- runActionE "InlayHint.GetWhereBindingTypeSigs" state $ useWithStaleE GetLocalBindingTypeSigs nfp + 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 = catMaybes + [ bindingToInlayHints bindingId bindingSig bindingRange offset + | LocalBindings{..} <- localBindings + , let sigSpans = getSrcSpan <$> existingSigNames + , LocalBinding{..} <- bindings + , let bindingSpan = getSrcSpan (idName bindingId) + , let bindingSig = Map.lookup bindingId sigMap + , bindingSpan `notElem` sigSpans + , Just bindingRange <- maybeToList $ toCurrentRange pm <$> srcSpanToRange bindingLoc + -- Show inlay hints only within visible range + , isSubrangeOf bindingRange visibleRange + ] + pure $ InL inlayHints + where + 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 + , _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 + -- Subtract the offset to align with the whole binding expression + insertChar = _character startPos - fromIntegral offset + startPos' = startPos { _character = insertChar } + insertRange = Range startPos' startPos' + in TextEdit insertRange (text <> "\n" <> T.replicate (fromIntegral insertChar) " ") diff --git a/ghcide/test/data/local-sig-inlay-hints/Infix.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Infix.expected.hs new file mode 100644 index 0000000000..bef11e0565 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Infix.hs b/ghcide/test/data/local-sig-inlay-hints/Infix.hs new file mode 100644 index 0000000000..cf29c31010 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Inline.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Inline.expected.hs new file mode 100644 index 0000000000..f9b32f84a5 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Inline.hs b/ghcide/test/data/local-sig-inlay-hints/Inline.hs new file mode 100644 index 0000000000..3adcb786a7 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/Inline.hs @@ -0,0 +1,5 @@ +module Inline where + +f :: a +f = undefined + where g = True diff --git a/ghcide/test/data/local-sig-inlay-hints/Nest.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Nest.expected.hs new file mode 100644 index 0000000000..ef2883c23c --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Nest.hs b/ghcide/test/data/local-sig-inlay-hints/Nest.hs new file mode 100644 index 0000000000..9da7ea6e7e --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/NoLens.expected.hs b/ghcide/test/data/local-sig-inlay-hints/NoLens.expected.hs new file mode 100644 index 0000000000..9a01a17762 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/NoLens.hs b/ghcide/test/data/local-sig-inlay-hints/NoLens.hs new file mode 100644 index 0000000000..9a01a17762 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Operator.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Operator.expected.hs new file mode 100644 index 0000000000..0bae866b6b --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Operator.hs b/ghcide/test/data/local-sig-inlay-hints/Operator.hs new file mode 100644 index 0000000000..4708de5966 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/Operator.hs @@ -0,0 +1,6 @@ +module Operator where + +f :: a +f = undefined + where + g = ($) diff --git a/ghcide/test/data/local-sig-inlay-hints/Qualified.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Qualified.expected.hs new file mode 100644 index 0000000000..7b3623a4ee --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Qualified.hs b/ghcide/test/data/local-sig-inlay-hints/Qualified.hs new file mode 100644 index 0000000000..82c69893a3 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/ScopedTypeVariables.expected.hs b/ghcide/test/data/local-sig-inlay-hints/ScopedTypeVariables.expected.hs new file mode 100644 index 0000000000..e7aa4b18b8 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/ScopedTypeVariables.hs b/ghcide/test/data/local-sig-inlay-hints/ScopedTypeVariables.hs new file mode 100644 index 0000000000..48fe48e41d --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Simple.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Simple.expected.hs new file mode 100644 index 0000000000..23d55a326d --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Simple.hs b/ghcide/test/data/local-sig-inlay-hints/Simple.hs new file mode 100644 index 0000000000..952a08ace6 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/Simple.hs @@ -0,0 +1,6 @@ +module Simple where + +f :: a +f = undefined + where + g = True diff --git a/ghcide/test/data/local-sig-inlay-hints/Tuple.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Tuple.expected.hs new file mode 100644 index 0000000000..354bc35f34 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Tuple.hs b/ghcide/test/data/local-sig-inlay-hints/Tuple.hs new file mode 100644 index 0000000000..27d6a19d3b --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Typeclass.expected.hs b/ghcide/test/data/local-sig-inlay-hints/Typeclass.expected.hs new file mode 100644 index 0000000000..4e8d58e895 --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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-inlay-hints/Typeclass.hs b/ghcide/test/data/local-sig-inlay-hints/Typeclass.hs new file mode 100644 index 0000000000..8ea9361bfb --- /dev/null +++ b/ghcide/test/data/local-sig-inlay-hints/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/InlayHintTests.hs b/ghcide/test/exe/InlayHintTests.hs new file mode 100644 index 0000000000..97b1ada422 --- /dev/null +++ b/ghcide/test/exe/InlayHintTests.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +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 (..), + Position (Position), + Range (Range, _end, _start), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit, _newText, _range), + UInt, + VersionedTextDocumentIdentifier (_uri), + type (|?) (..)) +import Language.LSP.Test (applyEdit, createDoc, + documentContents, getInlayHints, + openDoc, setConfigSection) +import Test.Hls (Assertion, 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 + , 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 "] + } + ] + ] + ] + +editTest :: String -> TestTree +editTest file = + testWithDummyPlugin (file <> " (InlayHint EditText)") (mkIdeTestFs [copyDir "local-sig-inlay-hints"]) $ 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-inlay-hints"]) $ 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 [ "localBindingInlayHintOn" 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 + } + +pointRange :: UInt -> UInt -> Range +pointRange x y = Range (Position x y) (Position x y) + +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 85c1146f6e..cbffd63bb4 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2195,6 +2195,7 @@ test-suite ghcide-tests THTests UnitTests WatchedFileTests + InlayHintTests -- Tests that have been pulled out of the main file default-extensions: diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 751aa6f28e..8e3ff334e5 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -85,10 +85,12 @@ "symbolsOn": true }, "ghcide-type-lenses": { + "codeLensOn": true, "config": { + "localBindingInlayHintOn": true, "mode": "always" }, - "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 938964fc50..3d5594bafb 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -185,6 +185,18 @@ "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.localBindingInlayHintOn": { + "default": true, + "markdownDescription": "Display inlay hints of local bindings", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -201,9 +213,9 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.globalOn": { + "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 751aa6f28e..8e3ff334e5 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -85,10 +85,12 @@ "symbolsOn": true }, "ghcide-type-lenses": { + "codeLensOn": true, "config": { + "localBindingInlayHintOn": true, "mode": "always" }, - "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 938964fc50..3d5594bafb 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -185,6 +185,18 @@ "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.localBindingInlayHintOn": { + "default": true, + "markdownDescription": "Display inlay hints of local bindings", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -201,9 +213,9 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.globalOn": { + "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 751aa6f28e..8e3ff334e5 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -85,10 +85,12 @@ "symbolsOn": true }, "ghcide-type-lenses": { + "codeLensOn": true, "config": { + "localBindingInlayHintOn": true, "mode": "always" }, - "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 938964fc50..3d5594bafb 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -185,6 +185,18 @@ "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.localBindingInlayHintOn": { + "default": true, + "markdownDescription": "Display inlay hints of local bindings", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.ghcide-type-lenses.config.mode": { "default": "always", "description": "Control how type lenses are shown", @@ -201,9 +213,9 @@ "scope": "resource", "type": "string" }, - "haskell.plugin.ghcide-type-lenses.globalOn": { + "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" },