diff --git a/hls-refactor-plugin.cabal b/hls-refactor-plugin.cabal --- a/hls-refactor-plugin.cabal +++ b/hls-refactor-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-refactor-plugin -version: 1.1.0.0 +version: 1.2.0.0 synopsis: Exactprint refactorings for Haskell Language Server description: Please see the README on GitHub at @@ -68,7 +68,7 @@ , ghc-boot , regex-tdfa , text-rope - , ghcide ^>=1.9 + , ghcide ^>=1.10 , hls-plugin-api ^>=1.6 , lsp , text diff --git a/src/Development/IDE/GHC/Dump.hs b/src/Development/IDE/GHC/Dump.hs --- a/src/Development/IDE/GHC/Dump.hs +++ b/src/Development/IDE/GHC/Dump.hs @@ -145,7 +145,11 @@ sourceText (SourceText src) = text "SourceText" <+> text src epaAnchor :: EpaLocation -> SDoc +#if MIN_VERSION_ghc(9,5,0) + epaAnchor (EpaSpan r _) = text "EpaSpan" <+> realSrcSpan r +#else epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r +#endif epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs anchorOp :: AnchorOperation -> SDoc diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -472,7 +472,7 @@ modifySmallestDeclWithM validSpan f a = do let modifyMatchingDecl [] = pure (DL.empty, Nothing) modifyMatchingDecl (ldecl@(L src _) : rest) = - lift (validSpan $ locA src) >>= \case + TransformT (lift $ validSpan $ locA src) >>= \case True -> do (decs', r) <- f ldecl pure $ (DL.fromList decs' <> DL.fromList rest, Just r) @@ -578,11 +578,18 @@ r -> (r -> r -> m r) -> TransformT m (MatchGroup GhcPs (LHsExpr GhcPs), r) +#if MIN_VERSION_ghc(9,5,0) +modifyMgMatchesT' (MG xMg (L locMatches matches)) f def combineResults = do + (unzip -> (matches', rs)) <- mapM f matches + r' <- TransformT $ lift $ foldM combineResults def rs + pure $ (MG xMg (L locMatches matches'), r') +#else 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 +#endif graftSmallestDeclsWithM :: forall a. @@ -697,7 +704,7 @@ uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast #if MIN_VERSION_ghc(9,4,0) - expr' <- lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered + expr' <- TransformT $ 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 @@ -738,7 +745,7 @@ uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast #if MIN_VERSION_ghc(9,4,0) - expr' <- lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered + expr' <- TransformT $ 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 diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -106,6 +106,7 @@ DeltaPos (..), EpAnn (..), EpaLocation (..), + hsmodAnn, LEpaComment) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), @@ -240,7 +241,8 @@ extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) Nothing -> do - let n = newImport importName sym importQual False + let qns = (,) <$> importQual <*> Just (qualifiedImportStyle df) + n = newImport importName sym qns False sym = if isNothing importQual then Just it else Nothing it = case thingParent of Nothing -> newThing @@ -251,9 +253,21 @@ mzero isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool -isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) = +isWantedModule wantedModule Nothing (L _ it@ImportDecl{ ideclName +#if MIN_VERSION_ghc(9,5,0) + , ideclImportList = Just (Exactly, _) +#else + , ideclHiding = Just (False, _) +#endif + }) = not (isQualifiedImport it) && unLoc ideclName == wantedModule -isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) = +isWantedModule wantedModule (Just qual) (L _ ImportDecl{ ideclAs, ideclName +#if MIN_VERSION_ghc(9,5,0) + , ideclImportList = Just (Exactly, _) +#else + , ideclHiding = Just (False, _) +#endif + }) = unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) isWantedModule _ _ _ = False @@ -812,15 +826,21 @@ -- In the expression: seq "test" seq "test" (traceShow "test") -- In an equation for ‘f’: -- f = seq "test" seq "test" (traceShow "test") +-- | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) - <|> matchRegexUnifySpaces _message (pat False False False True) - <|> matchRegexUnifySpaces _message (pat False False False False) - = codeEdit ty lit (makeAnnotatedLit ty lit) + <|> matchRegexUnifySpaces _message (pat False False False True) + <|> matchRegexUnifySpaces _message (pat False False False False) + + = codeEdit _range ty lit (makeAnnotatedLit ty lit) | Just source <- sourceOpt - , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) - = let lit' = makeAnnotatedLit ty lit; - tir = textInRange _range source - in codeEdit ty lit (T.replace lit lit' tir) + , Just [ty, lit, srcspan] <- matchRegexUnifySpaces _message (pat True True False False) + , range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of + [s] -> let x = realSrcSpanToRange s + in x{_end = (_end x){_character = succ (_character (_end x))}} + _ -> error "bug in srcspan parser" + = let lit' = makeAnnotatedLit ty lit; + tir = textInRange range source + in codeEdit range ty lit (T.replace lit lit' tir) | otherwise = [] where makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" @@ -828,10 +848,10 @@ pat multiple at inArg inExpr = T.concat [ ".*Defaulting the type variable " , ".*to type ‘([^ ]+)’ " , "in the following constraint" - , if multiple then "s" else "" + , if multiple then "s" else " " , ".*arising from the literal ‘(.+)’" , if inArg then ".+In the.+argument" else "" - , if at then ".+at" else "" + , if at then ".+at ([^ ]*)" else "" , if inExpr then ".+In the expression" else "" , ".+In the expression" ] @@ -841,14 +861,14 @@ , " to type ‘([^ ]+)’ " , ".*arising from the literal ‘(.+)’" , if inArg then ".+In the.+argument" else "" - , if at then ".+at" else "" + , if at then ".+at ([^ ]*)" else "" , if inExpr then ".+In the expression" else "" , ".+In the expression" ] #endif - codeEdit ty lit replacement = + codeEdit range ty lit replacement = let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" - edits = [TextEdit _range replacement] + edits = [TextEdit range replacement] in [( title, edits )] -- | GHC strips out backticks in case of infix functions as well as single quote @@ -953,7 +973,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} | Just [binding, mod, srcspan] <- matchRegexUnifySpaces _message - "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" + "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\)." = suggestions hsmodImports binding mod srcspan | Just (binding, mod_srcspan) <- matchRegExMultipleImports _message @@ -1118,10 +1138,17 @@ | isNothing ideclAs = Just False /= -- I don't find this particularly comprehensible, -- but HLint suggested me to do so... +#if MIN_VERSION_ghc(9,5,0) + (ideclImportList <&> \(isHiding, L _ ents) -> + let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents + in (isHiding == EverythingBut) && not occurs || (isHiding == Exactly) && occurs + ) +#else (ideclHiding <&> \(isHiding, L _ ents) -> let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents in isHiding && not occurs || not isHiding && occurs ) +#endif occursUnqualified _ _ = False symbolOccursIn :: T.Text -> IE GhcPs -> Bool @@ -1196,12 +1223,21 @@ where findMissingConstraint :: T.Text -> Maybe T.Text findMissingConstraint t = - let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement - regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" + let -- The regex below can be tested at: + -- https://regex101.com/r/dfSivJ/1 + regex = "(No instance for|Could not deduce):? (\\((.+)\\)|‘(.+)’|.+) arising from" -- a use of / a do statement + match = matchRegexUnifySpaces t regex - matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams - in match <|> matchImplicitParams <&> last + -- For a string like: + -- "Could not deduce: ?a::() arising from" + -- The `matchRegexUnifySpaces` function returns two empty match + -- groups at the end of the list. It's not clear why this is the + -- case, so we select the last non-empty match group. + getCorrectGroup = last . filter (/="") + + in getCorrectGroup <$> match + -- | Suggests a constraint for an instance declaration for which a constraint is missing. suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1417,8 +1453,8 @@ | otherwise -> [] where moduleText = moduleNameText identInfo -suggestNewImport :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] -suggestNewImport packageExportsMap ps fileContents Diagnostic{_message} +suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestNewImport df packageExportsMap ps fileContents Diagnostic{_message} | msg <- unifySpaces _message , Just thingMissing <- extractNotInScopeName msg , qual <- extractQualifiedModuleName msg @@ -1430,16 +1466,17 @@ , Just (range, indent) <- newImportInsertRange ps fileContents , extendImportSuggestions <- matchRegexUnifySpaces msg "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" - = let suggestions = nubSortBy simpleCompareImportSuggestion - (constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions) in + = let qis = qualifiedImportStyle df + suggestions = nubSortBy simpleCompareImportSuggestion + (constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions qis) in map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions where L _ HsModule {..} = astA ps -suggestNewImport _ _ _ _ = [] +suggestNewImport _ _ _ _ _ = [] constructNewImportSuggestions - :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [ImportSuggestion] -constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdBy simpleCompareImportSuggestion + :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> QualifiedImportStyle -> [ImportSuggestion] +constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion [ suggestion | 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 @@ -1451,7 +1488,7 @@ renderNewImport :: IdentInfo -> [ImportSuggestion] renderNewImport identInfo | Just q <- qual - = [ImportSuggestion importanceScore (quickFixImportKind "new.qualified") (newQualImport m q)] + = [ImportSuggestion importanceScore (quickFixImportKind "new.qualified") (newQualImport m q qis)] | otherwise = [ImportSuggestion importanceScore (quickFixImportKind' "new" importStyle) (newUnqualImport m (renderImportStyle importStyle) False) | importStyle <- NE.toList $ importStyles identInfo] ++ @@ -1555,7 +1592,11 @@ -- 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) +#if MIN_VERSION_ghc(9,5,0) + whereKeywordLineOffset = case hsmodAnn hsmodExt of +#else whereKeywordLineOffset = case hsmodAnn of +#endif EpAnn _ annsModule _ -> do -- Find the first 'where' whereLocation <- fmap NE.head . NE.nonEmpty . mapMaybe filterWhere . am_main $ annsModule @@ -1565,7 +1606,12 @@ filterWhere _ = Nothing epaLocationToLine :: EpaLocation -> Maybe Int - epaLocationToLine (EpaSpan sp) = Just . srcLocLine . realSrcSpanEnd $ sp +#if MIN_VERSION_ghc(9,5,0) + epaLocationToLine (EpaSpan sp _) +#else + epaLocationToLine (EpaSpan sp) +#endif + = Just . srcLocLine . realSrcSpanEnd $ sp epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments -- 'priorComments' contains the comments right before the current EpaLocation -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and @@ -1629,10 +1675,10 @@ newImport :: T.Text -- ^ module name -> Maybe T.Text -- ^ the symbol - -> Maybe T.Text -- ^ qualified name + -> Maybe (T.Text, QualifiedImportStyle) -- ^ qualified name and style -> Bool -- ^ the symbol is to be imported or hidden -> NewImport -newImport modName mSymbol mQual hiding = NewImport impStmt +newImport modName mSymbol mQualNameStyle hiding = NewImport impStmt where symImp | Just symbol <- mSymbol @@ -1641,15 +1687,19 @@ | otherwise = "" impStmt = "import " - <> maybe "" (const "qualified ") mQual - <> modName + <> qualifiedModName (snd <$> mQualNameStyle) <> (if hiding then " hiding" else "") <> symImp <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual + mQual = fst <$> mQualNameStyle + qualifiedModName Nothing = modName + qualifiedModName (Just QualifiedImportPrefix) = "qualified " <> modName + qualifiedModName (Just QualifiedImportPostfix) = modName <> " qualified" -newQualImport :: T.Text -> T.Text -> NewImport -newQualImport modName qual = newImport modName Nothing (Just qual) False +newQualImport :: T.Text -> T.Text -> QualifiedImportStyle -> NewImport +newQualImport modName qual qis = newImport modName Nothing (Just (qual, qis)) False + newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport newUnqualImport modName symbol = newImport modName (Just symbol) Nothing @@ -1802,7 +1852,13 @@ -- | Returns the ranges for a binding in an import declaration rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] -rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = +rangesForBindingImport ImportDecl{ +#if MIN_VERSION_ghc(9,5,0) + ideclImportList = Just (Exactly, L _ lies) +#else + ideclHiding = Just (False, L _ lies) +#endif + } b = concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies where b' = wrapOperatorInParens b diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -311,7 +311,7 @@ #else Right x -> pure (makeDeltaAst x) #endif - Left _ -> lift $ Left $ "No parse: " <> s + Left _ -> TransformT $ lift $ Left $ "No parse: " <> s #if !MIN_VERSION_ghc(9,2,0) lookupAnn :: (Data a, Monad m) @@ -344,7 +344,7 @@ liftMaybe :: String -> Maybe a -> TransformT (Either String) a liftMaybe _ (Just x) = return x -liftMaybe s _ = lift $ Left s +liftMaybe s _ = TransformT $ lift $ Left s ------------------------------------------------------------------------------ extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite @@ -376,7 +376,11 @@ LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) extendImportTopLevel thing (L l it@ImportDecl{..}) +#if MIN_VERSION_ghc(9,5,0) + | Just (hide, L l' lies) <- ideclImportList +#else | Just (hide, L l' lies) <- ideclHiding +#endif , hasSibling <- not $ null lies = do src <- uniqueSrcSpanT top <- uniqueSrcSpanT @@ -385,13 +389,17 @@ printOutputable (occName (unLoc rdr)) `elem` map (printOutputable @OccName) (listify (const True) lies) when alreadyImported $ - lift (Left $ thing <> " already imported") + TransformT $ lift (Left $ thing <> " already imported") - let lie = reLocA $ L src $ IEName rdr + let lie = reLocA $ L src $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + rdr x = reLocA $ L top $ IEVar noExtField lie if x `elem` lies - then lift (Left $ thing <> " already imported") + then TransformT $ lift (Left $ thing <> " already imported") else do #if !MIN_VERSION_ghc(9,2,0) anns <- getAnnsT @@ -416,9 +424,13 @@ return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} #else let lies' = addCommaInImportList lies x +#if MIN_VERSION_ghc(9,5,0) + return $ L l it{ideclImportList = Just (hide, L l' lies')} +#else return $ L l it{ideclHiding = Just (hide, L l' lies')} #endif -extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" +#endif +extendImportTopLevel _ _ = TransformT $ lift $ Left "Unable to extend the import list" wildCardSymbol :: String wildCardSymbol = ".." @@ -447,16 +459,24 @@ LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) extendImportViaParent df parent child (L l it@ImportDecl{..}) +#if MIN_VERSION_ghc(9,5,0) + | Just (hide, L l' lies) <- ideclImportList = go hide l' [] lies +#else | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies +#endif where go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) - | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports" + | parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports" go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) -- ThingAbs ie => ThingWith ie child | parent == unIEWrappedName ie = do srcChild <- uniqueSrcSpanT let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child - childLIE = reLocA $ L srcChild $ IEName childRdr + childLIE = reLocA $ L srcChild $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + childRdr #if !MIN_VERSION_ghc(9,2,0) x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] [] -- take anns from ThingAbs, and attach parens to it @@ -465,7 +485,13 @@ #else x :: LIE GhcPs = L ll' $ IEThingWith (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) absIE NoIEWildcard [childLIE] #endif + +#if MIN_VERSION_ghc(9,5,0) + return $ L l it{ideclImportList = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} +#else return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} +#endif + #if !MIN_VERSION_ghc(9,2,0) go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs) #else @@ -475,7 +501,11 @@ | parent == unIEWrappedName ie , child == wildCardSymbol = do #if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,5,0) + let it' = it{ideclImportList = Just (hide, lies)} +#else let it' = it{ideclHiding = Just (hide, lies)} +#endif thing = IEThingWith newl twIE (IEWildcard 2) [] newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l''' lies = L l' $ reverse pre ++ [L l'' thing] ++ xs @@ -497,16 +527,24 @@ printOutputable (occName (unLoc childRdr)) `elem` map (printOutputable @OccName) (listify (const True) lies') when alreadyImported $ - lift (Left $ child <> " already included in " <> parent <> " imports") + TransformT $ lift (Left $ child <> " already included in " <> parent <> " imports") - let childLIE = reLocA $ L srcChild $ IEName childRdr + let childLIE = reLocA $ L srcChild $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + childRdr #if !MIN_VERSION_ghc(9,2,0) when hasSibling $ addTrailingCommaT (last lies') addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)] return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)} #else +#if MIN_VERSION_ghc(9,5,0) + let it' = it{ideclImportList = Just (hide, lies)} +#else let it' = it{ideclHiding = Just (hide, lies)} +#endif lies = L l' $ reverse pre ++ [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs fixLast = if hasSibling then first addComma else id @@ -528,12 +566,21 @@ let parentLIE = L srcParent (if isParentOperator then IEType parentRdr else IEName parentRdr) childLIE = reLocA $ L srcChild $ IEName childRdr #else - let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr') + let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' + else IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + parentRdr') parentRdr' = modifyAnns parentRdr $ \case it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1, nann_close = epl 0} other -> other - childLIE = reLocA $ L srcChild $ IEName childRdr + childLIE = reLocA $ L srcChild $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField #endif + childRdr +#endif #if !MIN_VERSION_ghc(9,2,0) x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] [] -- Add AnnType for the parent if it's parenthesized (type operator) @@ -554,8 +601,12 @@ lies' = addCommaInImportList (reverse pre) x #endif +#if MIN_VERSION_ghc(9,5,0) + return $ L l it{ideclImportList = Just (hide, L l' lies')} +#else return $ L l it{ideclHiding = Just (hide, L l' lies')} -extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" +#endif +extendImportViaParent _ _ _ _ = TransformT $ lift $ Left "Unable to extend the import list via parent" #if MIN_VERSION_ghc(9,2,0) -- Add an item in an import list, taking care of adding comma if needed. @@ -592,7 +643,11 @@ fixLast = over _last (first (if existingTrailingComma then id else addComma)) #endif +#if MIN_VERSION_ghc(9,5,0) +unIEWrappedName :: IEWrappedName GhcPs -> String +#else unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String +#endif unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ) hasParen :: String -> Bool @@ -615,10 +670,17 @@ hideSymbol :: String -> LImportDecl GhcPs -> Rewrite hideSymbol symbol lidecl@(L loc ImportDecl{..}) = +#if MIN_VERSION_ghc(9,5,0) + case ideclImportList of + Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing + Just (EverythingBut, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) + Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports +#else case ideclHiding of Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports +#endif hideSymbol _ (L _ (XImportDecl _)) = error "cannot happen" @@ -655,7 +717,11 @@ #if MIN_VERSION_ghc(9,2,0) rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr) #endif - let lie = reLocA $ L src $ IEName rdr + let lie = reLocA $ L src $ IEName +#if MIN_VERSION_ghc(9,5,0) + noExtField +#endif + rdr x = reLocA $ L top $ IEVar noExtField lie #if MIN_VERSION_ghc(9,2,0) x <- pure $ if hasSibling then first addComma x else x @@ -682,7 +748,11 @@ else forM_ mlies $ \lies0 -> do transferAnn lies0 singleHide id #endif +#if MIN_VERSION_ghc(9,5,0) + return $ L l idecls{ideclImportList = Just (EverythingBut, L l' $ x : lies)} +#else return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)} +#endif where isOperator = not . all isAlphaNum . occNameString . rdrNameOcc @@ -701,7 +771,11 @@ lidecl' = L l $ idecl +#if MIN_VERSION_ghc(9,5,0) + { ideclImportList = Just (Exactly, edited) +#else { ideclHiding = Just (False, edited) +#endif } #if !MIN_VERSION_ghc(9,2,0) -- avoid import A (foo,) diff --git a/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/src/Development/IDE/Plugin/Plugins/AddArgument.hs --- a/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -10,7 +10,7 @@ import Language.LSP.Types #else import Control.Monad (join) -import Control.Monad.Except (lift) +import Control.Monad.Trans.Class (lift) import Data.Bifunctor (Bifunctor (..)) import Data.Either.Extra (maybeToEither) import qualified Data.Text as T @@ -34,7 +34,7 @@ import GHC.Types.SrcLoc (generatedSrcSpan) import Ide.PluginUtils (makeDiffTextEdit, responseError) -import Language.Haskell.GHC.ExactPrint (TransformT, +import Language.Haskell.GHC.ExactPrint (TransformT(..), noAnnSrcSpanDP1, runTransformT) import Language.Haskell.GHC.ExactPrint.Transform (d1) @@ -85,10 +85,10 @@ -- => (`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 + (L locDecl (ValD xVal fun@FunBind{fun_matches=mg,fun_id = idFunBind})) -> 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)) + numPats <- TransformT $ lift $ maybeToEither (responseError "Unexpected empty match group in HsDecl") numPatsMay + let decl' = L locDecl (ValD xVal fun{fun_matches=mg'}) pure (decl', Just (idFunBind, numPats)) decl -> pure (decl, Nothing) where diff --git a/src/Development/IDE/Plugin/Plugins/ImportUtils.hs b/src/Development/IDE/Plugin/Plugins/ImportUtils.hs --- a/src/Development/IDE/Plugin/Plugins/ImportUtils.hs +++ b/src/Development/IDE/Plugin/Plugins/ImportUtils.hs @@ -4,11 +4,14 @@ quickFixImportKind, renderImportStyle, unImportStyle, - importStyles + importStyles, + QualifiedImportStyle(..), + qualifiedImportStyle ) where import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Text as T +import Development.IDE.GHC.Compat import Development.IDE.Plugin.CodeAction.ExactPrint (wildCardSymbol) import Development.IDE.Types.Exports import Language.LSP.Types (CodeActionKind (..)) @@ -83,3 +86,13 @@ quickFixImportKind :: T.Text -> CodeActionKind quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x + +-- | Possible import styles for qualified imports +data QualifiedImportStyle = QualifiedImportPostfix | QualifiedImportPrefix + deriving Show + +qualifiedImportStyle :: DynFlags -> QualifiedImportStyle +qualifiedImportStyle df | hasImportQualifedPostEnabled && hasPrePositiveQualifiedWarning = QualifiedImportPostfix + | otherwise = QualifiedImportPrefix + where hasImportQualifedPostEnabled = xopt ImportQualifiedPost df + hasPrePositiveQualifiedWarning = wopt Opt_WarnPrepositiveQualifiedModule df diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -64,11 +64,11 @@ main :: IO () main = defaultTestRunner tests -refactorPlugin :: IO [PluginDescriptor IdeState] +refactorPlugin :: IO (IdePlugins IdeState) refactorPlugin = do exactprintLog <- pluginTestRecorder ghcideLog <- pluginTestRecorder - pure $ + pure $ IdePlugins $ [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports" , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures" , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings" @@ -2416,8 +2416,7 @@ , "" , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" ]) - , knownBrokenForGhcVersions [GHC92, GHC94] "GHC 9.2 only has 'traceShow' in error span" $ - testSession "add default type to satisfy two constraints" $ + , testSession "add default type to satisfy two constraints" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2441,8 +2440,7 @@ , "" , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" ]) - , knownBrokenForGhcVersions [GHC92, GHC94] "GHC 9.2 only has 'traceShow' in error span" $ - testSession "add default type to satisfy two constraints with duplicate literals" $ + , testSession "add default type to satisfy two constraints with duplicate literals" $ testFor (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}"