hls-refactor-plugin 1.0.0.0 → 1.1.0.0
raw patch · 44 files changed
+1344/−522 lines, 44 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
- Development.IDE.Plugin.CodeAction: instance GHC.Show.Show Development.IDE.Plugin.CodeAction.ImportStyle
+ Development.IDE.GHC.ExactPrint: genAnchor1 :: Anchor
+ Development.IDE.GHC.ExactPrint: modifyMgMatchesT :: Monad m => MatchGroup GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))) -> TransformT m (MatchGroup GhcPs (LHsExpr GhcPs))
+ Development.IDE.GHC.ExactPrint: modifyMgMatchesT' :: Monad m => MatchGroup GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs), r)) -> r -> (r -> r -> m r) -> TransformT m (MatchGroup GhcPs (LHsExpr GhcPs), r)
+ Development.IDE.GHC.ExactPrint: modifySigWithM :: forall a m. (HasDecls a, Monad m) => IdP GhcPs -> (LHsSigType GhcPs -> LHsSigType GhcPs) -> a -> TransformT m a
+ Development.IDE.GHC.ExactPrint: modifySmallestDeclWithM :: forall a m r. (HasDecls a, Monad m) => (SrcSpan -> m Bool) -> (LHsDecl GhcPs -> TransformT m ([LHsDecl GhcPs], r)) -> a -> TransformT m (a, Maybe r)
+ Development.IDE.GHC.ExactPrint: setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a
+ Development.IDE.Plugin.CodeAction: instance GHC.Classes.Eq Development.IDE.Plugin.CodeAction.ImportSuggestion
- Development.IDE.GHC.ExactPrint: class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l
+ Development.IDE.GHC.ExactPrint: class (Data ast, Typeable l, Outputable l, Outputable ast, Default l) => ASTElement l ast | ast -> l
Files
- hls-refactor-plugin.cabal +16/−12
- src/Development/IDE/GHC/Compat/ExactPrint.hs +0/−5
- src/Development/IDE/GHC/Dump.hs +13/−11
- src/Development/IDE/GHC/ExactPrint.hs +189/−34
- src/Development/IDE/Plugin/CodeAction.hs +199/−346
- src/Development/IDE/Plugin/CodeAction/Args.hs +32/−34
- src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +46/−22
- src/Development/IDE/Plugin/CodeAction/Util.hs +14/−13
- src/Development/IDE/Plugin/Plugins/AddArgument.hs +167/−0
- src/Development/IDE/Plugin/Plugins/Diagnostic.hs +53/−0
- src/Development/IDE/Plugin/Plugins/FillHole.hs +104/−0
- src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs +78/−0
- src/Development/IDE/Plugin/Plugins/ImportUtils.hs +85/−0
- test/Main.hs +135/−44
- test/Test/AddArgument.hs +74/−0
- test/data/golden/add-arg/AddArgFromLet.expected.hs +6/−0
- test/data/golden/add-arg/AddArgFromLet.hs +6/−0
- test/data/golden/add-arg/AddArgFromWhere.expected.hs +6/−0
- test/data/golden/add-arg/AddArgFromWhere.hs +6/−0
- test/data/golden/add-arg/AddArgFromWhereComments.expected.hs +6/−0
- test/data/golden/add-arg/AddArgFromWhereComments.hs +6/−0
- test/data/golden/add-arg/AddArgWithLambda.expected.hs +4/−0
- test/data/golden/add-arg/AddArgWithLambda.hs +4/−0
- test/data/golden/add-arg/AddArgWithSig.expected.hs +4/−0
- test/data/golden/add-arg/AddArgWithSig.hs +4/−0
- test/data/golden/add-arg/AddArgWithSigAndDocs.expected.hs +11/−0
- test/data/golden/add-arg/AddArgWithSigAndDocs.hs +11/−0
- test/data/golden/add-arg/AddArgWithTypeSynSig.expected.hs +5/−0
- test/data/golden/add-arg/AddArgWithTypeSynSig.hs +5/−0
- test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.expected.hs +5/−0
- test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.hs +5/−0
- test/data/golden/add-arg/Hole.expected.hs +1/−0
- test/data/golden/add-arg/Hole.hs +1/−0
- test/data/golden/add-arg/MultiSigFirst.expected.hs +6/−0
- test/data/golden/add-arg/MultiSigFirst.hs +5/−0
- test/data/golden/add-arg/MultiSigLast.expected.hs +7/−0
- test/data/golden/add-arg/MultiSigLast.hs +6/−0
- test/data/golden/add-arg/MultiSigMiddle.expected.hs +7/−0
- test/data/golden/add-arg/MultiSigMiddle.hs +6/−0
- test/data/golden/add-arg/MultipleDeclAlts.expected.hs +2/−0
- test/data/golden/add-arg/MultipleDeclAlts.hs +2/−0
- test/data/golden/add-arg/NoTypeSuggestion.expected.hs +1/−0
- test/data/golden/add-arg/NoTypeSuggestion.hs +1/−0
- test/data/hiding/hie.yaml +0/−1
hls-refactor-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-refactor-plugin-version: 1.0.0.0+version: 1.1.0.0 synopsis: Exactprint refactorings for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -17,11 +17,11 @@ test/data/**/*.hs test/data/**/*.yaml +source-repository head+ type: git+ location: https://github.com/haskell/haskell-language-server.git+ library- if impl(ghc >= 9.3)- buildable: False- else- buildable: True exposed-modules: Development.IDE.GHC.ExactPrint Development.IDE.GHC.Compat.ExactPrint Development.IDE.Plugin.CodeAction@@ -30,6 +30,11 @@ other-modules: Development.IDE.Plugin.CodeAction.Args Development.IDE.Plugin.CodeAction.ExactPrint Development.IDE.Plugin.CodeAction.PositionIndexed+ Development.IDE.Plugin.Plugins.AddArgument+ Development.IDE.Plugin.Plugins.Diagnostic+ Development.IDE.Plugin.Plugins.FillHole+ Development.IDE.Plugin.Plugins.FillTypeWildcard+ Development.IDE.Plugin.Plugins.ImportUtils default-extensions: BangPatterns CPP@@ -63,8 +68,8 @@ , ghc-boot , regex-tdfa , text-rope- , ghcide ^>=1.8- , hls-plugin-api ^>=1.3 || ^>=1.4 || ^>= 1.5+ , ghcide ^>=1.9+ , hls-plugin-api ^>=1.6 , lsp , text , transformers@@ -85,20 +90,17 @@ default-language: Haskell2010 test-suite tests- if impl(ghc >= 9.3)- buildable: False- else- buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs+ other-modules: Test.AddArgument ghc-options: -O0 -threaded -rtsopts -with-rtsopts=-N -Wunused-imports build-depends: , base , filepath , hls-refactor-plugin- , hls-test-utils ^>=1.4+ , hls-test-utils ^>=1.5 , lens , lsp-types , text@@ -109,6 +111,8 @@ , extra , text-rope , containers+ -- ghc is included to enable the MIN_VERSION_ghc macro+ , ghc , ghcide , ghcide-test-utils , shake
src/Development/IDE/GHC/Compat/ExactPrint.hs view
@@ -2,9 +2,6 @@ -- multiple ghc-exactprint versions, accepting that anything more ambitious is -- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint module Development.IDE.GHC.Compat.ExactPrint-#if MIN_VERSION_ghc(9,3,0)- ( ) where-#else ( ExactPrint , exactPrint , makeDeltaAst@@ -33,6 +30,4 @@ #else pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))-#endif- #endif
src/Development/IDE/GHC/Dump.hs view
@@ -1,25 +1,22 @@ {-# LANGUAGE CPP #-} module Development.IDE.GHC.Dump(showAstDataHtml) where-import Data.Data hiding (Fixity)-import Development.IDE.GHC.Compat hiding (NameAnn)+import Data.Data hiding (Fixity)+import Development.IDE.GHC.Compat hiding (LocatedA,+ NameAnn) import Development.IDE.GHC.Compat.ExactPrint-#if MIN_VERSION_ghc(8,10,1) import GHC.Hs.Dump-#else-import HsDumpAst-#endif #if MIN_VERSION_ghc(9,2,1)-import qualified Data.ByteString as B+import qualified Data.ByteString as B import Development.IDE.GHC.Compat.Util-import Generics.SYB (ext1Q, ext2Q, extQ)-import GHC.Hs+import Generics.SYB (ext1Q, ext2Q, extQ)+import GHC.Hs hiding (AnnLet) #endif #if MIN_VERSION_ghc(9,0,1)-import GHC.Plugins+import GHC.Plugins hiding (AnnLet) #else import GhcPlugins #endif-import Prelude hiding ((<>))+import Prelude hiding ((<>)) -- | Show a GHC syntax tree in HTML. #if MIN_VERSION_ghc(9,2,1)@@ -235,8 +232,13 @@ annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") +#if MIN_VERSION_ghc(9,4,0)+ annotationEpAnnHsLet :: EpAnn NoEpAnns -> SDoc+ annotationEpAnnHsLet = annotation' (text "EpAnn NoEpAnns")+#else annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")+#endif annotationAnnList :: EpAnn AnnList -> SDoc annotationAnnList = annotation' (text "EpAnn AnnList")
src/Development/IDE/GHC/ExactPrint.hs view
@@ -3,9 +3,6 @@ -- | This module hosts various abstractions and utility functions to work with ghc-exactprint. module Development.IDE.GHC.ExactPrint-#if MIN_VERSION_ghc(9,3,0)- ( ) where-#else ( Graft(..), graftDecls, graftDeclsWithM,@@ -20,11 +17,19 @@ transform, transformM, ExactPrint(..),+#if MIN_VERSION_ghc(9,2,1)+ modifySmallestDeclWithM,+ modifyMgMatchesT,+ modifyMgMatchesT',+ modifySigWithM,+ genAnchor1,+#endif #if !MIN_VERSION_ghc(9,2,0) Anns, Annotate, setPrecedingLinesT, #else+ setPrecedingLines, addParens, addParensToCtxt, modifyAnns,@@ -56,6 +61,7 @@ import Control.Monad.Zip import Data.Bifunctor import Data.Bool (bool)+import Data.Default (Default) import qualified Data.DList as DL import Data.Either.Extra (mapLeft) import Data.Foldable (Foldable (fold))@@ -86,11 +92,14 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities)-import Retrie.ExactPrint hiding (Annotated (..),- parseDecl, parseExpr,+import Retrie.ExactPrint hiding (parseDecl,+ parseExpr, parsePattern, parseType)-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,9,0)+import GHC.Plugins (showSDoc)+import GHC.Utils.Outputable (Outputable (ppr))+#elif MIN_VERSION_ghc(9,2,0) import GHC (EpAnn (..), NameAdornment (NameParens), NameAnn (..),@@ -101,9 +110,22 @@ spanAsAnchor) import GHC.Parser.Annotation (AnnContext (..), DeltaPos (SameLine),- EpaLocation (EpaDelta))+ EpaLocation (EpaDelta),+ deltaPos) #endif +#if MIN_VERSION_ghc(9,2,1)+import Data.List (partition)+import GHC (Anchor(..), realSrcSpan, AnchorOperation, DeltaPos(..), SrcSpanAnnN)+import GHC.Types.SrcLoc (generatedSrcSpan)+import Control.Lens ((&), _last)+import Control.Lens.Operators ((%~))+#endif++#if MIN_VERSION_ghc(9,2,0)+setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a+setPrecedingLines ast n c = setEntryDP ast (deltaPos n c)+#endif ------------------------------------------------------------------------------ data Log = LogShake Shake.Log deriving Show@@ -114,10 +136,10 @@ instance Show (Annotated ParsedSource) where show _ = "<Annotated ParsedSource>"- + instance NFData (Annotated ParsedSource) where rnf = rwhnf- + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) @@ -307,7 +329,7 @@ getNeedsSpaceAndParenthesize dst a = -- Traverse the tree, looking for our replacement node. But keep track of -- the context (parent HsExpr constructor) we're in while we do it. This- -- lets us determine wehther or not we need parentheses.+ -- lets us determine whether or not we need parentheses. let (needs_parens, needs_space) = everythingWithContext (Nothing, Nothing) (<>) ( mkQ (mempty, ) $ \x s -> case x of@@ -374,7 +396,7 @@ #if MIN_VERSION_ghc(9,2,0) val'' <- hoistTransform (either Fail.fail pure) $- annotate dflags True $ maybeParensAST val'+ annotate dflags False $ maybeParensAST val' pure val'' #else (anns, val'') <-@@ -430,6 +452,138 @@ | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a +#if MIN_VERSION_ghc(9,2,1)++-- | Replace the smallest declaration whose SrcSpan satisfies the given condition with a new+-- list of declarations.+--+-- For example, if you would like to move a where-clause-defined variable to the same+-- level as its parent HsDecl, you could use this function.+--+-- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`. If+-- not declaration matched, then `Nothing` is returned.+modifySmallestDeclWithM ::+ forall a m r.+ (HasDecls a, Monad m) =>+ (SrcSpan -> m Bool) ->+ (LHsDecl GhcPs -> TransformT m ([LHsDecl GhcPs], r)) ->+ a ->+ TransformT m (a, Maybe r)+modifySmallestDeclWithM validSpan f a = do+ let modifyMatchingDecl [] = pure (DL.empty, Nothing)+ modifyMatchingDecl (ldecl@(L src _) : rest) =+ lift (validSpan $ locA src) >>= \case+ True -> do+ (decs', r) <- f ldecl+ pure $ (DL.fromList decs' <> DL.fromList rest, Just r)+ False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest+ modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a++generatedAnchor :: AnchorOperation -> Anchor+generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp++setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN+setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) =+ SrcSpanAnn (EpAnn anc nameAnn comments) span+setAnchor _ spanAnnN = spanAnnN++removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN+removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) =+ let nameAnnSansTrailings = nameAnn {nann_trailing = []}+ in SrcSpanAnn (EpAnn anc nameAnnSansTrailings comments) span+removeTrailingAnns spanAnnN = spanAnnN++-- | Modify the type signature for the given IdP. This function handles splitting a multi-sig+-- SigD into multiple SigD if the type signature is changed.+--+-- For example, update the type signature for `foo` from `Int` to `Bool`:+--+-- - foo :: Int+-- + foo :: Bool+--+-- - foo, bar :: Int+-- + bar :: Int+-- + foo :: Bool+--+-- - foo, bar, baz :: Int+-- + bar, baz :: Int+-- + foo :: Bool+modifySigWithM ::+ forall a m.+ (HasDecls a, Monad m) =>+ IdP GhcPs ->+ (LHsSigType GhcPs -> LHsSigType GhcPs) ->+ a ->+ TransformT m a+modifySigWithM queryId f a = do+ let modifyMatchingSigD :: [LHsDecl GhcPs] -> TransformT m (DL.DList (LHsDecl GhcPs))+ modifyMatchingSigD [] = pure (DL.empty)+ modifyMatchingSigD (ldecl@(L annSigD (SigD xsig (TypeSig xTypeSig ids (HsWC xHsWc lHsSig)))) : rest)+ | queryId `elem` (unLoc <$> ids) = do+ let newSig = f lHsSig+ -- If this signature update caused no change, then we don't need to split up multi-signatures+ if newSig `geq` lHsSig+ then pure $ DL.singleton ldecl <> DL.fromList rest+ else case partition ((== queryId) . unLoc) ids of+ ([L annMatchedId matchedId], otherIds) ->+ let matchedId' = L (setAnchor genAnchor0 $ removeTrailingAnns annMatchedId) matchedId+ matchedIdSig =+ let sig' = SigD xsig (TypeSig xTypeSig [matchedId'] (HsWC xHsWc newSig))+ epAnn = bool (noAnnSrcSpanDP generatedSrcSpan (DifferentLine 1 0)) annSigD (null otherIds)+ in L epAnn sig'+ otherSig = case otherIds of+ [] -> []+ (L (SrcSpanAnn epAnn span) id1:ids) -> [+ let epAnn' = case epAnn of+ EpAnn _ nameAnn commentsId1 -> EpAnn genAnchor0 nameAnn commentsId1+ EpAnnNotUsed -> EpAnn genAnchor0 mempty emptyComments+ ids' = L (SrcSpanAnn epAnn' span) id1:ids+ ids'' = ids' & _last %~ first removeTrailingAnns+ in L annSigD (SigD xsig (TypeSig xTypeSig ids'' (HsWC xHsWc lHsSig)))+ ]+ in pure $ DL.fromList otherSig <> DL.singleton matchedIdSig <> DL.fromList rest+ _ -> error "multiple ids matched"+ modifyMatchingSigD (ldecl : rest) = (DL.singleton ldecl <>) <$> modifyMatchingSigD rest+ modifyDeclsT (fmap DL.toList . modifyMatchingSigD) a++genAnchor0 :: Anchor+genAnchor0 = generatedAnchor m0++genAnchor1 :: Anchor+genAnchor1 = generatedAnchor m1++-- | Apply a transformation to the decls contained in @t@+modifyDeclsT' :: (HasDecls t, HasTransform m)+ => ([LHsDecl GhcPs] -> m ([LHsDecl GhcPs], r))+ -> t -> m (t, r)+modifyDeclsT' action t = do+ decls <- liftT $ hsDecls t+ (decls', r) <- action decls+ t' <- liftT $ replaceDecls t decls'+ pure (t', r)++-- | Modify each LMatch in a MatchGroup+modifyMgMatchesT ::+ Monad m =>+ MatchGroup GhcPs (LHsExpr GhcPs) ->+ (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs))) ->+ TransformT m (MatchGroup GhcPs (LHsExpr GhcPs))+modifyMgMatchesT mg f = fst <$> modifyMgMatchesT' mg (fmap (, ()) . f) () ((.) pure . const)++-- | Modify the each LMatch in a MatchGroup+modifyMgMatchesT' ::+ Monad m =>+ MatchGroup GhcPs (LHsExpr GhcPs) ->+ (LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs), r)) ->+ r ->+ (r -> r -> m r) ->+ TransformT m (MatchGroup GhcPs (LHsExpr GhcPs), r)+modifyMgMatchesT' (MG xMg (L locMatches matches) originMg) f def combineResults = do+ (unzip -> (matches', rs)) <- mapM f matches+ r' <- lift $ foldM combineResults def rs+ pure $ (MG xMg (L locMatches matches') originMg, r')+#endif+ graftSmallestDeclsWithM :: forall a. (HasDecls a) =>@@ -468,7 +622,17 @@ modifyDeclsT (fmap DL.toList . go) a -class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where+-- In 9.2+, we need `Default l` to do `setPrecedingLines` on annotated elements.+-- In older versions, we pass around annotations explicitly, so the instance isn't needed.+class+ ( Data ast+ , Typeable l+ , Outputable l+ , Outputable ast+#if MIN_VERSION_ghc(9,2,0)+ , Default l+#endif+ ) => ASTElement l ast | ast -> l where parseAST :: Parser (LocatedAn l ast) maybeParensAST :: LocatedAn l ast -> LocatedAn l ast {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with@@ -489,13 +653,8 @@ graft = graftExpr instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where-#if __GLASGOW_HASKELL__ == 808- parseAST = fmap (fmap $ right $ second dL) . parsePattern- maybeParensAST = dL . parenthesizePat appPrec . unLoc-#else parseAST = parsePattern maybeParensAST = parenthesizePat appPrec-#endif instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where parseAST = parseType@@ -525,6 +684,7 @@ ------------------------------------------------------------------------------ + -- | Given an 'LHSExpr', compute its exactprint annotations. -- Note that this function will throw away any existing annotations (and format) annotate :: (ASTElement l ast, Outputable l)@@ -536,9 +696,12 @@ annotate dflags needs_space ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0)+ expr' <- lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered+ pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space)+#elif MIN_VERSION_ghc(9,2,0) expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered- pure expr'+ pure $ setPrecedingLines expr' 0 (bool 0 1 needs_space) #else (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns@@ -547,6 +710,7 @@ -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)+#if !MIN_VERSION_ghc(9,2,0) -- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain -- multiple matches. To work around this, we split the single -- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match',@@ -559,17 +723,6 @@ let set_matches matches = ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} -#if MIN_VERSION_ghc(9,2,0)- alts' <- for alts $ \alt -> do- uniq <- show <$> uniqueSrcSpanT- let rendered = render dflags $ set_matches [alt]- lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case- (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))- -> pure alt'- _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match"-- pure $ L src $ set_matches alts'-#else (anns', alts') <- fmap unzip $ for alts $ \alt -> do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags $ set_matches [alt]@@ -584,8 +737,12 @@ annotateDecl dflags ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast-#if MIN_VERSION_ghc(9,2,0)- lift $ mapLeft show $ parseDecl dflags uniq rendered+#if MIN_VERSION_ghc(9,4,0)+ expr' <- lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered+ pure $ setPrecedingLines expr' 1 0+#elif MIN_VERSION_ghc(9,2,0)+ expr' <- lift $ mapLeft show $ parseDecl dflags uniq rendered+ pure $ setPrecedingLines expr' 1 0 #else (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered let anns' = setPrecedingLines expr' 1 0 anns@@ -667,6 +824,4 @@ isCommaAnn :: TrailingAnn -> Bool isCommaAnn AddCommaAnn{} = True isCommaAnn _ = False-#endif- #endif
src/Development/IDE/Plugin/CodeAction.hs view
@@ -19,9 +19,9 @@ (&&&), (>>>)) import Control.Concurrent.STM.Stats (atomically)+import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe-import Control.Monad.Extra import Data.Aeson import Data.Char import qualified Data.DList as DL@@ -37,56 +37,67 @@ import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.Utf16.Rope as Rope-import Data.Tuple.Extra (fst3)-import Development.IDE.Types.Logger hiding (group) import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service-import Development.IDE.GHC.Compat+import Development.IDE.Core.Shake hiding (Log)+import Development.IDE.GHC.Compat hiding+ (ImplicitPrelude) import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint-import qualified Development.IDE.GHC.ExactPrint as E+import qualified Development.IDE.GHC.ExactPrint as E import Development.IDE.GHC.Util (printOutputable, printRdrName)-import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint-import Development.IDE.Plugin.CodeAction.Util import Development.IDE.Plugin.CodeAction.PositionIndexed+import Development.IDE.Plugin.CodeAction.Util import Development.IDE.Plugin.Completions.Types+import qualified Development.IDE.Plugin.Plugins.AddArgument+import Development.IDE.Plugin.Plugins.Diagnostic+import Development.IDE.Plugin.Plugins.FillHole (suggestFillHole)+import Development.IDE.Plugin.Plugins.FillTypeWildcard (suggestFillTypeWildcard)+import Development.IDE.Plugin.Plugins.ImportUtils import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Types.Exports import Development.IDE.Types.Location+import Development.IDE.Types.Logger hiding+ (group) import Development.IDE.Types.Options+import GHC.Exts (fromList) import qualified GHC.LanguageExtensions as Lang+#if MIN_VERSION_ghc(9,4,0)+import GHC.Parser.Annotation (TokenLocation (..))+#endif import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP-import Language.LSP.Types (ApplyWorkspaceEditParams(..), CodeAction (..),+import Language.LSP.Types (ApplyWorkspaceEditParams (..),+ CodeAction (..), CodeActionContext (CodeActionContext, _diagnostics),- CodeActionKind (CodeActionQuickFix, CodeActionUnknown),+ CodeActionKind (CodeActionQuickFix), CodeActionParams (CodeActionParams), Command, Diagnostic (..),- MessageType (..),- ShowMessageParams (..), List (..),+ MessageType (..), ResponseError, SMethod (..),+ ShowMessageParams (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit, _range), UInt, WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InR), uriToFilePath)-import GHC.Exts (fromList) import Language.LSP.VFS (VirtualFile, _file_text)-import Text.Regex.TDFA (mrAfter,- (=~), (=~~))+import qualified Text.Fuzzy.Parallel as TFP+import Text.Regex.TDFA ((=~), (=~~)) #if MIN_VERSION_ghc(9,2,0) import GHC (AddEpAnn (AddEpAnn), Anchor (anchor_op),@@ -95,9 +106,7 @@ DeltaPos (..), EpAnn (..), EpaLocation (..),- LEpaComment,- LocatedA)-+ LEpaComment) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos,@@ -135,13 +144,11 @@ wrap suggestExportUnusedTopBinding , wrap suggestModuleTypo , wrap suggestFixConstructorImport- , wrap suggestNewImport-#if !MIN_VERSION_ghc(9,3,0) , wrap suggestExtendImport , wrap suggestImportDisambiguation , wrap suggestNewOrExtendImportForClassMethod , wrap suggestHideShadow-#endif+ , wrap suggestNewImport ] plId in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction }@@ -151,11 +158,9 @@ mkGhcideCAsPlugin [ wrap $ suggestSignature True , wrap suggestFillTypeWildcard- , wrap suggestAddTypeAnnotationToSatisfyContraints-#if !MIN_VERSION_ghc(9,3,0)+ , wrap suggestAddTypeAnnotationToSatisfyConstraints , wrap removeRedundantConstraints , wrap suggestConstraint-#endif ] plId @@ -163,10 +168,9 @@ bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ mkGhcideCAsPlugin [ wrap suggestReplaceIdentifier-#if !MIN_VERSION_ghc(9,3,0) , wrap suggestImplicitParameter-#endif , wrap suggestNewDefinition+ , wrap Development.IDE.Plugin.Plugins.AddArgument.plugin , wrap suggestDeleteUnusedBinding ] plId@@ -242,7 +246,7 @@ Nothing -> newThing Just p -> p <> "(" <> newThing <> ")" t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents)- return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})+ return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero @@ -369,7 +373,6 @@ -- imported from ‘Data.ByteString’ at B.hs:6:1-22 -- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 -- imported from ‘Data.Text’ at B.hs:7:1-16-#if !MIN_VERSION_ghc(9,3,0) suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} | Just [identifier, modName, s] <-@@ -384,12 +387,12 @@ Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", mods <- [(modName, s) | [_, modName, s] <- matched], result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier),- hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) =+ hideAll <- ("Hide " <> identifier <> " from all occurrence imports", concatMap snd result) = result <> [hideAll] | otherwise = [] where L _ HsModule {hsmodImports} = astA ps- + suggests identifier modName s | Just tcM <- mTcM, Just har <- mHar,@@ -401,7 +404,6 @@ then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl | otherwise = []-#endif findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) findImportDeclByModuleName decls modName = flip find decls $ \case@@ -458,6 +460,12 @@ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] | otherwise = [] ++-- Note [Removing imports is preferred]+-- It's good to prefer the remove imports code action because an unused import+-- is likely to be removed and less likely the warning will be disabled.+-- Therefore actions to remove a single or all redundant imports should be+-- preferred, so that the client can prioritize them higher. caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents digs ctxDigs uri | Just pm <- m,@@ -481,7 +489,8 @@ _diagnostics = Nothing _documentChanges = Nothing _edit = Just WorkspaceEdit{..}- _isPreferred = Nothing+ -- See Note [Removing imports is preferred]+ _isPreferred = Just True _command = Nothing _disabled = Nothing _xdata = Nothing@@ -520,7 +529,8 @@ _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing- _isPreferred = Nothing+ -- See Note [Removing imports is preferred]+ _isPreferred = Just True _disabled = Nothing _xdata = Nothing _changeAnnotations = Nothing@@ -534,7 +544,8 @@ _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing- _isPreferred = Nothing+ -- See Note [Removing imports is preferred]+ _isPreferred = Just True _disabled = Nothing _xdata = Nothing _changeAnnotations = Nothing@@ -772,8 +783,8 @@ exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportFamily, reLoc $ fdLName tcdFam) exportsAs _ = Nothing -suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}+suggestAddTypeAnnotationToSatisfyConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestAddTypeAnnotationToSatisfyConstraints sourceOpt Diagnostic{_range=_range,..} -- File.hs:52:41: warning: -- * Defaulting the following constraint to type ‘Integer’ -- Num p0 arising from the literal ‘1’@@ -813,6 +824,18 @@ | otherwise = [] where makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"+#if MIN_VERSION_ghc(9,4,0)+ pat multiple at inArg inExpr = T.concat [ ".*Defaulting the type variable "+ , ".*to type ‘([^ ]+)’ "+ , "in the following constraint"+ , if multiple then "s" else ""+ , ".*arising from the literal ‘(.+)’"+ , if inArg then ".+In the.+argument" else ""+ , if at then ".+at" else ""+ , if inExpr then ".+In the expression" else ""+ , ".+In the expression"+ ]+#else pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" , if multiple then "s" else "" , " to type ‘([^ ]+)’ "@@ -822,14 +845,19 @@ , if inExpr then ".+In the expression" else "" , ".+In the expression" ]+#endif codeEdit ty lit replacement = let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" edits = [TextEdit _range replacement] in [( title, edits )] --suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestReplaceIdentifier contents Diagnostic{_range=_range,..}+-- | GHC strips out backticks in case of infix functions as well as single quote+-- in case of quoted name when using TemplateHaskellQuotes. Which is not desired.+--+-- For example:+-- 1.+--+-- @ -- File.hs:52:41: error: -- * Variable not in scope: -- suggestAcion :: Maybe T.Text -> Range -> Range@@ -841,49 +869,59 @@ -- ‘T.isInfixOf’ (imported from Data.Text), -- ‘T.isSuffixOf’ (imported from Data.Text) -- Module ‘Data.Text’ does not export ‘isPrfixOf’.+-- @+--+-- * action: \`suggestAcion\` will be renamed to \`suggestAction\` keeping back ticks around the function+--+-- 2.+--+-- @+-- import Language.Haskell.TH (Name)+-- foo :: Name+-- foo = 'bread+--+-- File.hs:8:7: error:+-- Not in scope: ‘bread’+-- * Perhaps you meant one of these:+-- ‘break’ (imported from Prelude), ‘read’ (imported from Prelude)+-- * In the Template Haskell quotation 'bread+-- @+--+-- * action: 'bread will be renamed to 'break keeping single quote on beginning of name+suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestReplaceIdentifier contents Diagnostic{_range=_range,..} | renameSuggestions@(_:_) <- extractRenamableTerms _message = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] | otherwise = [] suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}--- * Variable not in scope:--- suggestAcion :: Maybe T.Text -> Range -> Range- | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"- = newDefinitionAction ideOptions parsedModule _range name typ- | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"- , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ- = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]- | otherwise = []- where- message = unifySpaces _message+suggestNewDefinition ideOptions parsedModule contents Diagnostic {_message, _range}+ | Just (name, typ) <- matchVariableNotInScope message =+ newDefinitionAction ideOptions parsedModule _range name typ+ | Just (name, typ) <- matchFoundHole message,+ [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name (Just typ) =+ [(label, mkRenameEdit contents _range name : newDefinitionEdits)]+ | otherwise = []+ where+ message = unifySpaces _message -newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]-newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ- | Range _ lastLineP : _ <-+newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> Maybe T.Text -> [(T.Text, [TextEdit])]+newDefinitionAction IdeOptions {..} parsedModule Range {_start} name typ+ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp- | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls- , _start `isInsideSrcSpan` l]- , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}- = [ ("Define " <> sig- , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]- )]- | otherwise = []+ | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls,+ _start `isInsideSrcSpan` l+ ],+ nextLineP <- Position {_line = _line lastLineP + 1, _character = 0} =+ [ ( "Define " <> sig,+ [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]+ )+ ]+ | otherwise = [] where colon = if optNewColonConvention then " : " else " :: "- sig = name <> colon <> T.dropWhileEnd isSpace typ- ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule--suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillTypeWildcard Diagnostic{_range=_range,..}--- Foo.hs:3:8: error:--- * Found type wildcard `_' standing for `p -> p1 -> p'-- | "Found type wildcard" `T.isInfixOf` _message- , " standing for " `T.isInfixOf` _message- , typeSignature <- extractWildCardTypeSignature _message- = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)]- | otherwise = []+ sig = name <> colon <> T.dropWhileEnd isSpace (fromMaybe "_" typ)+ ParsedModule {pm_parsed_source = L _ HsModule {hsmodDecls}} = parsedModule {- Handles two variants with different formatting @@ -911,90 +949,6 @@ [modul, "(from", _] -> Just modul _ -> Nothing --suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillHole Diagnostic{_range=_range,..}- | Just holeName <- extractHoleName _message- , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =- let isInfixHole = _message =~ addBackticks holeName :: Bool in- map (proposeHoleFit holeName False isInfixHole) holeFits- ++ map (proposeHoleFit holeName True isInfixHole) refFits- | otherwise = []- where- extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"- addBackticks text = "`" <> text <> "`"- addParens text = "(" <> text <> ")"- proposeHoleFit holeName parenthise isInfixHole name =- let isInfixOperator = T.head name == '('- name' = getOperatorNotation isInfixHole isInfixOperator name in- ( "replace " <> holeName <> " with " <> name- , TextEdit _range (if parenthise then addParens name' else name')- )- getOperatorNotation True False name = addBackticks name- getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name)- getOperatorNotation _isInfixHole _isInfixOperator name = name--processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])-processHoleSuggestions mm = (holeSuggestions, refSuggestions)-{-- • Found hole: _ :: LSP.Handlers-- Valid hole fits include def- Valid refinement hole fits include- fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)- fromJust (_ :: Maybe LSP.Handlers)- haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams- LSP.Handlers)- T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)- (_ :: LSP.Handlers)- (_ :: T.Text)- T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)- (_ :: LSP.Handlers)- (_ :: T.Text)--}- where- t = id @T.Text- holeSuggestions = do- -- get the text indented under Valid hole fits- validHolesSection <-- getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm- -- the Valid hole fits line can contain a hole fit- holeFitLine <-- mapHead- (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))- validHolesSection- let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine- guard (not $ T.null holeFit)- return holeFit- refSuggestions = do -- @[]- -- get the text indented under Valid refinement hole fits- refinementSection <-- getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm- -- get the text for each hole fit- holeFitLines <- getIndentedGroups (tail refinementSection)- let holeFit = T.strip $ T.unwords holeFitLines- guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"- return holeFit-- mapHead f (a:aa) = f a : aa- mapHead _ [] = []---- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]]-getIndentedGroups :: [T.Text] -> [[T.Text]]-getIndentedGroups [] = []-getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll--- |--- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]]-getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]-getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of- (l:ll) -> case span (\l' -> indentation l < indentation l') ll of- (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest- _ -> []--indentation :: T.Text -> Int-indentation = T.length . T.takeWhile isSpace--#if !MIN_VERSION_ghc(9,3,0) suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} | Just [binding, mod, srcspan] <-@@ -1025,24 +979,23 @@ ] | otherwise = [] lookupExportMap binding mod- | Just match <- Map.lookup binding (getExportsMap exportsMap)+ | let em = getExportsMap exportsMap+ match1 = lookupOccEnv em (mkVarOrDataOcc binding)+ match2 = lookupOccEnv em (mkTypeOcc binding)+ , Just match <- match1 <> match2 -- Only for the situation that data constructor name is same as type constructor name, -- let ident with parent be in front of the one without. , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch- , (not . null) idents -- Ensure fallback while `idents` is empty- , ident <- head idents+ , (ident:_) <- idents -- Ensure fallback while `idents` is empty = Just ident -- fallback to using GHC suggestion even though it is not always correct | otherwise = Just IdentInfo- { name = mkVarOcc $ T.unpack binding- , rendered = binding+ { name = mkVarOrDataOcc binding , parent = Nothing- , isDatacon = False- , moduleNameText = mod}-#endif+ , identModuleName = mkModuleNameFS $ mkFastStringByteString $ T.encodeUtf8 mod} data HidingMode = HideOthers [ModuleTarget]@@ -1068,7 +1021,6 @@ isPreludeImplicit :: DynFlags -> Bool isPreludeImplicit = xopt Lang.ImplicitPrelude -#if !MIN_VERSION_ghc(9,3,0) -- | Suggests disambiguation for ambiguous symbols. suggestImportDisambiguation :: DynFlags ->@@ -1160,7 +1112,6 @@ <> "." <> symbol suggestImportDisambiguation _ _ _ _ _ = []-#endif occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool occursUnqualified symbol ImportDecl{..}@@ -1183,7 +1134,6 @@ targetModuleName (ExistingImp _) = error "Cannot happen!" -#if !MIN_VERSION_ghc(9,3,0) disambiguateSymbol :: Annotated ParsedSource -> T.Text ->@@ -1216,7 +1166,6 @@ liftParseAST @RdrName df $ T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr ]-#endif findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs@@ -1235,7 +1184,6 @@ in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] | otherwise = [] -#if !MIN_VERSION_ghc(9,3,0) -- | Suggests a constraint for a declaration for which a constraint is missing. suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..}@@ -1317,12 +1265,10 @@ [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) , appendConstraint (T.unpack implicitT) hsib_body)] | otherwise = []-#endif findTypeSignatureName :: T.Text -> Maybe T.Text findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head -#if !MIN_VERSION_ghc(9,3,0) -- | Suggests a constraint for a type signature with any number of existing constraints. suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1366,7 +1312,7 @@ -- | Suggests the removal of a redundant constraint for a type signature. removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..}+removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagnostic{..} -- • Redundant constraint: Eq a -- • In the type signature for: -- foo :: forall a. Eq a => a -> a@@ -1441,18 +1387,18 @@ _message "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", idents <-- maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $- Map.lookup methodName $ getExportsMap packageExportsMap =+ maybe [] (Set.toList . Set.filter (\x -> fmap occNameText (parent x) == Just className)) $+ lookupOccEnv (getExportsMap packageExportsMap) (mkVarOrDataOcc methodName) = mconcat $ suggest <$> idents | otherwise = [] where- suggest identInfo@IdentInfo {moduleNameText}+ suggest identInfo | importStyle <- NE.toList $ importStyles identInfo,- mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleNameText) =+ mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleText) = case mImportDecl of -- extend Just decl ->- [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText,+ [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleText, quickFixImportKind' "extend" style, [Right $ uncurry extendImport (unImportStyle style) decl] )@@ -1463,13 +1409,13 @@ | Just (range, indent) <- newImportInsertRange ps fileContents -> (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$>- [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False)+ [ (quickFixImportKind' "new" style, newUnqualImport moduleText rendered False) | style <- importStyle, let rendered = renderImportStyle style ]- <> [(quickFixImportKind "new.all", newImportAll moduleNameText)]+ <> [(quickFixImportKind "new.all", newImportAll moduleText)] | otherwise -> []-#endif+ where moduleText = moduleNameText identInfo suggestNewImport :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] suggestNewImport packageExportsMap ps fileContents Diagnostic{_message}@@ -1484,35 +1430,67 @@ , Just (range, indent) <- newImportInsertRange ps fileContents , extendImportSuggestions <- matchRegexUnifySpaces msg "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"- = sortOn fst3 [(imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))- | (kind, unNewImport -> imp) <- constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions- ]+ = let suggestions = nubSortBy simpleCompareImportSuggestion+ (constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions) in+ map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions where L _ HsModule {..} = astA ps suggestNewImport _ _ _ _ = [] constructNewImportSuggestions- :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)]-constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd+ :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [ImportSuggestion]+constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdBy simpleCompareImportSuggestion [ suggestion- | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing]- , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap)- , canUseIdent thingMissing identInfo- , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules- , suggestion <- renderNewImport identInfo+ | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] -- strip away qualified module names from the unknown name+ , identInfo <- maybe [] Set.toList $ (lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name)) <> (lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name)) -- look up the modified unknown name in the export map+ , canUseIdent thingMissing identInfo -- check if the identifier information retrieved can be used+ , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules -- check if the module of the identifier is allowed+ , suggestion <- renderNewImport identInfo -- creates a list of import suggestions for the retrieved identifier information ] where- renderNewImport :: IdentInfo -> [(CodeActionKind, NewImport)]+ renderNewImport :: IdentInfo -> [ImportSuggestion] renderNewImport identInfo | Just q <- qual- = [(quickFixImportKind "new.qualified", newQualImport m q)]+ = [ImportSuggestion importanceScore (quickFixImportKind "new.qualified") (newQualImport m q)] | otherwise- = [(quickFixImportKind' "new" importStyle, newUnqualImport m (renderImportStyle importStyle) False)+ = [ImportSuggestion importanceScore (quickFixImportKind' "new" importStyle) (newUnqualImport m (renderImportStyle importStyle) False) | importStyle <- NE.toList $ importStyles identInfo] ++- [(quickFixImportKind "new.all", newImportAll m)]+ [ImportSuggestion importanceScore (quickFixImportKind "new.all") (newImportAll m)] where+ -- The importance score takes 2 metrics into account. The first being the similarity using+ -- the Text.Fuzzy.Parallel.match function. The second is a factor of the relation between+ -- the modules prefix import suggestion and the unknown identifier names.+ importanceScore+ | Just q <- qual+ = let+ similarityScore = fromIntegral $ unpackMatchScore (TFP.match (T.toLower q) (T.toLower m)) :: Double+ (maxLength, minLength) = case (T.length q, T.length m) of+ (la, lb)+ | la >= lb -> (fromIntegral la, fromIntegral lb)+ | otherwise -> (fromIntegral lb, fromIntegral la)+ lengthPenaltyFactor = 100 * minLength / maxLength+ in max 0 (floor (similarityScore * lengthPenaltyFactor))+ | otherwise+ = 0+ where+ unpackMatchScore pScore+ | Just score <- pScore = score+ | otherwise = 0 m = moduleNameText identInfo +data ImportSuggestion = ImportSuggestion !Int !CodeActionKind !NewImport+ deriving ( Eq )++-- | Implements a lexicographic order for import suggestions that ignores the code action.+-- First it compares the importance score in DESCENDING order.+-- If the scores are equal it compares the import names alphabetical order.+--+-- TODO: this should be a correct Ord instance but CodeActionKind does not implement a Ord+-- which would lead to an unlawful Ord instance.+simpleCompareImportSuggestion :: ImportSuggestion -> ImportSuggestion -> Ordering+simpleCompareImportSuggestion (ImportSuggestion s1 _ i1) (ImportSuggestion s2 _ i2)+ = flip compare s1 s2 <> compare i1 i2+ newtype NewImport = NewImport {unNewImport :: T.Text} deriving (Show, Eq, Ord) @@ -1553,11 +1531,7 @@ -- | find line number right after module ... where findPositionAfterModuleName :: Annotated ParsedSource-#if MIN_VERSION_ghc(9,2,0) -> LocatedA ModuleName-#else- -> Located ModuleName-#endif -> Maybe Int findPositionAfterModuleName ps hsmodName' = do -- Note that 'where' keyword and comments are not part of the AST. They belongs to@@ -1578,7 +1552,7 @@ prevSrcSpan = maybe (getLoc hsmodName') getLoc hsmodExports -- The relative position of 'where' keyword (in lines, relative to the previous AST node).- -- The exact-print API changed a lot in ghc-9.2, so we need to handle it seperately for different compiler versions.+ -- The exact-print API changed a lot in ghc-9.2, so we need to handle it separately for different compiler versions. whereKeywordLineOffset :: Maybe Int #if MIN_VERSION_ghc(9,2,0) whereKeywordLineOffset = case hsmodAnn of@@ -1611,7 +1585,7 @@ deltaPos <- fmap NE.head . NE.nonEmpty .mapMaybe filterWhere $ annsDP ann pure $ deltaRow deltaPos - -- Before ghc 9.2, DeltaPos doesn't take comment into acccount, so we don't need to sum line offset of comments.+ -- Before ghc 9.2, DeltaPos doesn't take comment into account, so we don't need to sum line offset of comments. filterWhere :: (KeywordId, DeltaPos) -> Maybe DeltaPos filterWhere (keywordId, deltaPos) = if keywordId == G AnnWhere then Just deltaPos else Nothing@@ -1751,8 +1725,13 @@ extractDoesNotExportModuleName :: T.Text -> Maybe T.Text extractDoesNotExportModuleName x | Just [m] <-+#if MIN_VERSION_ghc(9,4,0)+ matchRegexUnifySpaces x "the module ‘([^’]*)’ does not export"+ <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ export"+#else matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports"+#endif = Just m | otherwise = Nothing@@ -1760,73 +1739,17 @@ mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit-mkRenameEdit contents range name =- if maybeIsInfixFunction == Just True- then TextEdit range ("`" <> name <> "`")- else TextEdit range name+mkRenameEdit contents range name+ | maybeIsInfixFunction == Just True = TextEdit range ("`" <> name <> "`")+ | maybeIsTemplateFunction == Just True = TextEdit range ("'" <> name)+ | otherwise = TextEdit range name where maybeIsInfixFunction = do curr <- textInRange range <$> contents pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr----- | Extract the type and surround it in parentheses except in obviously safe cases.------ Inferring when parentheses are actually needed around the type signature would--- require understanding both the precedence of the context of the hole and of--- the signature itself. Inserting them (almost) unconditionally is ugly but safe.-extractWildCardTypeSignature :: T.Text -> T.Text-extractWildCardTypeSignature msg- | enclosed || not isApp || isToplevelSig = sig- | otherwise = "(" <> sig <> ")"- where- msgSigPart = snd $ T.breakOnEnd "standing for " msg- (sig, rest) = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart- -- If we're completing something like ‘foo :: _’ parens can be safely omitted.- isToplevelSig = errorMessageRefersToToplevelHole rest- -- Parenthesize type applications, e.g. (Maybe Char).- isApp = T.any isSpace sig- -- Do not add extra parentheses to lists, tuples and already parenthesized types.- enclosed = not (T.null sig) && (T.head sig, T.last sig) `elem` [('(', ')'), ('[', ']')]---- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@.--- The former is considered toplevel case for which the function returns 'True',--- the latter is not toplevel and the returned value is 'False'.------ When type hole is at toplevel then there’s a line starting with--- "• In the type signature" which ends with " :: _" like in the--- following snippet:------ source/library/Language/Haskell/Brittany/Internal.hs:131:13: error:--- • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’--- To use the inferred type, enable PartialTypeSignatures--- • In the type signature: decl :: _--- In an equation for ‘splitAnnots’:--- splitAnnots m@HsModule {hsmodAnn, hsmodDecls}--- = undefined--- where--- ann :: SrcSpanAnnA--- decl :: _--- L ann decl = head hsmodDecls--- • Relevant bindings include--- [REDACTED]------ When type hole is not at toplevel there’s a stack of where--- the hole was located ending with "In the type signature":------ source/library/Language/Haskell/Brittany/Internal.hs:130:20: error:--- • Found type wildcard ‘_’ standing for ‘GhcPs’--- To use the inferred type, enable PartialTypeSignatures--- • In the first argument of ‘HsDecl’, namely ‘_’--- In the type ‘HsDecl _’--- In the type signature: decl :: HsDecl _--- • Relevant bindings include--- [REDACTED]-errorMessageRefersToToplevelHole :: T.Text -> Bool-errorMessageRefersToToplevelHole msg =- not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest- where- (prefix, rest) = T.breakOn "• In the type signature:" msg+ maybeIsTemplateFunction = do+ curr <- textInRange range <$> contents+ pure $ "'" `T.isPrefixOf` curr extractRenamableTerms :: T.Text -> [T.Text] extractRenamableTerms msg@@ -1915,7 +1838,19 @@ ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]-rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l]+#if !MIN_VERSION_ghc(9,2,0)+rangesForBinding' b (L (locA -> l) (IEVar _ nm))+ | L _ (IEPattern (L _ b')) <- nm+ , T.unpack (printOutputable b') == b+ = [l]+#else+rangesForBinding' b (L (locA -> l) (IEVar _ nm))+ | L _ (IEPattern _ (L _ b')) <- nm+ , T.unpack (printOutputable b') == b+ = [l]+#endif+rangesForBinding' b (L (locA -> l) x@IEVar{})+ | T.unpack (printOutputable x) == b = [l] rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l] rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] #if !MIN_VERSION_ghc(9,2,0)@@ -1931,29 +1866,16 @@ #endif rangesForBinding' _ _ = [] --- | 'matchRegex' combined with 'unifySpaces'-matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]-matchRegexUnifySpaces message = matchRegex (unifySpaces message)- -- | 'allMatchRegex' combined with 'unifySpaces' allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] allMatchRegexUnifySpaces message = allMatchRegex (unifySpaces message) --- | Returns Just (the submatches) for the first capture, or Nothing.-matchRegex :: T.Text -> T.Text -> Maybe [T.Text]-matchRegex message regex = case message =~~ regex of- Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings- Nothing -> Nothing- -- | Returns Just (all matches) for the first capture, or Nothing. allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] allMatchRegex message regex = message =~~ regex -unifySpaces :: T.Text -> T.Text-unifySpaces = T.unwords . T.words- -- functions to help parse multiple import suggestions -- | Returns the first match if found@@ -1991,72 +1913,3 @@ _ -> Nothing imps <- regExImports imports return (binding, imps)---- | Possible import styles for an 'IdentInfo'.------ The first 'Text' parameter corresponds to the 'rendered' field of the--- 'IdentInfo'.-data ImportStyle- = ImportTopLevel T.Text- -- ^ Import a top-level export from a module, e.g., a function, a type, a- -- class.- --- -- > import M (?)- --- -- Some exports that have a parent, like a type-class method or an- -- associated type/data family, can still be imported as a top-level- -- import.- --- -- Note that this is not the case for constructors, they must always be- -- imported as part of their parent data type.-- | ImportViaParent T.Text T.Text- -- ^ Import an export (first parameter) through its parent (second- -- parameter).- --- -- import M (P(?))- --- -- @P@ and @?@ can be a data type and a constructor, a class and a method,- -- a class and an associated type/data family, etc.-- | ImportAllConstructors T.Text- -- ^ Import all constructors for a specific data type.- --- -- import M (P(..))- --- -- @P@ can be a data type or a class.- deriving Show--importStyles :: IdentInfo -> NonEmpty ImportStyle-importStyles IdentInfo {parent, rendered, isDatacon}- | Just p <- parent- -- Constructors always have to be imported via their parent data type, but- -- methods and associated type/data families can also be imported as- -- top-level exports.- = ImportViaParent rendered p- :| [ImportTopLevel rendered | not isDatacon]- <> [ImportAllConstructors p]- | otherwise- = ImportTopLevel rendered :| []---- | Used for adding new imports-renderImportStyle :: ImportStyle -> T.Text-renderImportStyle (ImportTopLevel x) = x-renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"-renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"-renderImportStyle (ImportAllConstructors p) = p <> "(..)"---- | Used for extending import lists-unImportStyle :: ImportStyle -> (Maybe String, String)-unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x)-unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)-unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol)---quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind-quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel"-quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent"-quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors"--quickFixImportKind :: T.Text -> CodeActionKind-quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x
src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -13,9 +13,12 @@ where import Control.Concurrent.STM.Stats (readTVarIO)+import Control.Monad.Except (ExceptT (..),+ runExceptT) import Control.Monad.Reader import Control.Monad.Trans.Maybe-import Data.Either (fromRight)+import Data.Either (fromRight,+ partitionEithers) import qualified Data.HashMap.Strict as Map import Data.IORef.Extra import Data.Maybe (fromMaybe)@@ -26,10 +29,8 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint-#if !MIN_VERSION_ghc(9,3,0) import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, rewriteToEdit)-#endif import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), GlobalBindingTypeSigsResult) import Development.IDE.Spans.LocalBindings (Bindings)@@ -46,7 +47,7 @@ type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] -type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult+type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) GhcideCodeActionResult ------------------------------------------------------------------------------------------------- @@ -72,20 +73,20 @@ Just (_, txt) -> pure txt _ -> pure Nothing caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule-#if !MIN_VERSION_ghc(9,3,0) caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource-#endif caaTmr <- onceIO $ runRule TypeCheck caaHar <- onceIO $ runRule GetHieAst caaBindings <- onceIO $ runRule GetBindings caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs- liftIO $- concat- <$> sequence- [ runReaderT codeAction caa+ results <- liftIO $++ sequence+ [ runReaderT (runExceptT codeAction) caa | caaDiagnostic <- diags, let caa = CodeActionArgs {..} ]+ let (errs, successes) = partitionEithers results+ pure $ concat successes mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title kind isPreferred diags edit =@@ -117,7 +118,6 @@ instance ToTextEdit TextEdit where toTextEdit _ = pure . pure -#if !MIN_VERSION_ghc(9,3,0) instance ToTextEdit Rewrite where toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ runMaybeT $ do@@ -129,7 +129,6 @@ let r = rewriteToEdit df rw #endif pure $ fromRight [] r-#endif instance ToTextEdit a => ToTextEdit [a] where toTextEdit caa = foldMap (toTextEdit caa)@@ -149,11 +148,7 @@ caaParsedModule :: IO (Maybe ParsedModule), caaContents :: IO (Maybe T.Text), caaDf :: IO (Maybe DynFlags),-#if MIN_VERSION_ghc(9,3,0)- caaAnnSource :: IO (Maybe ParsedSource),-#else caaAnnSource :: IO (Maybe (Annotated ParsedSource)),-#endif caaTmr :: IO (Maybe TcModuleResult), caaHar :: IO (Maybe HieAstResult), caaBindings :: IO (Maybe Bindings),@@ -194,44 +189,49 @@ instance ToCodeAction a => ToCodeAction (Maybe a) where toCodeAction = maybe (pure []) toCodeAction +instance ToCodeAction a => ToCodeAction (Either ResponseError a) where+ toCodeAction = either (\err -> ExceptT $ ReaderT $ \_ -> pure $ Left err) toCodeAction+ instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where- toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te+ toCodeAction (title, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where- toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te+ toCodeAction (title, kind, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where- toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te+ toCodeAction (title, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where- toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te+ toCodeAction (title, kind, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te ------------------------------------------------------------------------------------------------- toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction-toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f+toCodeAction1 get f = ExceptT . ReaderT $ \caa -> do+ caaMay <- get caa+ flip runReaderT caa . runExceptT . toCodeAction . f $ caaMay toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction-toCodeAction2 get f = ReaderT $ \caa ->+toCodeAction2 get f = ExceptT . ReaderT $ \caa -> get caa >>= \case- Just x -> flip runReaderT caa . toCodeAction . f $ x- _ -> pure []+ Just x -> flip runReaderT caa . runExceptT . toCodeAction . f $ x+ _ -> pure $ Right [] toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction-toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f+toCodeAction3 get f = ExceptT . ReaderT $ \caa -> get caa >>= flip runReaderT caa . runExceptT . toCodeAction . f -- | this instance returns a delta AST, useful for exactprint transforms instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where #if !MIN_VERSION_ghc(9,3,0)- toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->+ toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> x >>= \case- Just s -> flip runReaderT caa . toCodeAction . f . astA $ s- _ -> pure []+ Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . astA $ s+ _ -> pure $ Right [] #else- toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} ->+ toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} -> x >>= \case- Just s -> flip runReaderT caa . toCodeAction . f . pm_parsed_source $ s- _ -> pure []+ Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . pm_parsed_source $ s+ _ -> pure $ Right [] #endif instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where@@ -241,7 +241,7 @@ toCodeAction = toCodeAction3 caaIdeOptions instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where- toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x+ toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where toCodeAction = toCodeAction1 caaParsedModule@@ -261,13 +261,11 @@ instance ToCodeAction r => ToCodeAction (DynFlags -> r) where toCodeAction = toCodeAction2 caaDf -#if !MIN_VERSION_ghc(9,3,0) instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where toCodeAction = toCodeAction1 caaAnnSource instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where toCodeAction = toCodeAction2 caaAnnSource-#endif instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where toCodeAction = toCodeAction1 caaTmr
src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -48,7 +48,8 @@ IsUnicodeSyntax (NormalSyntax), NameAdornment (NameParens), TrailingAnn (AddCommaAnn), addAnns, ann,- emptyComments, reAnnL)+ emptyComments, noSrcSpanA, reAnnL)+import Language.Haskell.GHC.ExactPrint.ExactPrint (makeDeltaAst, showAst) #else import Control.Applicative (Alternative ((<|>))) import Control.Monad.Extra (whenJust)@@ -62,6 +63,7 @@ KeywordId (G), mkAnnKey) #endif + ------------------------------------------------------------------------------ -- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the@@ -196,26 +198,30 @@ removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input" where go :: LHsType GhcPs -> Rewrite-#if !MIN_VERSION_ghc(9,2,0)- go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do-#else+#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,4,0) go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do+#else+ go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do #endif let ctxt' = filter (not . toRemove) ctxt removeStuff = (toRemove <$> headMaybe ctxt) == Just True-#if !MIN_VERSION_ghc(9,2,0)- when removeStuff $- setEntryDPT hst_body (DP (0, 0))- return $ L l $ it{hst_ctxt = L l' ctxt'}-#else+#if MIN_VERSION_ghc(9,2,0) let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body return $ case ctxt' of [] -> hst_body' _ -> do let ctxt'' = over _last (first removeComma) ctxt'+#if MIN_VERSION_ghc(9,4,0)+ L l $ it{ hst_ctxt = L l' ctxt''+#else L l $ it{ hst_ctxt = Just $ L l' ctxt''+#endif , hst_body = hst_body' }+#else+ when removeStuff $+ setEntryDPT hst_body (DP (0, 0))+ return $ L l $ it{hst_ctxt = L l' ctxt'} #endif go (L _ (HsParTy _ ty)) = go ty go (L _ HsForAllTy{hst_body}) = go hst_body@@ -231,10 +237,12 @@ Rewrite appendConstraint constraintT = go . traceAst "appendConstraint" where-#if !MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0) go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do-#else+#elif MIN_VERSION_ghc(9,2,0) go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do+#else+ go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do #endif constraint <- liftParseAST df constraintT #if !MIN_VERSION_ghc(9,2,0)@@ -258,8 +266,12 @@ [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close _ -> Nothing ctxt' = over _last (first addComma) $ map dropHsParTy ctxt+#if MIN_VERSION_ghc(9,4,0)+ return $ L l $ it{hst_ctxt = L l'' $ ctxt' ++ [constraint]}+#else return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]} #endif+#endif go (L _ HsForAllTy{hst_body}) = go hst_body go (L _ (HsParTy _ ty)) = go ty go ast@(L l _) = Rewrite (locA l) $ \df -> do@@ -267,7 +279,16 @@ constraint <- liftParseAST df constraintT lContext <- uniqueSrcSpanT lTop <- uniqueSrcSpanT-#if !MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,4,0)+ let context = reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]+#else+ let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]+#endif+ annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]+ needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint+ ast <- pure $ setEntryDP ast (SameLine 1)+#else let context = L lContext [constraint] addSimpleAnnT context dp00 $ (G AnnDarrow, DP (0, 1)) :@@ -277,11 +298,6 @@ ] | hsTypeNeedsParens sigPrec $ unLoc constraint ]-#else- let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]- annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]- needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint- ast <- pure $ setEntryDP ast (SameLine 1) #endif return $ reLocA $ L lTop $ HsQualTy noExtField context ast@@ -336,8 +352,16 @@ Rewrite (locA l) $ \df -> do case mparent of -- This will also work for `ImportAllConstructors`+#if !MIN_VERSION_ghc(9,2,0) Just parent -> extendImportViaParent df parent identifier lDecl _ -> extendImportTopLevel identifier lDecl+#else+ -- Parsed source in GHC 9.4 uses absolute position annotation (RealSrcSpan),+ -- while rewriting relies on relative positions. ghc-exactprint has the utility+ -- makeDeltaAst for relativization.+ Just parent -> extendImportViaParent df parent identifier (makeDeltaAst lDecl)+ _ -> extendImportTopLevel identifier (makeDeltaAst lDecl)+#endif -- | Add an identifier or a data type to import list. Expects a Delta AST --@@ -385,7 +409,7 @@ nodeHasComma x = isJust $ Map.lookup (mkAnnKey x) anns >>= find isAnnComma . annsDP when shouldAddTrailingComma (addTrailingCommaT x) - -- Parens are attachted to `lies`, so if `lies` was empty previously,+ -- Parens are attached to `lies`, so if `lies` was empty previously, -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ transferAnn (L l' lies) (L l' [x]) id@@ -435,7 +459,7 @@ childLIE = reLocA $ L srcChild $ IEName childRdr #if !MIN_VERSION_ghc(9,2,0) x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] []- -- take anns from ThingAbs, and attatch parens to it+ -- take anns from ThingAbs, and attach parens to it transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]} addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)] #else@@ -506,7 +530,7 @@ #else let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr') parentRdr' = modifyAnns parentRdr $ \case- it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1}+ it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1, nann_close = epl 0} other -> other childLIE = reLocA $ L srcChild $ IEName childRdr #endif@@ -518,7 +542,7 @@ addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)] addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))]- -- Parens are attachted to `pre`, so if `pre` was empty previously,+ -- Parens are attached to `pre`, so if `pre` was empty previously, -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ transferAnn (L l' $ reverse pre) (L l' [x]) id@@ -538,7 +562,7 @@ addCommaInImportList :: -- | Initial list [LocatedAn AnnListItem a]- -- | Additionnal item+ -- | Additional item -> LocatedAn AnnListItem a -> [LocatedAn AnnListItem a] addCommaInImportList lies x =
src/Development/IDE/Plugin/CodeAction/Util.hs view
@@ -1,23 +1,24 @@ module Development.IDE.Plugin.CodeAction.Util where -#if MIN_VERSION_ghc(9,2,0)-import GHC.Utils.Outputable-#else-import Development.IDE.GHC.Util-import Development.IDE.GHC.Compat.Util-import Development.IDE.GHC.Compat-#endif-import Data.Data (Data)-import qualified Data.Unique as U+import Data.Data (Data)+import Data.Time.Clock.POSIX (POSIXTime,+ getCurrentTime,+ utcTimeToPOSIXSeconds)+import qualified Data.Unique as U import Debug.Trace import Development.IDE.GHC.Compat.ExactPrint as GHC+import Development.IDE.GHC.Dump (showAstDataHtml) import GHC.Stack-import System.Environment.Blank (getEnvDefault)+import System.Environment.Blank (getEnvDefault) import System.IO.Unsafe import Text.Printf-import Development.IDE.GHC.Dump (showAstDataHtml)-import Data.Time.Clock.POSIX (POSIXTime, getCurrentTime,- utcTimeToPOSIXSeconds)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Utils.Outputable+#else+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util+import Development.IDE.GHC.Util+#endif -------------------------------------------------------------------------------- -- Tracing exactprint terms
+ src/Development/IDE/Plugin/Plugins/AddArgument.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Plugin.Plugins.AddArgument (plugin) where++#if MIN_VERSION_ghc(9,4,0)+import Development.IDE.GHC.ExactPrint (epl)+import GHC.Parser.Annotation (TokenLocation (..))+#endif+#if !MIN_VERSION_ghc(9,2,1)+import qualified Data.Text as T+import Language.LSP.Types+#else+import Control.Monad (join)+import Control.Monad.Except (lift)+import Data.Bifunctor (Bifunctor (..))+import Data.Either.Extra (maybeToEither)+import qualified Data.Text as T+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.ExactPrint (exactPrint,+ makeDeltaAst)+import Development.IDE.GHC.Error (spanContainsRange)+import Development.IDE.GHC.ExactPrint (genAnchor1,+ modifyMgMatchesT',+ modifySigWithM,+ modifySmallestDeclWithM)+import Development.IDE.Plugin.Plugins.Diagnostic+import GHC (EpAnn (..),+ SrcSpanAnn' (SrcSpanAnn),+ SrcSpanAnnA,+ SrcSpanAnnN,+ TrailingAnn (..),+ emptyComments,+ noAnn)+import GHC.Hs (IsUnicodeSyntax (..))+import GHC.Types.SrcLoc (generatedSrcSpan)+import Ide.PluginUtils (makeDiffTextEdit,+ responseError)+import Language.Haskell.GHC.ExactPrint (TransformT,+ noAnnSrcSpanDP1,+ runTransformT)+import Language.Haskell.GHC.ExactPrint.Transform (d1)+import Language.LSP.Types+#endif++#if !MIN_VERSION_ghc(9,2,1)+plugin :: [(T.Text, [TextEdit])]+plugin = []+#else+-- When GHC tells us that a variable is not bound, it will tell us either:+-- - there is an unbound variable with a given type+-- - there is an unbound variable (GHC provides no type suggestion)+--+-- When we receive either of these errors, we produce a text edit that will add a new argument (as a new pattern in the+-- last position of each LHS of the top-level bindings for this HsDecl).+--+-- NOTE When adding a new argument to a declaration, the corresponding argument's type in declaration's signature might+-- not be the last type in the signature, such as:+-- foo :: a -> b -> c -> d+-- foo a b = \c -> ...+-- In this case a new argument would have to add its type between b and c in the signature.+plugin :: ParsedModule -> Diagnostic -> Either ResponseError [(T.Text, [TextEdit])]+plugin parsedModule Diagnostic {_message, _range}+ | Just (name, typ) <- matchVariableNotInScope message = addArgumentAction parsedModule _range name typ+ | Just (name, typ) <- matchFoundHoleIncludeUnderscore message = addArgumentAction parsedModule _range name (Just typ)+ | otherwise = pure []+ where+ message = unifySpaces _message++-- Given a name for the new binding, add a new pattern to the match in the last position,+-- returning how many patterns there were in this match prior to the transformation:+-- addArgToMatch "foo" `bar arg1 arg2 = ...`+-- => (`bar arg1 arg2 foo = ...`, 2)+addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int)+addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) =+ let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name+ newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName)+ in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs), Prelude.length pats)++-- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind.+-- Also return:+-- - the declaration's name+-- - the number of bound patterns in the declaration's matches prior to the transformation+--+-- For example:+-- insertArg "new_pat" `foo bar baz = 1`+-- => (`foo bar baz new_pat = 1`, Just ("foo", 2))+appendFinalPatToMatches :: T.Text -> LHsDecl GhcPs -> TransformT (Either ResponseError) (LHsDecl GhcPs, Maybe (GenLocated SrcSpanAnnN RdrName, Int))+appendFinalPatToMatches name = \case+ (L locDecl (ValD xVal (FunBind xFunBind idFunBind mg coreFunBind))) -> do+ (mg', numPatsMay) <- modifyMgMatchesT' mg (pure . second Just . addArgToMatch name) Nothing combineMatchNumPats+ numPats <- lift $ maybeToEither (responseError "Unexpected empty match group in HsDecl") numPatsMay+ let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind))+ pure (decl', Just (idFunBind, numPats))+ decl -> pure (decl, Nothing)+ where+ combineMatchNumPats Nothing other = pure other+ combineMatchNumPats other Nothing = pure other+ combineMatchNumPats (Just l) (Just r)+ | l == r = pure (Just l)+ | otherwise = Left $ responseError "Unexpected different numbers of patterns in HsDecl MatchGroup"++-- The add argument works as follows:+-- 1. Attempt to add the given name as the last pattern of the declaration that contains `range`.+-- 2. If such a declaration exists, use that declaration's name to modify the signature of said declaration, if it+-- has a type signature.+--+-- NOTE For the following situation, the type signature is not updated (it's unclear what should happen):+-- type FunctionTySyn = () -> Int+-- foo :: FunctionTySyn+-- foo () = new_def+--+-- TODO instead of inserting a typed hole; use GHC's suggested type from the error+addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])]+addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do+ (newSource, _, _) <- runTransformT $ do+ (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc)+ case matchedDeclNameMay of+ Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc'+ Nothing -> pure moduleSrc'+ let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource)+ pure [("Add argument ‘" <> name <> "’ to function", fromLspList diff)]+ where+ addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg+ addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name++ spanContainsRangeOrErr = maybeToEither (responseError "SrcSpan was not valid range") . (`spanContainsRange` range)++-- Transform an LHsType into a list of arguments and return type, to make transformations easier.+hsTypeToFunTypeAsList :: LHsType GhcPs -> ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs)+hsTypeToFunTypeAsList = \case+ L spanAnnA (HsFunTy xFunTy arrow lhs rhs) ->+ let (rhsArgs, rhsRes) = hsTypeToFunTypeAsList rhs+ in ((spanAnnA, xFunTy, arrow, lhs):rhsArgs, rhsRes)+ ty -> ([], ty)++-- The inverse of `hsTypeToFunTypeAsList`+hsTypeFromFunTypeAsList :: ([(SrcSpanAnnA, XFunTy GhcPs, HsArrow GhcPs, LHsType GhcPs)], LHsType GhcPs) -> LHsType GhcPs+hsTypeFromFunTypeAsList (args, res) =+ foldr (\(spanAnnA, xFunTy, arrow, argTy) res -> L spanAnnA $ HsFunTy xFunTy arrow argTy res) res args++-- Add a typed hole to a type signature in the given argument position:+-- 0 `foo :: ()` => foo :: _ -> ()+-- 2 `foo :: FunctionTySyn` => foo :: FunctionTySyn+-- 1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int+addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs)+addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) =+ let (args, res) = hsTypeToFunTypeAsList lsigTy+#if MIN_VERSION_ghc(9,4,0)+ wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem []) emptyComments) generatedSrcSpan+ arrowAnn = TokenLoc (epl 1)+ newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow (L arrowAnn HsNormalTok), L wildCardAnn $ HsWildCardTy noExtField)+#else+ wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan+ newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField)+#endif+ -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments+ -- in the signature, then we return the original type signature.+ -- This situation most likely occurs due to a function type synonym in the signature+ insertArg n _ | n < 0 = error "Not possible"+ insertArg 0 as = newArg:as+ insertArg _ [] = []+ insertArg n (a:as) = a : insertArg (n - 1) as+ lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res)+ in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy')++fromLspList :: List a -> [a]+fromLspList (List a) = a+#endif
+ src/Development/IDE/Plugin/Plugins/Diagnostic.hs view
@@ -0,0 +1,53 @@+module Development.IDE.Plugin.Plugins.Diagnostic (+ matchVariableNotInScope,+ matchRegexUnifySpaces,+ unifySpaces,+ matchFoundHole,+ matchFoundHoleIncludeUnderscore,+ )+ where++import Data.Bifunctor (Bifunctor (..))+import qualified Data.Text as T+import Text.Regex.TDFA ((=~~))++unifySpaces :: T.Text -> T.Text+unifySpaces = T.unwords . T.words++-- | Returns Just (the submatches) for the first capture, or Nothing.+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]+matchRegex message regex = case message =~~ regex of+ Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings+ Nothing -> Nothing++-- | 'matchRegex' combined with 'unifySpaces'+matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]+matchRegexUnifySpaces message = matchRegex (unifySpaces message)++matchFoundHole :: T.Text -> Maybe (T.Text, T.Text)+matchFoundHole message+ | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" =+ Just (name, typ)+ | otherwise = Nothing++matchFoundHoleIncludeUnderscore :: T.Text -> Maybe (T.Text, T.Text)+matchFoundHoleIncludeUnderscore message = first ("_" <>) <$> matchFoundHole message++matchVariableNotInScope :: T.Text -> Maybe (T.Text, Maybe T.Text)+matchVariableNotInScope message+ -- * Variable not in scope:+ -- suggestAcion :: Maybe T.Text -> Range -> Range+ -- * Variable not in scope:+ -- suggestAcion+ | Just (name, typ) <- matchVariableNotInScopeTyped message = Just (name, Just typ)+ | Just name <- matchVariableNotInScopeUntyped message = Just (name, Nothing)+ | otherwise = Nothing+ where+ matchVariableNotInScopeTyped message+ | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" =+ Just (name, typ)+ | otherwise = Nothing+ matchVariableNotInScopeUntyped message+ | Just [name] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+)" =+ Just name+ | otherwise = Nothing
+ src/Development/IDE/Plugin/Plugins/FillHole.hs view
@@ -0,0 +1,104 @@+module Development.IDE.Plugin.Plugins.FillHole+ ( suggestFillHole+ ) where++import Control.Monad (guard)+import Data.Char+import qualified Data.Text as T+import Development.IDE.Plugin.Plugins.Diagnostic+import Language.LSP.Types (Diagnostic (..),+ TextEdit (TextEdit))+import Text.Regex.TDFA (MatchResult (..),+ (=~))++suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]+suggestFillHole Diagnostic{_range=_range,..}+ | Just holeName <- extractHoleName _message+ , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =+ let isInfixHole = _message =~ addBackticks holeName :: Bool in+ map (proposeHoleFit holeName False isInfixHole) holeFits+ ++ map (proposeHoleFit holeName True isInfixHole) refFits+ | otherwise = []+ where+ extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"+ addBackticks text = "`" <> text <> "`"+ addParens text = "(" <> text <> ")"+ proposeHoleFit holeName parenthise isInfixHole name =+ case T.uncons name of+ Nothing -> error "impossible: empty name provided by ghc"+ Just (firstChr, _) ->+ let isInfixOperator = firstChr == '('+ name' = getOperatorNotation isInfixHole isInfixOperator name in+ ( "replace " <> holeName <> " with " <> name+ , TextEdit _range (if parenthise then addParens name' else name')+ )+ getOperatorNotation True False name = addBackticks name+ getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name)+ getOperatorNotation _isInfixHole _isInfixOperator name = name+ headOrThrow msg = \case+ [] -> error msg+ (x:_) -> x++processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])+processHoleSuggestions mm = (holeSuggestions, refSuggestions)+{-+ • Found hole: _ :: LSP.Handlers++ Valid hole fits include def+ Valid refinement hole fits include+ fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)+ fromJust (_ :: Maybe LSP.Handlers)+ haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams+ LSP.Handlers)+ T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)+ (_ :: LSP.Handlers)+ (_ :: T.Text)+ T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)+ (_ :: LSP.Handlers)+ (_ :: T.Text)+-}+ where+ t = id @T.Text+ holeSuggestions = do+ -- get the text indented under Valid hole fits+ validHolesSection <-+ getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm+ -- the Valid hole fits line can contain a hole fit+ holeFitLine <-+ mapHead+ (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))+ validHolesSection+ let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine+ guard (not $ T.null holeFit)+ return holeFit+ refSuggestions = do -- @[]+ -- get the text indented under Valid refinement hole fits+ refinementSection <-+ getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm+ case refinementSection of+ [] -> error "GHC provided invalid hole fit options"+ (_:refinementSection) -> do+ -- get the text for each hole fit+ holeFitLines <- getIndentedGroups refinementSection+ let holeFit = T.strip $ T.unwords holeFitLines+ guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"+ return holeFit++ mapHead f (a:aa) = f a : aa+ mapHead _ [] = []++-- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]]+getIndentedGroups :: [T.Text] -> [[T.Text]]+getIndentedGroups [] = []+getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll+-- |+-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]]+getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]+getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of+ (l:ll) -> case span (\l' -> indentation l < indentation l') ll of+ (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest+ _ -> []++indentation :: T.Text -> Int+indentation = T.length . T.takeWhile isSpace+
+ src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs view
@@ -0,0 +1,78 @@+module Development.IDE.Plugin.Plugins.FillTypeWildcard+ ( suggestFillTypeWildcard+ ) where++import Data.Char+import qualified Data.Text as T+import Language.LSP.Types (Diagnostic (..), TextEdit (TextEdit))++suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]+suggestFillTypeWildcard Diagnostic{_range=_range,..}+-- Foo.hs:3:8: error:+-- * Found type wildcard `_' standing for `p -> p1 -> p'+ | "Found type wildcard" `T.isInfixOf` _message+ , " standing for " `T.isInfixOf` _message+ , typeSignature <- extractWildCardTypeSignature _message+ = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)]+ | otherwise = []++-- | Extract the type and surround it in parentheses except in obviously safe cases.+--+-- Inferring when parentheses are actually needed around the type signature would+-- require understanding both the precedence of the context of the hole and of+-- the signature itself. Inserting them (almost) unconditionally is ugly but safe.+extractWildCardTypeSignature :: T.Text -> T.Text+extractWildCardTypeSignature msg+ | enclosed || not isApp || isToplevelSig = sig+ | otherwise = "(" <> sig <> ")"+ where+ msgSigPart = snd $ T.breakOnEnd "standing for " msg+ (sig, rest) = T.span (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart+ -- If we're completing something like ‘foo :: _’ parens can be safely omitted.+ isToplevelSig = errorMessageRefersToToplevelHole rest+ -- Parenthesize type applications, e.g. (Maybe Char).+ isApp = T.any isSpace sig+ -- Do not add extra parentheses to lists, tuples and already parenthesized types.+ enclosed =+ case T.uncons sig of+ Nothing -> error "GHC provided invalid type"+ Just (firstChr, _) -> not (T.null sig) && (firstChr, T.last sig) `elem` [('(', ')'), ('[', ']')]++-- | Detect whether user wrote something like @foo :: _@ or @foo :: (_, Int)@.+-- The former is considered toplevel case for which the function returns 'True',+-- the latter is not toplevel and the returned value is 'False'.+--+-- When type hole is at toplevel then there’s a line starting with+-- "• In the type signature" which ends with " :: _" like in the+-- following snippet:+--+-- source/library/Language/Haskell/Brittany/Internal.hs:131:13: error:+-- • Found type wildcard ‘_’ standing for ‘HsDecl GhcPs’+-- To use the inferred type, enable PartialTypeSignatures+-- • In the type signature: decl :: _+-- In an equation for ‘splitAnnots’:+-- splitAnnots m@HsModule {hsmodAnn, hsmodDecls}+-- = undefined+-- where+-- ann :: SrcSpanAnnA+-- decl :: _+-- L ann decl = head hsmodDecls+-- • Relevant bindings include+-- [REDACTED]+--+-- When type hole is not at toplevel there’s a stack of where+-- the hole was located ending with "In the type signature":+--+-- source/library/Language/Haskell/Brittany/Internal.hs:130:20: error:+-- • Found type wildcard ‘_’ standing for ‘GhcPs’+-- To use the inferred type, enable PartialTypeSignatures+-- • In the first argument of ‘HsDecl’, namely ‘_’+-- In the type ‘HsDecl _’+-- In the type signature: decl :: HsDecl _+-- • Relevant bindings include+-- [REDACTED]+errorMessageRefersToToplevelHole :: T.Text -> Bool+errorMessageRefersToToplevelHole msg =+ not (T.null prefix) && " :: _" `T.isSuffixOf` T.takeWhile (/= '\n') rest+ where+ (prefix, rest) = T.breakOn "• In the type signature:" msg
+ src/Development/IDE/Plugin/Plugins/ImportUtils.hs view
@@ -0,0 +1,85 @@+module Development.IDE.Plugin.Plugins.ImportUtils+ ( ImportStyle(..),+ quickFixImportKind',+ quickFixImportKind,+ renderImportStyle,+ unImportStyle,+ importStyles+ ) where++import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Text as T+import Development.IDE.Plugin.CodeAction.ExactPrint (wildCardSymbol)+import Development.IDE.Types.Exports+import Language.LSP.Types (CodeActionKind (..))++-- | Possible import styles for an 'IdentInfo'.+--+-- The first 'Text' parameter corresponds to the 'rendered' field of the+-- 'IdentInfo'.+data ImportStyle+ = ImportTopLevel T.Text+ -- ^ Import a top-level export from a module, e.g., a function, a type, a+ -- class.+ --+ -- > import M (?)+ --+ -- Some exports that have a parent, like a type-class method or an+ -- associated type/data family, can still be imported as a top-level+ -- import.+ --+ -- Note that this is not the case for constructors, they must always be+ -- imported as part of their parent data type.++ | ImportViaParent T.Text T.Text+ -- ^ Import an export (first parameter) through its parent (second+ -- parameter).+ --+ -- import M (P(?))+ --+ -- @P@ and @?@ can be a data type and a constructor, a class and a method,+ -- a class and an associated type/data family, etc.++ | ImportAllConstructors T.Text+ -- ^ Import all constructors for a specific data type.+ --+ -- import M (P(..))+ --+ -- @P@ can be a data type or a class.+ deriving Show++importStyles :: IdentInfo -> NonEmpty ImportStyle+importStyles i@(IdentInfo {parent})+ | Just p <- pr+ -- Constructors always have to be imported via their parent data type, but+ -- methods and associated type/data families can also be imported as+ -- top-level exports.+ = ImportViaParent rend p+ :| [ImportTopLevel rend | not (isDatacon i)]+ <> [ImportAllConstructors p]+ | otherwise+ = ImportTopLevel rend :| []+ where rend = rendered i+ pr = occNameText <$> parent++-- | Used for adding new imports+renderImportStyle :: ImportStyle -> T.Text+renderImportStyle (ImportTopLevel x) = x+renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"+renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"+renderImportStyle (ImportAllConstructors p) = p <> "(..)"++-- | Used for extending import lists+unImportStyle :: ImportStyle -> (Maybe String, String)+unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x)+unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)+unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol)+++quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind+quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel"+quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent"+quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors"++quickFixImportKind :: T.Text -> CodeActionKind+quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x
test/Main.hs view
@@ -39,7 +39,6 @@ SemanticTokenRelative (length), SemanticTokensEdit (_start), mkRange)-import qualified Language.LSP.Types as LSP import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as L import System.Directory@@ -57,20 +56,25 @@ import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import Test.Hls +import Control.Applicative (liftA2) import qualified Development.IDE.Plugin.CodeAction as Refactor import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde+import qualified Test.AddArgument main :: IO () main = defaultTestRunner tests -refactorPlugin :: [PluginDescriptor IdeState]-refactorPlugin =- [ Refactor.iePluginDescriptor mempty "ghcide-code-actions-imports-exports"- , Refactor.typeSigsPluginDescriptor mempty "ghcide-code-actions-type-signatures"- , Refactor.bindingsPluginDescriptor mempty "ghcide-code-actions-bindings"- , Refactor.fillHolePluginDescriptor mempty "ghcide-code-actions-fill-holes"- , Refactor.extendImportPluginDescriptor mempty "ghcide-completions-1"- ] ++ GhcIde.descriptors mempty+refactorPlugin :: IO [PluginDescriptor IdeState]+refactorPlugin = do+ exactprintLog <- pluginTestRecorder+ ghcideLog <- pluginTestRecorder+ pure $+ [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports"+ , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures"+ , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings"+ , Refactor.fillHolePluginDescriptor exactprintLog "ghcide-code-actions-fill-holes"+ , Refactor.extendImportPluginDescriptor exactprintLog "ghcide-completions-1"+ ] ++ GhcIde.descriptors ghcideLog tests :: TestTree tests =@@ -99,7 +103,8 @@ doTest = do ir <- getInitializeResponse let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir- zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands+ -- Check if expected exists in commands. Note that commands can arrive in different order.+ mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected acquire :: IO (ResponseMessage Initialize) acquire = run initializeResponse@@ -213,19 +218,19 @@ "not imported" ["module A where", "import Text.Printf ()", "FormatParse"] (Position 2 10)- "FormatParse {"- ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]+ "FormatParse"+ ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] , completionCommandTest "parent imported" ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] (Position 2 10)- "FormatParse {"+ "FormatParse" ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] , completionNoCommandTest "already imported" ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] (Position 2 10)- "FormatParse {"+ "FormatParse" ] , testGroup "Package completion" [ completionCommandTest@@ -256,7 +261,8 @@ _ <- waitForDiagnostics compls <- skipManyTill anyMessage (getCompletions docId pos) let wantedC = find ( \case- CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x+ CompletionItem {_insertText = Just x+ ,_command = Just _} -> wanted `T.isPrefixOf` x _ -> False ) compls case wantedC of@@ -319,6 +325,9 @@ , exportUnusedTests , addImplicitParamsConstraintTests , removeExportTests+#if MIN_VERSION_ghc(9,2,1)+ , Test.AddArgument.tests+#endif ] insertImportTests :: TestTree@@ -465,12 +474,12 @@ "NoExplicitExports.expected.hs" "import Data.Monoid" , checkImport- "add to correctly placed exisiting import"+ "add to correctly placed existing import" "ImportAtTop.hs" "ImportAtTop.expected.hs" "import Data.Monoid" , checkImport- "add to multiple correctly placed exisiting imports"+ "add to multiple correctly placed existing imports" "MultipleImportsAtTop.hs" "MultipleImportsAtTop.expected.hs" "import Data.Monoid"@@ -599,7 +608,7 @@ doc <- createDoc "Testing.hs" "haskell" content _ <- waitForDiagnostics actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))- [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]+ [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle , "Replace" `T.isInfixOf` actionTitle] executeCodeAction fixTypo contentAfterAction <- documentContents doc let expectedContentAfterAction = T.unlines@@ -609,6 +618,28 @@ , "foo x y = x `monus` y" ] liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "change template function" $ do+ let content = T.unlines+ [ "{-# LANGUAGE TemplateHaskellQuotes #-}"+ , "module Testing where"+ , "import Language.Haskell.TH (Name)"+ , "foo :: Name"+ , "foo = 'bread"+ ]+ doc <- createDoc "Testing.hs" "haskell" content+ diags <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 4 6) (Position 4 12))+ [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "break" `T.isInfixOf` actionTitle ]+ executeCodeAction fixTypo+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "{-# LANGUAGE TemplateHaskellQuotes #-}"+ , "module Testing where"+ , "import Language.Haskell.TH (Name)"+ , "foo :: Name"+ , "foo = 'break"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction ] typeWildCardActionTests :: TestTree@@ -716,6 +747,7 @@ contentAfterAction <- documentContents doc liftIO $ expectedContentAfterAction @=? contentAfterAction + {-# HLINT ignore "Use nubOrd" #-} removeImportTests :: TestTree removeImportTests = testGroup "remove import actions"@@ -1261,7 +1293,8 @@ , "b :: A" , "b = ConstructorFoo" ])- , testSession "extend single line qualified import with value" $ template+ , ignoreForGHC94 "On GHC 9.4, the error messages with -fdefer-type-errors don't have necessary imported target srcspan info." $+ testSession "extend single line qualified import with value" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" , "stuffA :: Double"@@ -1432,7 +1465,7 @@ , "import A (pattern Some)" , "k (Some x) = x" ])- , ignoreForGHC92 "Diagnostic message has no suggestions" $+ , ignoreFor (BrokenForGHC [GHC92, GHC94]) "Diagnostic message has no suggestions" $ testSession "type constructor name same as data constructor name" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where"@@ -1485,7 +1518,7 @@ actionsOrCommands <- getCodeActions docB range let codeActions = filter- (T.isPrefixOf "Add" . codeActionTitle)+ (liftA2 (&&) (T.isPrefixOf "Add") (not . T.isPrefixOf "Add argument") . codeActionTitle) [ca | InR ca <- actionsOrCommands] actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the@@ -1636,8 +1669,10 @@ , test True [] "f = empty" [] "import Control.Applicative (empty)" , test True [] "f = empty" [] "import Control.Applicative" , test True [] "f = (&)" [] "import Data.Function ((&))"- , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"- , test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty"+ , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"+ $ test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"+ , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"+ $ test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" , test True [] "f = pack" [] "import Data.Text (pack)" , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"@@ -1645,15 +1680,18 @@ , test True [] "f = (&) [] id" [] "import Data.Function ((&))" , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))"- , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))"- , test True+ , test True [] "f :: a ~~ b" [] "import Data.Type.Equality ((~~))"+ , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"+ $ test True ["qualified Data.Text as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"- , test True+ , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"+ $ test True [ "qualified Data.Text as T" , "qualified Data.Function as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"- , test True+ , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"+ $ test True [ "qualified Data.Text as T" , "qualified Data.Function as T" , "qualified Data.Functor as T"@@ -1817,7 +1855,6 @@ auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"] withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do doc <- openDoc file "haskell"- waitForProgressDone void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] actions <- getAllCodeActions doc k dir doc actions@@ -1830,7 +1867,7 @@ [ testGroup "single" [ testOneCodeAction- "hide unsued"+ "hide unused" "Hide on from Data.Function" (1, 2) (1, 4)@@ -1843,7 +1880,7 @@ , "g on = on" ] , testOneCodeAction- "extend hiding unsued"+ "extend hiding unused" "Hide on from Data.Function" (1, 2) (1, 4)@@ -1854,7 +1891,7 @@ , "f on = on" ] , testOneCodeAction- "delete unsued"+ "delete unused" "Hide on from Data.Function" (1, 2) (1, 4)@@ -1956,7 +1993,7 @@ ] , testOneCodeAction "auto hide all"- "Hide ++ from all occurence imports"+ "Hide ++ from all occurrence imports" (2, 2) (2, 6) [ "import B"@@ -2025,7 +2062,7 @@ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _- <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>+ <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 0 0 0 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action@@ -2049,7 +2086,7 @@ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _- <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>+ <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 0 0 0 50) liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" executeCodeAction action@@ -2083,7 +2120,7 @@ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _- <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>+ <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 1 0 0 50) liftIO $ actionTitle @?= "Define select :: Int -> Bool" executeCodeAction action@@ -2109,14 +2146,38 @@ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) _ <- waitForDiagnostics InR action@CodeAction { _title = actionTitle } : _- <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>+ <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$> getCodeActions docB (R 1 0 0 50) liftIO $ actionTitle @?= "Define select :: Int -> Bool" executeCodeAction action contentAfterAction <- documentContents docB liftIO $ contentAfterAction @?= T.unlines expected+ , testSession "insert new function definition - untyped error" $ do+ let txtB =+ ["foo = select"+ ]+ txtB' =+ [""+ ,"someOtherCode = ()"+ ]+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')+ _ <- waitForDiagnostics+ InR action@CodeAction { _title = actionTitle } : _+ <- filter (\(InR CodeAction{_title=x}) -> "Define" `T.isPrefixOf` x) <$>+ getCodeActions docB (R 0 0 0 50)+ liftIO $ actionTitle @?= "Define select :: _"+ executeCodeAction action+ contentAfterAction <- documentContents docB+ liftIO $ contentAfterAction @?= T.unlines (txtB +++ [ ""+ , "select :: _"+ , "select = _"+ ]+ ++ txtB') ] +#if MIN_VERSION_ghc(9,2,1)+#endif deleteUnusedDefinitionTests :: TestTree deleteUnusedDefinitionTests = testGroup "delete unused definition action"@@ -2271,7 +2332,11 @@ , "" , "f = 1" ])+#if MIN_VERSION_ghc(9,4,0)+ [ (DsWarning, (3, 4), "Defaulting the type variable") ]+#else [ (DsWarning, (3, 4), "Defaulting the following constraint") ]+#endif "Add type annotation ‘Integer’ to ‘1’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A (f) where"@@ -2288,7 +2353,11 @@ , " let x = 3" , " in x" ])+#if MIN_VERSION_ghc(9,4,0)+ [ (DsWarning, (4, 12), "Defaulting the type variable") ]+#else [ (DsWarning, (4, 12), "Defaulting the following constraint") ]+#endif "Add type annotation ‘Integer’ to ‘3’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where"@@ -2306,7 +2375,11 @@ , " let x = let y = 5 in y" , " in x" ])+#if MIN_VERSION_ghc(9,4,0)+ [ (DsWarning, (4, 20), "Defaulting the type variable") ]+#else [ (DsWarning, (4, 20), "Defaulting the following constraint") ]+#endif "Add type annotation ‘Integer’ to ‘5’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where"@@ -2325,9 +2398,15 @@ , "" , "f = seq \"debug\" traceShow \"debug\"" ])+#if MIN_VERSION_ghc(9,4,0)+ [ (DsWarning, (6, 8), "Defaulting the type variable")+ , (DsWarning, (6, 16), "Defaulting the type variable")+ ]+#else [ (DsWarning, (6, 8), "Defaulting the following constraint") , (DsWarning, (6, 16), "Defaulting the following constraint") ]+#endif ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"@@ -2337,7 +2416,7 @@ , "" , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" ])- , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $+ , knownBrokenForGhcVersions [GHC92, GHC94] "GHC 9.2 only has 'traceShow' in error span" $ testSession "add default type to satisfy two constraints" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"@@ -2348,7 +2427,11 @@ , "" , "f a = traceShow \"debug\" a" ])+#if MIN_VERSION_ghc(9,4,0)+ [ (DsWarning, (6, 6), "Defaulting the type variable") ]+#else [ (DsWarning, (6, 6), "Defaulting the following constraint") ]+#endif ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"@@ -2358,7 +2441,7 @@ , "" , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" ])- , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $+ , knownBrokenForGhcVersions [GHC92, GHC94] "GHC 9.2 only has 'traceShow' in error span" $ testSession "add default type to satisfy two constraints with duplicate literals" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"@@ -2369,7 +2452,11 @@ , "" , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ])+#if MIN_VERSION_ghc(9,4,0)+ [ (DsWarning, (6, 54), "Defaulting the type variable") ]+#else [ (DsWarning, (6, 54), "Defaulting the following constraint") ]+#endif ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"@@ -2986,15 +3073,15 @@ "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" (typeSignatureSpaces $ Just "Monoid a, Show a") (typeSignatureSpaces Nothing)- , check+ , check "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" typeSignatureLined1 typeSignatureOneLine- , check+ , check "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" typeSignatureLined2 typeSignatureOneLine- , check+ , check "Remove redundant constraint `Show a` from the context of the type signature for `foo`" typeSignatureLined3 typeSignatureLined3'@@ -3064,7 +3151,7 @@ (R 2 0 2 11) "Export ‘bar’" Nothing- , ignoreForGHC92 "Diagnostic message has no suggestions" $+ , ignoreFor (BrokenForGHC [GHC92, GHC94]) "Diagnostic message has no suggestions" $ testSession "type is exported but not the constructor of same name" $ template (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"@@ -3680,7 +3767,9 @@ run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a-runInDir dir = runSessionWithServer' refactorPlugin def def lspTestCaps dir+runInDir dir act = do+ plugin <- refactorPlugin+ runSessionWithServer' plugin def def lspTestCaps dir act lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }@@ -3699,6 +3788,9 @@ ignoreForGHC92 :: String -> TestTree -> TestTree ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92]) +ignoreForGHC94 :: String -> TestTree -> TestTree+ignoreForGHC94 = knownIssueFor Broken (BrokenForGHC [GHC94])+ data BrokenTarget = BrokenSpecific OS [GhcVersion] -- ^Broken for `BrokenOS` with `GhcVersion`@@ -3744,4 +3836,3 @@ listOfChar :: T.Text listOfChar | ghcVersion >= GHC90 = "String" | otherwise = "[Char]"-
+ test/Test/AddArgument.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}++module Test.AddArgument (tests) where++import Data.List.Extra+import qualified Data.Text as T+import Development.IDE.Types.Location+import Language.LSP.Test+import Language.LSP.Types hiding+ (SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length),+ SemanticTokensEdit (_start),+ mkRange)+import Test.Tasty+import Test.Tasty.HUnit+++import Test.Hls++import qualified Development.IDE.Plugin.CodeAction as Refactor++tests :: TestTree+tests =+ testGroup+ "add argument"+#if !MIN_VERSION_ghc(9,2,1)+ []+#else+ [ mkGoldenAddArgTest' "Hole" (r 0 0 0 50) "_new_def",+ mkGoldenAddArgTest "NoTypeSuggestion" (r 0 0 0 50),+ mkGoldenAddArgTest "MultipleDeclAlts" (r 0 0 0 50),+ mkGoldenAddArgTest "AddArgWithSig" (r 1 0 1 50),+ mkGoldenAddArgTest "AddArgWithSigAndDocs" (r 8 0 8 50),+ mkGoldenAddArgTest "AddArgFromLet" (r 2 0 2 50),+ mkGoldenAddArgTest "AddArgFromWhere" (r 3 0 3 50),+ mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50),+ mkGoldenAddArgTest "AddArgWithTypeSynSig" (r 2 0 2 50),+ mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (r 2 0 2 50),+ mkGoldenAddArgTest "AddArgWithLambda" (r 1 0 1 50),+ mkGoldenAddArgTest "MultiSigFirst" (r 2 0 2 50),+ mkGoldenAddArgTest "MultiSigLast" (r 2 0 2 50),+ mkGoldenAddArgTest "MultiSigMiddle" (r 2 0 2 50)+ ]+ where+ r x y x' y' = Range (Position x y) (Position x' y')++mkGoldenAddArgTest :: FilePath -> Range -> TestTree+mkGoldenAddArgTest testFileName range = mkGoldenAddArgTest' testFileName range "new_def"++-- Make a golden test for the add argument action. Given varName is the name of the variable not yet defined.+mkGoldenAddArgTest' :: FilePath -> Range -> T.Text -> TestTree+mkGoldenAddArgTest' testFileName range varName = do+ let action docB = do+ _ <- waitForDiagnostics+ InR action@CodeAction {_title = actionTitle} : _ <-+ filter (\(InR CodeAction {_title = x}) -> "Add" `isPrefixOf` T.unpack x)+ <$> getCodeActions docB range+ liftIO $ actionTitle @?= ("Add argument ‘" <> varName <> "’ to function")+ executeCodeAction action+ goldenWithHaskellDoc+ (mkPluginTestDescriptor Refactor.bindingsPluginDescriptor "ghcide-code-actions-bindings")+ (testFileName <> " (golden)")+ "test/data/golden/add-arg"+ testFileName+ "expected"+ "hs"+ action+#endif
+ test/data/golden/add-arg/AddArgFromLet.expected.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> _ -> Int+foo True new_def =+ let bar = new_def+ in bar++foo False new_def = 1
+ test/data/golden/add-arg/AddArgFromLet.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> Int+foo True =+ let bar = new_def+ in bar++foo False = 1
+ test/data/golden/add-arg/AddArgFromWhere.expected.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> _ -> Int+foo True new_def = bar+ where+ bar = new_def++foo False new_def = 1
+ test/data/golden/add-arg/AddArgFromWhere.hs view
@@ -0,0 +1,6 @@+foo :: Bool -> Int+foo True = bar+ where+ bar = new_def++foo False = 1
+ test/data/golden/add-arg/AddArgFromWhereComments.expected.hs view
@@ -0,0 +1,6 @@+foo -- c1+ -- | c2+ {- c3 -} True new_def -- c4+ = new_def++foo False new_def = False
+ test/data/golden/add-arg/AddArgFromWhereComments.hs view
@@ -0,0 +1,6 @@+foo -- c1+ -- | c2+ {- c3 -} True -- c4+ = new_def++foo False = False
+ test/data/golden/add-arg/AddArgWithLambda.expected.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> _ -> () -> Int+foo True new_def = \() -> new_def [True]++foo False new_def = const 1
+ test/data/golden/add-arg/AddArgWithLambda.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> () -> Int+foo True = \() -> new_def [True]++foo False = const 1
+ test/data/golden/add-arg/AddArgWithSig.expected.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> _ -> Int+foo True new_def = new_def [True]++foo False new_def = 1
+ test/data/golden/add-arg/AddArgWithSig.hs view
@@ -0,0 +1,4 @@+foo :: Bool -> Int+foo True = new_def [True]++foo False = 1
+ test/data/golden/add-arg/AddArgWithSigAndDocs.expected.hs view
@@ -0,0 +1,11 @@+foo ::+ -- c1+ Bool -- c2+ -- c3+ -> -- c4+ -- | c5+ () -- c6+ -> _ -> Int+foo True () new_def = new_def [True]++foo False () new_def = 1
+ test/data/golden/add-arg/AddArgWithSigAndDocs.hs view
@@ -0,0 +1,11 @@+foo ::+ -- c1+ Bool -- c2+ -- c3+ -> -- c4+ -- | c5+ () -- c6+ -> Int+foo True () = new_def [True]++foo False () = 1
+ test/data/golden/add-arg/AddArgWithTypeSynSig.expected.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn+foo True new_def = new_def [True]++foo False new_def = 1
+ test/data/golden/add-arg/AddArgWithTypeSynSig.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn+foo True = new_def [True]++foo False = 1
+ test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.expected.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn -> () -> _ -> Int+foo True () new_def = new_def [True]++foo False () new_def = 1
+ test/data/golden/add-arg/AddArgWithTypeSynSigContravariant.hs view
@@ -0,0 +1,5 @@+type FunctionTySyn = Bool -> Int+foo :: FunctionTySyn -> () -> Int+foo True () = new_def [True]++foo False () = 1
+ test/data/golden/add-arg/Hole.expected.hs view
@@ -0,0 +1,1 @@+foo _new_def = _new_def
+ test/data/golden/add-arg/Hole.hs view
@@ -0,0 +1,1 @@+foo = _new_def
+ test/data/golden/add-arg/MultiSigFirst.expected.hs view
@@ -0,0 +1,6 @@+bar :: Bool -> Int+foo :: Bool -> _ -> Int+bar = const 1+foo True new_def = new_def [True]++foo False new_def = 1
+ test/data/golden/add-arg/MultiSigFirst.hs view
@@ -0,0 +1,5 @@+foo, bar :: Bool -> Int+bar = const 1+foo True = new_def [True]++foo False = 1
+ test/data/golden/add-arg/MultiSigLast.expected.hs view
@@ -0,0 +1,7 @@+baz, bar :: Bool -> Int+foo :: Bool -> _ -> Int+bar = const 1+foo True new_def = new_def [True]++foo False new_def = 1+baz = 1
+ test/data/golden/add-arg/MultiSigLast.hs view
@@ -0,0 +1,6 @@+baz, bar, foo :: Bool -> Int+bar = const 1+foo True = new_def [True]++foo False = 1+baz = 1
+ test/data/golden/add-arg/MultiSigMiddle.expected.hs view
@@ -0,0 +1,7 @@+baz, bar :: Bool -> Int+foo :: Bool -> _ -> Int+bar = const 1+foo True new_def = new_def [True]++foo False new_def = 1+baz = 1
+ test/data/golden/add-arg/MultiSigMiddle.hs view
@@ -0,0 +1,6 @@+baz, foo, bar :: Bool -> Int+bar = const 1+foo True = new_def [True]++foo False = 1+baz = 1
+ test/data/golden/add-arg/MultipleDeclAlts.expected.hs view
@@ -0,0 +1,2 @@+foo True new_def = new_def+foo False new_def = 1
+ test/data/golden/add-arg/MultipleDeclAlts.hs view
@@ -0,0 +1,2 @@+foo True = new_def+foo False = 1
+ test/data/golden/add-arg/NoTypeSuggestion.expected.hs view
@@ -0,0 +1,1 @@+foo new_def = new_def
+ test/data/golden/add-arg/NoTypeSuggestion.hs view
@@ -0,0 +1,1 @@+foo = new_def
test/data/hiding/hie.yaml view
@@ -2,7 +2,6 @@ direct: arguments: - -Wall- - HideFunction.hs - AVec.hs - BVec.hs - CVec.hs