From ba2d544a84235f6c5a993fc5e771101bde1a673b Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Fri, 17 Jun 2022 18:36:47 +0800 Subject: [PATCH 1/3] 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 2/3] 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 3/3] 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)