diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +v0.11.0.0 + * support GHC 9.4 + v0.10.0.0 * support GHC 9.2; drop support for GHC <= 9.0 (@alanz) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ [`refact`](https://hackage.haskell.org/package/refact) package. It is currently integrated into [HLint](https://github.com/ndmitchell/hlint) to enable the automatic application of suggestions. -apply-refact 0.10.x supports GHC 9.2, and 0.9.x supports GHC 8.6 through 9.0. +apply-refact 0.11.x supports GHC 9.4 and 9.2, 0.10.x supports GHC 9.2 and 0.9.x supports GHC 8.6 through 9.0. # Install diff --git a/apply-refact.cabal b/apply-refact.cabal --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: apply-refact -version: 0.10.0.0 +version: 0.11.0.0 synopsis: Perform refactorings specified by the refact library. description: Perform refactorings specified by the refact library. It is primarily used with HLint's --refactor flag. license: BSD-3-Clause @@ -18,7 +18,7 @@ , tests/examples/*.hs , tests/examples/*.hs.refact , tests/examples/*.hs.expected -tested-with: GHC == 9.2.1 +tested-with: GHC==9.4.2, GHC==9.2.5 source-repository head @@ -32,11 +32,10 @@ , Refact.Internal , Refact.Compat GHC-Options: -Wall - build-depends: base >=4.16 && < 5 + build-depends: base >=4.15 && < 5 , refact >= 0.2 - , ghc-exactprint >= 1.5.0 - , ghc >= 9.2 , ghc-boot-th + , ghc-exactprint ^>= 1.6.0 || ^>= 1.5.0 , ghc-paths , containers >= 0.6.0.1 && < 0.7 , extra >= 1.7.3 @@ -47,6 +46,11 @@ , uniplate >= 1.6.13 , unix-compat >= 0.5.2 , directory >= 1.3 + if (impl(ghc >= 9.4) && impl(ghc < 9.5)) + build-depends: ghc ^>= 9.4 + if (impl(ghc >= 9.2) && impl(ghc < 9.3)) + build-depends: ghc ^>= 9.2 + default-extensions: FlexibleContexts , FlexibleInstances , FunctionalDependencies diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs --- a/src/Refact/Compat.hs +++ b/src/Refact/Compat.hs @@ -43,11 +43,7 @@ StmtLR (..), -- * HsSyn / GHC.Hs -#if __GLASGOW_HASKELL__ >= 810 module GHC.Hs, -#else - module HsSyn, -#endif -- * Name / OccName / GHC.Types.Name nameOccName, @@ -97,127 +93,92 @@ setSrcSpanFile, srcSpanToAnnSpan, AnnSpan, + +#if MIN_VERSION_ghc(9,4,0) + -- * GHC 9.4 stuff + initParserOpts, +#endif ) where -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Data.Bag (unitBag, bagToList ) +import Control.Monad.Trans.State.Strict (StateT) +import Data.Data (Data) +import qualified GHC +import GHC.Data.Bag (unitBag, bagToList) import GHC.Data.FastString (FastString, mkFastString) +#if MIN_VERSION_ghc(9,4,0) +import qualified GHC.Data.Strict as Strict +#endif import GHC.Data.StringBuffer (stringToStringBuffer) +#if MIN_VERSION_ghc(9,4,0) +import GHC.Driver.Config.Parser +import GHC.Driver.Errors.Types (ErrorMessages, ghcUnknownMessage) +#endif import GHC.Driver.Session hiding (initDynFlags) -import GHC.Parser.Annotation +import GHC.Hs hiding (Pat, Stmt) import GHC.Parser.Header (getOptions) +#if MIN_VERSION_ghc(9,4,0) +import GHC.Types.Error (getMessages) +#endif import GHC.Types.Fixity ( Fixity(..) ) -import GHC.Utils.Error hiding (mkErr) import GHC.Types.Name (nameOccName, occName, occNameString) import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) import GHC.Types.SrcLoc hiding (spans) import GHC.Types.SourceText -import GHC.Utils.Panic (pprPanic) -import GHC.Utils.Outputable - ( ppr, - showSDocUnsafe, - text, - vcat, - ) -import GHC.Utils.Panic (handleGhcException) +#if MIN_VERSION_ghc(9,4,0) +import GHC.Utils.Error #else -import ApiAnnotation -#if __GLASGOW_HASKELL__ == 810 -import Bag (unitBag) -#endif -import BasicTypes (Fixity (..), SourceText (..)) -import ErrUtils - ( ErrorMessages, - pprErrMsgBagWithLoc, -#if __GLASGOW_HASKELL__ == 810 - mkPlainErrMsg, +import GHC.Utils.Error hiding (mkErr) #endif - ) -import DynFlags hiding (initDynFlags) -import FastString (FastString, mkFastString) -import GHC.LanguageExtensions.Type (Extension (..)) -import HeaderInfo (getOptions) -import Name (nameOccName) -import OccName (occName, occNameString) -import Outputable +import GHC.Utils.Outputable ( ppr, showSDocUnsafe, -#if __GLASGOW_HASKELL__ == 810 - pprPanic, text, vcat, -#endif ) -import Panic (handleGhcException) -import RdrName (RdrName (..), rdrNameOcc) -import SrcLoc hiding (spans) -import StringBuffer (stringToStringBuffer) -#endif - -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs hiding (Pat, Stmt) -#elif __GLASGOW_HASKELL__ <= 808 -import HsSyn hiding (Pat, Stmt) -#endif - -import Control.Monad.Trans.State.Strict (StateT) -import Data.Data (Data) -import qualified GHC +import GHC.Utils.Panic + ( handleGhcException + , pprPanic + ) import Language.Haskell.GHC.ExactPrint.Parsers (Parser) import Language.Haskell.GHC.ExactPrint.Utils import Refact.Types (Refactoring) -#if __GLASGOW_HASKELL__ <= 806 -type MonadFail' = Monad -#else type MonadFail' = MonadFail -#endif -#if __GLASGOW_HASKELL__ >= 900 type Module = Located HsModule -#else -type Module = Located (HsModule GhcPs) -#endif -#if __GLASGOW_HASKELL__ >= 810 type Errors = ErrorMessages + onError :: String -> Errors -> a onError s = pprPanic s . vcat . ppp + ppp :: Errors -> [SDoc] -ppp pst = concatMap unDecorated $ fmap errMsgDiagnostic $ bagToList pst +#if MIN_VERSION_ghc(9,4,0) +ppp pst = concatMap unDecorated $ fmap (diagnosticMessage . errMsgDiagnostic) $ bagToList $ getMessages pst #else -type Errors = (SrcSpan, String) -onError :: String -> Errors -> a -onError _ = error . show +ppp pst = concatMap unDecorated (errMsgDiagnostic <$> bagToList pst) #endif -#if __GLASGOW_HASKELL__ >= 900 type FunBind = HsMatchContext GhcPs -#else -type FunBind = HsMatchContext RdrName -#endif pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc -#if __GLASGOW_HASKELL__ >= 900 pattern RealSrcLoc' r <- RealSrcLoc r _ where - RealSrcLoc' r = RealSrcLoc r Nothing +#if MIN_VERSION_ghc(9,4,0) + RealSrcLoc' r = RealSrcLoc r Strict.Nothing #else -pattern RealSrcLoc' r <- RealSrcLoc r where - RealSrcLoc' r = RealSrcLoc r + RealSrcLoc' r = RealSrcLoc r Nothing #endif {-# COMPLETE RealSrcLoc', UnhelpfulLoc #-} pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan -#if __GLASGOW_HASKELL__ >= 900 pattern RealSrcSpan' r <- RealSrcSpan r _ where - RealSrcSpan' r = RealSrcSpan r Nothing +#if MIN_VERSION_ghc(9,4,0) + RealSrcSpan' r = RealSrcSpan r Strict.Nothing #else -pattern RealSrcSpan' r <- RealSrcSpan r where - RealSrcSpan' r = RealSrcSpan r + RealSrcSpan' r = RealSrcSpan r Nothing #endif {-# COMPLETE RealSrcSpan', UnhelpfulSpan #-} -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 composeSrcSpan :: a -> a composeSrcSpan = id @@ -225,31 +186,22 @@ decomposeSrcSpan = id type SrcSpanLess a = a -#endif type AnnSpan = RealSrcSpan badAnnSpan :: AnnSpan badAnnSpan = -#if __GLASGOW_HASKELL__ >= 900 badRealSrcSpan -#else - noSrcSpan -#endif srcSpanToAnnSpan :: SrcSpan -> AnnSpan srcSpanToAnnSpan = -#if __GLASGOW_HASKELL__ >= 900 \case RealSrcSpan l _ -> l; _ -> badRealSrcSpan -#else - id -#endif annSpanToSrcSpan :: AnnSpan -> SrcSpan annSpanToSrcSpan = -#if __GLASGOW_HASKELL__ >= 900 - flip RealSrcSpan Nothing +#if MIN_VERSION_ghc(9,4,0) + flip RealSrcSpan Strict.Nothing #else - id + flip RealSrcSpan Nothing #endif setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan @@ -271,29 +223,22 @@ setAnnSpanFile :: FastString -> AnnSpan -> AnnSpan setAnnSpanFile = -#if __GLASGOW_HASKELL__ >= 900 setRealSrcSpanFile -#else - setSrcSpanFile -#endif mkErr :: DynFlags -> SrcSpan -> String -> Errors -#if __GLASGOW_HASKELL__ >= 810 -mkErr _df l s = unitBag (mkPlainMsgEnvelope l (text s)) +#if MIN_VERSION_ghc(9,4,0) +mkErr _df l s = + mkMessages $ + unitBag (mkPlainErrorMsgEnvelope l (ghcUnknownMessage $ mkDecoratedError [] [text s])) #else -mkErr = const (,) +mkErr _df l s = unitBag (mkPlainMsgEnvelope l (text s)) #endif parseModuleName :: SrcSpan -> Parser (LocatedA GHC.ModuleName) parseModuleName ss _ _ s = let newMN = GHC.L (GHC.noAnnSrcSpan ss) (GHC.mkModuleName s) -#if __GLASGOW_HASKELL__ >= 900 -#else - newAnns = relativiseApiAnns newMN mempty -#endif in pure newMN -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 type DoGenReplacement an ast a = (Data ast, Data a) => a -> @@ -301,17 +246,7 @@ LocatedAn an ast -> LocatedAn an ast -> StateT Bool IO (LocatedAn an ast) -#else -type DoGenReplacement ast a = - (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) => - a -> - (ast -> Bool) -> - ast -> - ast -> - StateT ((Anns, AnnKeyMap), Bool) IO ast -#endif -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 type ReplaceWorker a mod = (Data a, Data mod) => mod -> @@ -319,80 +254,3 @@ Int -> Refactoring SrcSpan -> IO mod -#else -type ReplaceWorker a mod = - (Data a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) => - Anns -> - mod -> - AnnKeyMap -> - Parser a -> - Int -> - Refactoring SrcSpan -> - IO (Anns, mod, AnnKeyMap) -#endif - -#if __GLASGOW_HASKELL__ < 900 --- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to --- support GHC 8.6 -impliedXFlags :: [(Extension, Bool, Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (RankNTypes, True, ExplicitForAll) - , (QuantifiedConstraints, True, ExplicitForAll) - , (ScopedTypeVariables, True, ExplicitForAll) - , (LiberalTypeSynonyms, True, ExplicitForAll) - , (ExistentialQuantification, True, ExplicitForAll) - , (FlexibleInstances, True, TypeSynonymInstances) - , (FunctionalDependencies, True, MultiParamTypeClasses) - , (MultiParamTypeClasses, True, ConstrainedClassMethods) -- c.f. #7854 - , (TypeFamilyDependencies, True, TypeFamilies) - - , (RebindableSyntax, False, ImplicitPrelude) -- NB: turn off! - - , (DerivingVia, True, DerivingStrategies) - - , (GADTs, True, GADTSyntax) - , (GADTs, True, MonoLocalBinds) - , (TypeFamilies, True, MonoLocalBinds) - - , (TypeFamilies, True, KindSignatures) -- Type families use kind signatures - , (PolyKinds, True, KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (TypeInType, True, DataKinds) - , (TypeInType, True, PolyKinds) - , (TypeInType, True, KindSignatures) - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (AutoDeriveTypeable, True, DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (TypeFamilies, True, ExplicitNamespaces) - , (TypeOperators, True, ExplicitNamespaces) - - , (ImpredicativeTypes, True, RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (RecordWildCards, True, DisambiguateRecordFields) - - , (ParallelArrays, True, ParallelListComp) - - , (JavaScriptFFI, True, InterruptibleFFI) - - , (DeriveTraversable, True, DeriveFunctor) - , (DeriveTraversable, True, DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (DuplicateRecordFields, True, DisambiguateRecordFields) - - , (TemplateHaskell, True, TemplateHaskellQuotes) - , (Strict, True, StrictData) -#if __GLASGOW_HASKELL__ >= 810 - , (StandaloneKindSignatures, False, CUSKs) -#endif - ] -#endif diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -33,7 +34,6 @@ import Data.List.Extra import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Ord (comparing) -import qualified Data.Set as Set import Data.Tuple.Extra import Debug.Trace import qualified GHC @@ -41,10 +41,24 @@ import GHC.LanguageExtensions.Type (Extension (..)) import qualified GHC.Paths import Language.Haskell.GHC.ExactPrint + ( ExactPrint, + exactPrint, + getEntryDP, + makeDeltaAst, + runTransform, + setEntryDP, + transferEntryDP, + transferEntryDP', + ) import Language.Haskell.GHC.ExactPrint.ExactPrint + ( EPOptions, + epRigidity, + exactPrintWithOptions, + stringOptions, + ) import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Utils (ss2pos) import Refact.Compat ( AnnSpan, DoGenReplacement, @@ -56,7 +70,6 @@ -- combineSrcSpans, combineSrcSpansA, composeSrcSpan, - decomposeSrcSpan, getOptions, gopt_set, handleGhcException, @@ -68,7 +81,6 @@ parseDynamicFilePragma, parseModuleName, ppr, - rdrNameOcc, setSrcSpanFile, showSDocUnsafe, srcSpanToAnnSpan, @@ -76,8 +88,11 @@ xFlags, xopt_set, xopt_unset, - pattern RealSrcLoc', pattern RealSrcSpan', +#if MIN_VERSION_ghc(9,4,0) + mkGeneratedHsDocString, + initParserOpts +#endif ) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R @@ -319,7 +334,14 @@ modifyComment :: (Data a) => GHC.SrcSpan -> String -> a -> a modifyComment pos newComment = transformBi go where +#if MIN_VERSION_ghc(9,4,0) newTok :: GHC.EpaCommentTok -> GHC.EpaCommentTok + newTok (GHC.EpaDocComment _) = GHC.EpaDocComment $ mkGeneratedHsDocString newComment + newTok (GHC.EpaDocOptions _) = GHC.EpaDocOptions newComment + newTok (GHC.EpaLineComment _) = GHC.EpaLineComment newComment + newTok (GHC.EpaBlockComment _) = GHC.EpaBlockComment newComment + newTok GHC.EpaEofComment = GHC.EpaEofComment +#else newTok (GHC.EpaDocCommentNext _) = GHC.EpaDocCommentNext newComment newTok (GHC.EpaDocCommentPrev _) = GHC.EpaDocCommentPrev newComment newTok (GHC.EpaDocCommentNamed _) = GHC.EpaDocCommentNamed newComment @@ -328,6 +350,7 @@ newTok (GHC.EpaLineComment _) = GHC.EpaLineComment newComment newTok (GHC.EpaBlockComment _) = GHC.EpaBlockComment newComment newTok GHC.EpaEofComment = GHC.EpaEofComment +#endif go :: GHC.LEpaComment -> GHC.LEpaComment go old@(GHC.L (GHC.Anchor l o) (GHC.EpaComment t r)) = @@ -336,7 +359,7 @@ else old droppedComments :: [Refactoring GHC.SrcSpan] -> Module -> Module -> Bool -droppedComments rs orig_m m = not (all (`Set.member` current_comments) orig_comments) +droppedComments rs orig_m m = not (all (`elem` current_comments) orig_comments) where mcs = foldl' runModifyComment orig_m rs runModifyComment m' (ModifyComment pos newComment) = modifyComment pos newComment m' @@ -347,7 +370,7 @@ isComment :: GHC.EpaComment -> Bool isComment _ = True orig_comments = all_comments mcs - current_comments = Set.fromList $ all_comments m + current_comments = all_comments m parseBind :: Parser (GHC.LHsBind GHC.GhcPs) parseBind dyn fname s = @@ -450,10 +473,8 @@ -- Substitute the template into the original AST. doGenReplacement :: forall ast a. DoGenReplacement GHC.AnnListItem ast a -doGenReplacement m p new old +doGenReplacement _ p new old | p old = do - let n = decomposeSrcSpan new - o = decomposeSrcSpan old let (new', _, _) = runTransform $ transferEntryDP old new put True pure new' @@ -465,8 +486,6 @@ Just (oldNoLocal, oldLocal) <- stripLocalBind old, (RealSrcSpan' newLocReal) <- GHC.getLocA new, p (composeSrcSpan oldNoLocal) = do - let n = decomposeSrcSpan new - o = decomposeSrcSpan old let newFile = GHC.srcSpanFile newLocReal newLocal :: GHC.HsLocalBinds GHC.GhcPs newLocal = transformBi (setSrcSpanFile newFile) oldLocal @@ -556,13 +575,9 @@ (substTransform m subts (makeDeltaAst template)) -- (mergeAnns as relat, keyMap) () - let lst = listToMaybe . reverse . occNameString . rdrNameOcc - adjacent (GHC.srcSpanEnd -> RealSrcLoc' loc1) (GHC.srcSpanStart -> RealSrcLoc' loc2) = loc1 == loc2 - adjacent _ _ = False - - -- Add a space if needed, so that we avoid refactoring `y = do(foo bar)` into `y = dofoo bar`. - -- ensureDoSpace :: Anns -> Anns - ensureSpace :: forall t. (Data t) => t -> t + -- Add a space if needed, so that we avoid refactoring `y = do(foo bar)` into `y = dofoo bar`. + -- ensureDoSpace :: Anns -> Anns + let ensureSpace :: forall t. (Data t) => t -> t ensureSpace = everywhere (mkT ensureExprSpace) ensureExprSpace :: Expr -> Expr @@ -640,13 +655,18 @@ ] in Left $ NotFound expected actual ss where - doTrans :: forall an b. (Typeable an, Data b) => modu -> Maybe (GHC.LocatedAn an b) + doTrans :: forall an' b. (Typeable an', Data b) => modu -> Maybe (GHC.LocatedAn an' b) doTrans = something (mkQ Nothing (findLargestExpression ss)) - showType :: forall an b. Typeable b => Maybe (GHC.LocatedAn an b) -> Maybe String + showType :: forall an' b. Typeable b => Maybe (GHC.LocatedAn an' b) -> Maybe String showType = fmap $ \_ -> show (typeRep (Proxy @b)) -findLargestExpression :: forall an a. Data a => AnnSpan -> GHC.LocatedAn an a -> Maybe (GHC.LocatedAn an a) +findLargestExpression :: + forall an a. + Data a => + AnnSpan -> + GHC.LocatedAn an a -> + Maybe (GHC.LocatedAn an a) findLargestExpression as e@(getAnnSpanA -> l) = if l == as then Just e else Nothing findOrError :: @@ -675,7 +695,11 @@ IO (Either String GHC.DynFlags) addExtensionsToFlags es ds fp flags = catchErrors $ do (stringToStringBuffer -> buf) <- readFileUTF8' fp +#if MIN_VERSION_ghc(9,4,0) + let (_, opts) = getOptions (initParserOpts flags) buf fp +#else let opts = getOptions flags buf fp +#endif withExts = flip (foldl' xopt_unset) ds . flip (foldl' xopt_set) es