From 8cf63104d88e0bc5b31b6b5f669ebf1118faa79b Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 01:46:32 +0100 Subject: [PATCH 1/7] inline definition --- .../hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 112dc3a6ca..cf1bb4e881 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -85,6 +85,7 @@ import Control.Lens.Operators ((%~)) import Data.List (partition) import GHC (DeltaPos (..), SrcSpanAnnN) +import GHC.Driver.DynFlags (initSDocContext) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -749,7 +750,7 @@ annotateDecl dflags ast = do -- | Print out something 'Outputable'. render :: Outputable a => DynFlags -> a -> String -render dflags = showSDoc dflags . ppr +render dflags = renderWithContext (initSDocContext dflags defaultUserStyle) . ppr ------------------------------------------------------------------------------ From d6492e6e3010898ae4b85e343a282587582b2fa2 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 02:24:09 +0100 Subject: [PATCH 2/7] test --- plugins/hls-splice-plugin/test/Main.hs | 1 + plugins/hls-splice-plugin/test/testdata/Q.hs | 44 +++++++++++++++++++ .../testdata/TDeclUnqualified.expected.hs | 11 +++++ .../test/testdata/TDeclUnqualified.hs | 9 ++++ 4 files changed, 65 insertions(+) create mode 100644 plugins/hls-splice-plugin/test/testdata/Q.hs create mode 100644 plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs create mode 100644 plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.hs diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 7a1c36fc6a..aa40a93a8c 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -61,6 +61,7 @@ tests = testGroup "splice" , goldenTest "TDeclInstance" Inplace 5 1 , goldenTest "TDeclPatSyn" Inplace 6 1 , goldenTest "TDeclPragma" Inplace 5 1 + , goldenTest "TDeclUnqualified" Inplace 9 1 ] , goldenTestWithEdit "TTypeKindError" ( if ghcVersion >= GHC96 then diff --git a/plugins/hls-splice-plugin/test/testdata/Q.hs b/plugins/hls-splice-plugin/test/testdata/Q.hs new file mode 100644 index 0000000000..1fa50a13b7 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/Q.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Q where + +import Data.Maybe +import Data.Ord +import Data.String +import Language.Haskell.TH + +q :: Q [Dec] +q = do + let dName = mkName "D" + dataDec <- + dataD + (pure []) + dName + [] + Nothing + [normalC dName []] + [] + isStringDec <- + instanceD + (pure []) + (appT (conT ''IsString) (conT dName)) + [ funD + 'fromString + [ clause + [varP (mkName "s")] + ( normalB + ( appE + (appE (varE 'fromMaybe) (conE dName)) + ( infixE + (Just (conE dName)) + (varE '(<$)) + ( Just + (appE (conE 'Just) (appE (conE 'Down) (litE (integerL 1)))) + ) + ) + ) + ) + [] + ] + ] + pure [dataDec, isStringDec] diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs new file mode 100644 index 0000000000..9515bb1300 --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TDeclUnqualified where + +import Data.Maybe +import Data.String qualified +import Q + +data D = D +instance IsString D where + fromString s = fromMaybe D (D <$ Just (Down 1)) diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.hs b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.hs new file mode 100644 index 0000000000..569ee440fd --- /dev/null +++ b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TDeclUnqualified where + +import Data.Maybe +import Data.String qualified +import Q + +$(q) From 65da0dbf09c45c4010591419172ca2ceb854f6f1 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 02:31:46 +0100 Subject: [PATCH 3/7] always qualify --- .../src/Development/IDE/GHC/ExactPrint.hs | 3 ++- .../test/testdata/TDeclUnqualified.expected.hs | 8 ++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index cf1bb4e881..c0bb0ddf80 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -86,6 +86,7 @@ import Data.List (partition) import GHC (DeltaPos (..), SrcSpanAnnN) import GHC.Driver.DynFlags (initSDocContext) +import GHC.Utils.Outputable (alwaysQualify, mkUserStyle, Depth (..)) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -750,7 +751,7 @@ annotateDecl dflags ast = do -- | Print out something 'Outputable'. render :: Outputable a => DynFlags -> a -> String -render dflags = renderWithContext (initSDocContext dflags defaultUserStyle) . ppr +render dflags = renderWithContext (initSDocContext dflags (mkUserStyle alwaysQualify AllTheWay)) . ppr ------------------------------------------------------------------------------ diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs index 9515bb1300..8e7a31a248 100644 --- a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs +++ b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs @@ -7,5 +7,9 @@ import Data.String qualified import Q data D = D -instance IsString D where - fromString s = fromMaybe D (D <$ Just (Down 1)) +instance GHC.Internal.Data.String.IsString D where + GHC.Internal.Data.String.fromString s + = GHC.Internal.Data.Maybe.fromMaybe + D + (D GHC.Internal.Base.<$ + GHC.Internal.Maybe.Just (GHC.Internal.Data.Ord.Down 1)) From 0042f64435717b198320672a461f527a95855fc8 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 01:48:14 +0100 Subject: [PATCH 4/7] plumbing --- .../src/Development/IDE/GHC/ExactPrint.hs | 61 ++++++++++--------- .../src/Ide/Plugin/Splice.hs | 10 ++- 2 files changed, 39 insertions(+), 32 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index c0bb0ddf80..86cb117170 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -84,6 +84,7 @@ import Control.Lens (_last, (&)) import Control.Lens.Operators ((%~)) import Data.List (partition) import GHC (DeltaPos (..), + NamePprCtx, SrcSpanAnnN) import GHC.Driver.DynFlags (initSDocContext) import GHC.Utils.Outputable (alwaysQualify, mkUserStyle, Depth (..)) @@ -180,7 +181,7 @@ type Anchor = EpaLocation instance to combine 'Graft's, and run them via 'transform'. -} newtype Graft m a = Graft - { runGraft :: DynFlags -> a -> TransformT m a + { runGraft :: (DynFlags, NamePprCtx) -> a -> TransformT m a } hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a @@ -222,14 +223,15 @@ instance Monad m => Monoid (Graft m a) where -- | Convert a 'Graft' into a 'WorkspaceEdit'. transform :: DynFlags -> + NamePprCtx -> ClientCapabilities -> VersionedTextDocumentIdentifier -> Graft (Either String) ParsedSource -> ParsedSource -> Either String WorkspaceEdit -transform dflags ccs verTxtDocId f a = do +transform dflags npc ccs verTxtDocId f a = do let src = printA a - a' <- transformA a $ runGraft f dflags + a' <- transformA a $ runGraft f (dflags, npc) let res = printA a' pure $ diffText ccs (verTxtDocId, T.pack src) (T.pack res) IncludeDeletions @@ -239,15 +241,16 @@ transform dflags ccs verTxtDocId f a = do transformM :: Monad m => DynFlags -> + NamePprCtx -> ClientCapabilities -> VersionedTextDocumentIdentifier -> Graft (ExceptStringT m) ParsedSource -> ParsedSource -> m (Either String WorkspaceEdit) -transformM dflags ccs verTextDocId f a = runExceptT $ +transformM dflags npc ccs verTextDocId f a = runExceptT $ runExceptString $ do let src = printA a - a' <- transformA a $ runGraft f dflags + a' <- transformA a $ runGraft f (dflags, npc) let res = printA a' pure $ diffText ccs (verTextDocId, T.pack src) (T.pack res) IncludeDeletions @@ -302,8 +305,8 @@ graft' :: SrcSpan -> LocatedAn l ast -> Graft (Either String) a -graft' needs_space dst val = Graft $ \dflags a -> do - val' <- annotate dflags needs_space dst val +graft' needs_space dst val = Graft $ \(dflags, npc) a -> do + val' <- annotate dflags npc needs_space dst val pure $ everywhere' ( mkT $ @@ -323,12 +326,12 @@ graftExpr :: SrcSpan -> LHsExpr GhcPs -> Graft (Either String) a -graftExpr dst val = Graft $ \dflags a -> do +graftExpr dst val = Graft $ \(dflags, npc) a -> do let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a runGraft (graft' needs_space dst $ mk_parens val) - dflags + (dflags, npc) a getNeedsSpaceAndParenthesize :: @@ -360,7 +363,7 @@ graftExprWithM :: SrcSpan -> (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> Graft m a -graftExprWithM dst trans = Graft $ \dflags a -> do +graftExprWithM dst trans = Graft $ \(dflags, npc) a -> do let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a everywhereM' @@ -373,7 +376,7 @@ graftExprWithM dst trans = Graft $ \dflags a -> do Just val' -> do val'' <- hoistTransform (either Fail.fail pure) - (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space dst (mk_parens val')) + (annotate @AnnListItem @(HsExpr GhcPs) dflags npc needs_space dst (mk_parens val')) pure val'' Nothing -> pure val l -> pure l @@ -386,7 +389,7 @@ graftWithM :: SrcSpan -> (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) -> Graft m a -graftWithM dst trans = Graft $ \dflags a -> do +graftWithM dst trans = Graft $ \(dflags, npc) a -> do everywhereM' ( mkM $ \case @@ -397,7 +400,7 @@ graftWithM dst trans = Graft $ \dflags a -> do Just val' -> do val'' <- hoistTransform (either Fail.fail pure) $ - annotate dflags False dst $ maybeParensAST val' + annotate dflags npc False dst $ maybeParensAST val' pure val'' Nothing -> pure val l -> pure l @@ -414,7 +417,7 @@ genericGraftWithSmallestM :: SrcSpan -> (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a -genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> +genericGraftWithSmallestM proxy dst trans = Graft $ \(dflags, _) -> smallestM (genericIsSubspan proxy dst) (trans dflags) -- | Run the given transformation only on the largest node in the tree that @@ -427,7 +430,7 @@ genericGraftWithLargestM :: SrcSpan -> (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a -genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> +genericGraftWithLargestM proxy dst trans = Graft $ \(dflags, _) -> largestM (genericIsSubspan proxy dst) (trans dflags) @@ -437,9 +440,9 @@ graftDecls :: SrcSpan -> [LHsDecl GhcPs] -> Graft (Either String) a -graftDecls dst decs0 = Graft $ \dflags a -> do +graftDecls dst decs0 = Graft $ \(dflags, npc) a -> do decs <- forM decs0 $ \decl -> do - annotateDecl dflags decl + annotateDecl dflags npc decl let go [] = DL.empty go (L src e : rest) | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest @@ -630,13 +633,13 @@ graftSmallestDeclsWithM :: SrcSpan -> (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> Graft (Either String) a -graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do +graftSmallestDeclsWithM dst toDecls = Graft $ \(dflags, npc) a -> do let go [] = pure DL.empty go (e@(L src _) : rest) | dst `isSubspanOf` locA src = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> - annotateDecl dflags decl + annotateDecl dflags npc decl pure $ DL.fromList decs <> DL.fromList rest Nothing -> (DL.singleton e <>) <$> go rest | otherwise = (DL.singleton e <>) <$> go rest @@ -648,14 +651,14 @@ graftDeclsWithM :: SrcSpan -> (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> Graft m a -graftDeclsWithM dst toDecls = Graft $ \dflags a -> do +graftDeclsWithM dst toDecls = Graft $ \(dflags, npc) a -> do let go [] = pure DL.empty go (e@(L src _) : rest) | locA src `eqSrcSpan` dst = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> hoistTransform (either Fail.fail pure) $ - annotateDecl dflags decl + annotateDecl dflags npc decl pure $ DL.fromList decs <> DL.fromList rest Nothing -> (DL.singleton e <>) <$> go rest | otherwise = (DL.singleton e <>) <$> go rest @@ -722,10 +725,10 @@ instance ASTElement NameAnn RdrName where -- | Given an 'LHSExpr', compute its exactprint annotations. -- Note that this function will throw away any existing annotations (and format) annotate :: ASTElement l ast - => DynFlags -> Bool -> SrcSpan -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast) -annotate dflags _needs_space _loc ast = do + => DynFlags -> NamePprCtx -> Bool -> SrcSpan -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast) +annotate dflags npc _needs_space _loc ast = do uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast + let rendered = render dflags npc ast expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered #if MIN_VERSION_ghc(9,9,0) let L l e = makeDeltaAst expr' @@ -735,10 +738,10 @@ annotate dflags _needs_space _loc ast = do #endif -- | Given an 'LHsDecl', compute its exactprint annotations. -annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) -annotateDecl dflags ast = do +annotateDecl :: DynFlags -> NamePprCtx -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) +annotateDecl dflags npc ast = do uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast + let rendered = render dflags npc ast expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered #if MIN_VERSION_ghc(9,9,0) let expr'' = makeDeltaAst expr' @@ -750,8 +753,8 @@ annotateDecl dflags ast = do ------------------------------------------------------------------------------ -- | Print out something 'Outputable'. -render :: Outputable a => DynFlags -> a -> String -render dflags = renderWithContext (initSDocContext dflags (mkUserStyle alwaysQualify AllTheWay)) . ppr +render :: Outputable a => DynFlags -> NamePprCtx -> a -> String +render dflags npc = renderWithContext (initSDocContext dflags (mkUserStyle alwaysQualify AllTheWay)) . ppr ------------------------------------------------------------------------------ diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 94930665ac..4139ebc300 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -129,7 +129,7 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do params withTypeChecked fp TcModuleResult {..} = do - (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + (ps, hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed let Splices {..} = tmrTopLevelSplices let exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices @@ -139,6 +139,7 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do listToMaybe $ findSubSpansDesc srcSpan typeSplices declSuperSpans = listToMaybe $ findSubSpansDesc srcSpan declSplices + prUnqual = mkPrintUnqualifiedDefault hscEnv $ tcg_rdr_env tmrTypechecked graftSpliceWith :: forall ast. @@ -149,6 +150,7 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do expandeds <&> \(_, expanded) -> transform dflags + prUnqual clientCapabilities verTxtDocId (graft (RealSrcSpan spliceSpan Nothing) expanded) @@ -165,6 +167,7 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do declSuperSpans <&> \(_, expanded) -> transform dflags + prUnqual clientCapabilities verTxtDocId (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) @@ -362,7 +365,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e initTcWithGbl hscEnv typechkd srcSpan $ case classifyAST spliceContext of IsHsDecl -> fmap (fmap $ adjustToRange (verTxtDocId ^. J.uri) ran) $ - flip (transformM dflags clientCapabilities verTxtDocId) ps $ + flip (transformM dflags prUnqual clientCapabilities verTxtDocId) ps $ graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- @@ -375,7 +378,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e pure $ Just eExpr _ -> pure Nothing OneToOneAST astP -> - flip (transformM dflags clientCapabilities verTxtDocId) ps $ + flip (transformM dflags prUnqual clientCapabilities verTxtDocId) ps $ graftWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- @@ -404,6 +407,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e ] pure resl where + prUnqual = mkPrintUnqualifiedDefault hscEnv (tcg_rdr_env typechkd) dflags = hsc_dflags hscEnv showErrors = showBag From 7e154e5e091159f2193c127c332b03fcbec2472f Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 01:50:25 +0100 Subject: [PATCH 5/7] actually use the printer context --- .../src/Development/IDE/GHC/ExactPrint.hs | 4 ++-- .../test/testdata/TDeclUnqualified.expected.hs | 9 +++------ 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 86cb117170..fde897f8ed 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -87,7 +87,7 @@ import GHC (DeltaPos (..), NamePprCtx, SrcSpanAnnN) import GHC.Driver.DynFlags (initSDocContext) -import GHC.Utils.Outputable (alwaysQualify, mkUserStyle, Depth (..)) +import GHC.Utils.Outputable (mkUserStyle, Depth (..)) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -754,7 +754,7 @@ annotateDecl dflags npc ast = do -- | Print out something 'Outputable'. render :: Outputable a => DynFlags -> NamePprCtx -> a -> String -render dflags npc = renderWithContext (initSDocContext dflags (mkUserStyle alwaysQualify AllTheWay)) . ppr +render dflags npc = renderWithContext (initSDocContext dflags (mkUserStyle npc AllTheWay)) . ppr ------------------------------------------------------------------------------ diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs index 8e7a31a248..9056651938 100644 --- a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs +++ b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs @@ -7,9 +7,6 @@ import Data.String qualified import Q data D = D -instance GHC.Internal.Data.String.IsString D where - GHC.Internal.Data.String.fromString s - = GHC.Internal.Data.Maybe.fromMaybe - D - (D GHC.Internal.Base.<$ - GHC.Internal.Maybe.Just (GHC.Internal.Data.Ord.Down 1)) +instance Data.String.IsString D where + Data.String.fromString s + = fromMaybe D (D <$ Just (GHC.Internal.Data.Ord.Down 1)) From f1237aeee3d9b1a0993525e148b27f8d539e1080 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 02:31:26 +0100 Subject: [PATCH 6/7] unqualify bindings --- .../src/Development/IDE/GHC/ExactPrint.hs | 9 +++++++-- .../test/testdata/TDeclUnqualified.expected.hs | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index fde897f8ed..860490f5fd 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -84,7 +85,7 @@ import Control.Lens (_last, (&)) import Control.Lens.Operators ((%~)) import Data.List (partition) import GHC (DeltaPos (..), - NamePprCtx, + LocatedN, NamePprCtx, SrcSpanAnnN) import GHC.Driver.DynFlags (initSDocContext) import GHC.Utils.Outputable (mkUserStyle, Depth (..)) @@ -741,7 +742,7 @@ annotate dflags npc _needs_space _loc ast = do annotateDecl :: DynFlags -> NamePprCtx -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) annotateDecl dflags npc ast = do uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags npc ast + let rendered = render dflags npc $ unqualifyBindings ast expr' <- TransformT $ lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered #if MIN_VERSION_ghc(9,9,0) let expr'' = makeDeltaAst expr' @@ -749,6 +750,10 @@ annotateDecl dflags npc ast = do let expr'' = expr' #endif pure $ setPrecedingLines expr'' 1 0 + where + unqualifyBindings = everywhere $ mkT \case + fr@(FunRhs{mc_fun = L nl (Orig _ occ)}) -> fr{mc_fun = L nl (mkRdrUnqual occ)} + ctx -> ctx :: HsMatchContext (LocatedN RdrName) ------------------------------------------------------------------------------ diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs index 9056651938..c1ac32ea63 100644 --- a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs +++ b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs @@ -8,5 +8,5 @@ import Q data D = D instance Data.String.IsString D where - Data.String.fromString s + fromString s = fromMaybe D (D <$ Just (GHC.Internal.Data.Ord.Down 1)) From e04e7d9827ec712ee9dfe2a74382435c6399fb17 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Wed, 6 May 2026 18:41:33 +0100 Subject: [PATCH 7/7] (wip) auto-insert imports, plus misc... --- haskell-language-server.cabal | 4 +- .../src/Development/IDE/GHC/ExactPrint.hs | 20 ++++++-- .../src/Development/IDE/Plugin/CodeAction.hs | 4 ++ .../src/Ide/Plugin/Splice.hs | 47 ++++++++++++++++--- .../testdata/TDeclUnqualified.expected.hs | 1 + .../hls-splice-plugin/test/testdata/hie.yaml | 13 +++++ 6 files changed, 79 insertions(+), 10 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5c2f10f8ac..7a263b2c9a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -916,6 +916,7 @@ library hls-splice-plugin hs-source-dirs: plugins/hls-splice-plugin/src build-depends: , aeson + , containers , extra , foldl , ghc @@ -927,6 +928,7 @@ library hls-splice-plugin , mtl , syb , text + , text-rope , transformers , unliftio-core @@ -1557,6 +1559,7 @@ library hls-refactor-plugin Development.IDE.Plugin.CodeAction Development.IDE.Plugin.CodeAction.Util Development.IDE.GHC.Dump + Development.IDE.Plugin.Plugins.ImportUtils other-modules: Development.IDE.Plugin.CodeAction.Args Development.IDE.Plugin.CodeAction.ExactPrint Development.IDE.Plugin.CodeAction.PositionIndexed @@ -1564,7 +1567,6 @@ library hls-refactor-plugin Development.IDE.Plugin.Plugins.Diagnostic Development.IDE.Plugin.Plugins.FillHole Development.IDE.Plugin.Plugins.FillTypeWildcard - Development.IDE.Plugin.Plugins.ImportUtils default-extensions: CPP DataKinds diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 860490f5fd..f6b188d098 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -17,6 +17,7 @@ module Development.IDE.GHC.ExactPrint genericGraftWithLargestM, graftSmallestDeclsWithM, transform, + transformWithExtraEdits, transformM, ExactPrint(..), modifySmallestDeclWithM, @@ -230,11 +231,22 @@ transform :: Graft (Either String) ParsedSource -> ParsedSource -> Either String WorkspaceEdit -transform dflags npc ccs verTxtDocId f a = do +transform = transformWithExtraEdits id + +transformWithExtraEdits :: + (T.Text -> T.Text) -> + DynFlags -> + NamePprCtx -> + ClientCapabilities -> + VersionedTextDocumentIdentifier -> + Graft (Either String) ParsedSource -> + ParsedSource -> + Either String WorkspaceEdit +transformWithExtraEdits postProcess dflags npc ccs verTxtDocId f a = do let src = printA a a' <- transformA a $ runGraft f (dflags, npc) - let res = printA a' - pure $ diffText ccs (verTxtDocId, T.pack src) (T.pack res) IncludeDeletions + let res = postProcess $ T.pack $ printA a' + pure $ diffText ccs (verTxtDocId, T.pack src) res IncludeDeletions ------------------------------------------------------------------------------ @@ -751,6 +763,8 @@ annotateDecl dflags npc ast = do #endif pure $ setPrecedingLines expr'' 1 0 where + -- TODO is this doing an unnecessarily deep traversal? + -- is it even correct? unqualifyBindings = everywhere $ mkT \case fr@(FunRhs{mc_fun = L nl (Orig _ occ)}) -> fr{mc_fun = L nl (mkRdrUnqual occ)} ctx -> ctx :: HsMatchContext (LocatedN RdrName) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index a1ec99167d..b2ccf64acd 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -5,6 +5,10 @@ module Development.IDE.Plugin.CodeAction ( + -- TODO factor out somewhere instead of exporting from here? + newImport, + newImportToEdit, + newImportInsertRange, mkExactprintPluginDescriptor, iePluginDescriptor, typeSigsPluginDescriptor, diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 4139ebc300..34c7995a2d 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -9,6 +9,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Ide.Plugin.Splice (descriptor) where @@ -16,8 +17,9 @@ import Control.Applicative (Alternative ((<|>))) import Control.Arrow (Arrow (first)) import Control.Exception (SomeException) import qualified Control.Foldl as L -import Control.Lens (Identity (..), ix, view, - (%~), (<&>), (^.)) +import Control.Lens (Identity (..), _Just, at, + ix, view, (%~), (<&>), + (^.)) import Control.Monad (forM, guard, unless) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Extra (eitherM) @@ -33,9 +35,9 @@ import qualified Data.Bifunctor as B (first) import Data.Function import Data.Generics import qualified Data.Kind as Kinds -import Data.List (sortOn) +import Data.List (nub, sortOn) import Data.Maybe (fromMaybe, listToMaybe, - mapMaybe) + mapMaybe, catMaybes) import qualified Data.Text as T import Development.IDE import Development.IDE.Core.FileStore (getVersionedTextDoc) @@ -47,6 +49,9 @@ import Development.IDE.GHC.ExactPrint import GHC.Exts import qualified GHC.Runtime.Loader as Loader import qualified GHC.Types.Error as Error +import GHC.Utils.Outputable (NamePprCtx, + QualifyName (..), + queryQualifyName) import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.Plugin.Splice.Types import Ide.Types @@ -68,6 +73,13 @@ import GHC.Parser.Annotation (EpAnn (..)) import GHC.Parser.Annotation (SrcSpanAnn' (..)) #endif +import Data.List.Extra (nubOrd) +import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) +import Development.IDE.Plugin.Plugins.ImportUtils (QualifiedImportStyle(QualifiedImportPostfix)) +import Development.IDE.Plugin.Plugins.ImportUtils (qualifiedImportStyle) +import qualified Data.Text.Mixed.Rope as Rope +import qualified Data.Set as Set + descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -130,6 +142,8 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do withTypeChecked fp TcModuleResult {..} = do (ps, hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + -- TODO is this the right way to get the contents? + fileContents <- liftIO $ runAction "expandTHSplice.getFileContents" ideState $ getFileContents fp let Splices {..} = tmrTopLevelSplices let exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices @@ -165,7 +179,8 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do HsType -> graftSpliceWith typeSuperSpans HsDecl -> declSuperSpans <&> \(_, expanded) -> - transform + transformWithExtraEdits + (flip (foldl' (flip applyImportEdit)) (importEdits expanded)) dflags prUnqual clientCapabilities @@ -174,7 +189,27 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do ps <&> -- FIXME: Why ghc-exactprint sweeps preceding comments? - adjustToRange (verTxtDocId ^. J.uri) range + adjustToRange uri range + where + uri = verTxtDocId ^. J.uri + importEdits = mapMaybe + (\m -> snd <$> newImportToEdit (mkImport m) ps (maybe "" Rope.toText fileContents)) + . collectNotInScopeModules + collectNotInScopeModules decls = + nubOrd + [ moduleName m + | Orig m occ <- everything (<>) ([] `mkQ` pure) decls + , not $ any ((== m) . nameModule . greName) $ + lookupGlobalRdrEnv (tcg_rdr_env tmrTypechecked) occ + ] + -- TODO `newImport` has a pretty silly interface with the `modName == qual` forcing us to pass the same name twice + mkImport modName = newImport + (T.pack $ moduleNameString modName) Nothing + (Just (T.pack $ moduleNameString modName, qualifiedImportStyle dflags)) False + -- TODO not sure about this... do something more structured? + applyImportEdit (TextEdit (Range (Position l _) _) newTxt) txt = + let (before, after) = splitAt (fromIntegral l) (T.lines txt) + in T.unlines (before ++ T.lines newTxt ++ after) res <- liftIO $ runMaybeT $ do diff --git a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs index c1ac32ea63..09495a6659 100644 --- a/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs +++ b/plugins/hls-splice-plugin/test/testdata/TDeclUnqualified.expected.hs @@ -6,6 +6,7 @@ import Data.Maybe import Data.String qualified import Q +import qualified GHC.Internal.Data.Ord data D = D instance Data.String.IsString D where fromString s diff --git a/plugins/hls-splice-plugin/test/testdata/hie.yaml b/plugins/hls-splice-plugin/test/testdata/hie.yaml index 39bd673f43..4cebeb4f93 100644 --- a/plugins/hls-splice-plugin/test/testdata/hie.yaml +++ b/plugins/hls-splice-plugin/test/testdata/hie.yaml @@ -19,3 +19,16 @@ cradle: - TTypeTypeError.hs - TQQExp.hs - TSimpleDecl.hs + # TODO add these as separate commit? + # and also leave comment I guess about not realising there were already two Decl tests + # and I don't know or can't remember why they didn't fail before my previous fix, but these did + # actually, make a final cleanup PR which also adds a trailing newline and anything else needed for Geolog FFI + # oh, it's not just trailing newlines - various things can go wrong when there's existing code after the splice... + - TDeclBindgen.hs + - TDeclPrelude.hs + - TDeclData.hs + - TDeclForeignImport.hs + - TDeclInstance.hs + - TDeclNewtype.hs + - TDeclPatSyn.hs + - TDeclPragma.hs