diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +v0.15.0.0 + * #151, support GHC 9.12 (@alanz) + v0.14.0.0 * #144, support GHC 9.8 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,14 @@ [`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.14.x supports GHC 9.2 through 9.8; 0.13.x supports GHC 9.2 through 9.6; 0.12.x and 0.11.x support GHC 9.2 and 9.4; 0.10.x supports GHC 9.2; 0.9.x supports GHC 8.6 through 9.0. +# GHC Version Compatibility + +- 0.15.x supports GHC 9.2 through 9.8, and 9.12. Unfortunately we are unable to support GHC 9.10. +- 0.14.x supports GHC 9.2 through 9.8. +- 0.13.x supports GHC 9.2 through 9.6. +- 0.12.x and 0.11.x support GHC 9.2 and 9.4. +- 0.10.x supports GHC 9.2. +- 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,168 +1,201 @@ -cabal-version: 3.0 +cabal-version: 3.0 +name: apply-refact +version: 0.15.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. -name: apply-refact -version: 0.14.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 -license-file: LICENSE -author: Matthew Pickering -maintainer: matthewtpickering@gmail.com +license: BSD-3-Clause +license-file: LICENSE +author: Matthew Pickering +maintainer: matthewtpickering@gmail.com + -- copyright: -category: Development -homepage: https://github.com/mpickering/apply-refact -bug-reports: https://github.com/mpickering/apply-refact/issues -build-type: Simple -extra-source-files: CHANGELOG - , README.md - , tests/examples/*.hs - , tests/examples/*.hs.refact - , tests/examples/*.hs.expected -tested-with: GHC==9.8.1, GHC==9.6.3, GHC==9.4.6, GHC==9.2.8 +category: Development +homepage: https://github.com/mpickering/apply-refact +bug-reports: https://github.com/mpickering/apply-refact/issues +build-type: Simple +extra-source-files: + CHANGELOG + README.md + tests/examples/*.hs + tests/examples/*.hs.expected + tests/examples/*.hs.refact +tested-with: + GHC ==9.2.8 || ==9.4.6 || ==9.6.6 || ==9.8.4 || ==9.12.1 source-repository head type: git location: https://github.com/mpickering/apply-refact.git library - exposed-modules: Refact.Utils - , Refact.Apply - , Refact.Fixity - , Refact.Internal - , Refact.Compat - GHC-Options: -Wall - build-depends: base >=4.16 && < 5 - , refact >= 0.2 - , ghc-boot-th - , ghc-exactprint ^>= 1.5.0 || ^>= 1.6.0 || ^>= 1.7.0 || ^>= 1.8.0 - , containers >= 0.6.0.1 && < 0.8 - , extra >= 1.7.3 - , syb >= 0.7.1 - , process >= 1.6 - , transformers >= 0.5.6.2 && < 0.7 - , filemanip >= 0.3.6.3 && < 0.4 - , uniplate >= 1.6.13 - , unix-compat >= 0.5.2 - , directory >= 1.3 - if (impl(ghc >= 9.8) && impl(ghc < 9.9)) - build-depends: ghc ^>= 9.8 - if (impl(ghc >= 9.6) && impl(ghc < 9.7)) - build-depends: ghc ^>= 9.6 - 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 + exposed-modules: + Refact.Apply + Refact.Compat + Refact.Fixity + Refact.Internal + Refact.Utils - default-extensions: FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , NamedFieldPuns - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TupleSections - , TypeApplications - , TypeOperators - hs-source-dirs: src - default-language: Haskell2010 + ghc-options: -Wall + build-depends: + , base >=4.16 && <5 + , containers >=0.6.0.1 && <0.8 + , data-default + , directory >=1.3 + , extra >=1.7.3 + , filemanip >=0.3.6.3 && <0.4 + , ghc + , ghc-boot-th + , ghc-exactprint ^>=1.5.0 || ^>=1.6.0 || ^>=1.7.0 || ^>=1.8.0 || ^>=1.12.0 + , process >=1.6 + , refact >=0.2 + , syb >=0.7.1 + , transformers >=0.5.6.2 && <0.7 + , uniplate >=1.6.13 + , unix-compat >=0.5.2 + if (impl(ghc >=9.8) && impl(ghc <9.9)) + build-depends: ghc ^>=9.8 + + if (impl(ghc >=9.6) && impl(ghc <9.7)) + build-depends: ghc ^>=9.6 + + 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 + + if impl(ghc <9.10) + build-depends: data-default-class + + default-extensions: + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + PolyKinds + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + + hs-source-dirs: src + default-language: Haskell2010 + executable refactor - main-is: Main.hs + main-is: Main.hs other-modules: - Paths_apply_refact - Refact.Apply - Refact.Compat - Refact.Fixity - Refact.Internal - Refact.Options - Refact.Run - Refact.Utils - autogen-modules: - Paths_apply_refact - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind - build-depends: base - , refact - , ghc-exactprint - , ghc - , ghc-boot-th - , ghc-paths - , containers - , extra - , syb - , process - , directory - , optparse-applicative >= 0.15.1.0 - , filemanip - , unix-compat - , filepath - , transformers - , uniplate - default-extensions: FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , NamedFieldPuns - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TupleSections - , TypeApplications - , TypeOperators + Paths_apply_refact + Refact.Apply + Refact.Compat + Refact.Fixity + Refact.Internal + Refact.Options + Refact.Run + Refact.Utils -Test-Suite test - type: exitcode-stdio-1.0 - hs-source-dirs: tests, src - main-is: Test.hs + autogen-modules: Paths_apply_refact + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind + build-depends: + , base >=4.16 && <5 + , containers + , data-default + , directory + , extra + , filemanip + , filepath + , ghc + , ghc-boot-th + , ghc-exactprint + , ghc-paths + , optparse-applicative >=0.15.1.0 + , process + , refact + , syb + , transformers + , uniplate + , unix-compat + + if impl(ghc <9.10) + build-depends: data-default-class + + default-extensions: + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + PolyKinds + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: tests src + main-is: Test.hs other-modules: - Paths_apply_refact - Refact.Apply - Refact.Compat - Refact.Fixity - Refact.Internal - Refact.Options - Refact.Run - Refact.Utils - ghc-options: -threaded - default-language: Haskell2010 - build-depends: tasty - , tasty-golden - , tasty-expected-failure - , base - , refact - , ghc-exactprint - , ghc - , ghc-boot-th - , ghc-paths - , containers - , extra - , syb - , process - , directory - , optparse-applicative - , filemanip - , unix-compat - , filepath - , silently - , transformers - , uniplate - default-extensions: FlexibleContexts - , FlexibleInstances - , FunctionalDependencies - , GADTs - , LambdaCase - , MultiParamTypeClasses - , NamedFieldPuns - , PolyKinds - , RankNTypes - , ScopedTypeVariables - , TupleSections - , TypeApplications - , TypeOperators + Paths_apply_refact + Refact.Apply + Refact.Compat + Refact.Fixity + Refact.Internal + Refact.Options + Refact.Run + Refact.Utils + + autogen-modules: Paths_apply_refact + ghc-options: -threaded + default-language: Haskell2010 + build-depends: + , base >=4.16 && <5 + , containers + , directory + , extra + , filemanip + , filepath + , ghc + , ghc-boot-th + , ghc-exactprint + , ghc-paths + , optparse-applicative + , process + , refact + , silently + , syb + , tasty + , tasty-expected-failure + , tasty-golden + , transformers + , uniplate + , unix-compat + + if impl(ghc <9.10) + build-depends: data-default + + default-extensions: + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + PolyKinds + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs --- a/src/Refact/Compat.hs +++ b/src/Refact/Compat.hs @@ -4,7 +4,10 @@ module Refact.Compat ( -- * ApiAnnotation / GHC.Parser.ApiAnnotation +#if MIN_VERSION_ghc(9,12,0) +#else AnnKeywordId (..), +#endif DeltaPos(..), -- * BasicTypes / GHC.Types.Basic @@ -93,6 +96,12 @@ setSrcSpanFile, srcSpanToAnnSpan, AnnSpan, + commentSrcSpan, + ann, + transferEntryDP, + transferEntryDP', + AnnConstraint, + showAst, #if MIN_VERSION_ghc(9,4,0) -- * GHC 9.4 stuff @@ -101,7 +110,11 @@ ) where import Control.Monad.Trans.State.Strict (StateT) +#if MIN_VERSION_ghc(9,12,0) +import Data.Data (Data, Typeable) +#else import Data.Data (Data) +#endif import qualified GHC import GHC.Data.Bag (unitBag, bagToList) import GHC.Data.FastString (FastString, mkFastString) @@ -115,9 +128,9 @@ #endif import GHC.Driver.Session hiding (initDynFlags) #if MIN_VERSION_ghc(9,6,0) -import GHC.Hs hiding (Pat, Stmt, parseModuleName) +import GHC.Hs hiding (Pat, Stmt, parseModuleName, ann) #else -import GHC.Hs hiding (Pat, Stmt) +import GHC.Hs hiding (Pat, Stmt, ann) #endif import GHC.Parser.Header (getOptions) #if MIN_VERSION_ghc(9,8,0) @@ -148,7 +161,19 @@ import Language.Haskell.GHC.ExactPrint.Parsers (Parser) import Language.Haskell.GHC.ExactPrint.Utils import Refact.Types (Refactoring) +#if MIN_VERSION_ghc(9,12,0) +import qualified Language.Haskell.GHC.ExactPrint.Transform as Exact +#else +import Language.Haskell.GHC.ExactPrint (transferEntryDP, transferEntryDP', showAst) +#endif + +#if MIN_VERSION_ghc(9,12,0) +type AnnConstraint an = (NoAnn an, Semigroup an) +#else +type AnnConstraint an = (Monoid an) +#endif + type MonadFail' = MonadFail #if MIN_VERSION_ghc(9,6,0) @@ -164,14 +189,18 @@ ppp :: Errors -> [SDoc] #if MIN_VERSION_ghc(9,6,0) -ppp pst = concatMap unDecorated $ fmap ((diagnosticMessage (defaultDiagnosticOpts @GhcMessage)) . errMsgDiagnostic) $ bagToList $ getMessages pst +ppp = concatMap (unDecorated . diagnosticMessage (defaultDiagnosticOpts @GhcMessage) . errMsgDiagnostic) . bagToList . getMessages #elif MIN_VERSION_ghc(9,4,0) -ppp pst = concatMap unDecorated $ fmap (diagnosticMessage . errMsgDiagnostic) $ bagToList $ getMessages pst +ppp = concatMap (unDecorated . diagnosticMessage . errMsgDiagnostic) . bagToList . getMessages #else -ppp pst = concatMap unDecorated (errMsgDiagnostic <$> bagToList pst) +ppp = concatMap (unDecorated . errMsgDiagnostic) . bagToList #endif +#if MIN_VERSION_ghc(9,12,0) +type FunBind = HsMatchContext (LocatedN RdrName) +#else type FunBind = HsMatchContext GhcPs +#endif pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc pattern RealSrcLoc' r <- RealSrcLoc r _ where @@ -266,3 +295,35 @@ Int -> Refactoring SrcSpan -> IO mod + + +commentSrcSpan :: GHC.LEpaComment -> SrcSpan +#if MIN_VERSION_ghc(9,12,0) +commentSrcSpan (GHC.L (GHC.EpaSpan l) _) = l +commentSrcSpan (GHC.L (GHC.EpaDelta l _ _) _) = l +#elif MIN_VERSION_ghc(9,4,0) +commentSrcSpan (GHC.L (GHC.Anchor l _) _) = GHC.RealSrcSpan l Strict.Nothing +#else +commentSrcSpan (GHC.L (GHC.Anchor l _) _) = GHC.RealSrcSpan l Nothing +#endif + +#if MIN_VERSION_ghc(9,12,0) +transferEntryDP :: (Typeable t1, Typeable t2, Exact.HasTransform m) + => LocatedAn t1 a -> LocatedAn t2 b -> m (LocatedAn t2 b) +transferEntryDP a b = return $ Exact.transferEntryDP a b +#endif + +#if MIN_VERSION_ghc(9,12,0) +transferEntryDP' ::(Exact.HasTransform m) + => LHsDecl GhcPs -> LHsDecl GhcPs -> m (LHsDecl GhcPs) +transferEntryDP' a b = return $ Exact.transferEntryDP' a b +#endif + + +#if MIN_VERSION_ghc(9,12,0) +ann :: EpAnn a -> a +ann ls = GHC.anns ls +#else +ann :: SrcSpanAnn' a -> a +ann = GHC.ann +#endif diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -7,8 +8,8 @@ import Data.Generics hiding (Fixity) import Data.Maybe import qualified GHC -import Language.Haskell.GHC.ExactPrint -import Refact.Compat (Fixity (..), SourceText (..), occNameString, rdrNameOcc) +import Language.Haskell.GHC.ExactPrint hiding (transferEntryDP) +import Refact.Compat (Fixity (..), SourceText (..), occNameString, rdrNameOcc,transferEntryDP) import Refact.Utils -- | Rearrange infix expressions to account for fixity. @@ -31,10 +32,13 @@ mkOpAppRn :: [(String, GHC.Fixity)] -> GHC.SrcSpanAnnA -> +#if MIN_VERSION_ghc(9,12,0) + GHC.NoExtField -> +#else GHC.EpAnn [GHC.AddEpAnn] -> +#endif Expr -> -- Left operand; already rearranged - Expr -> - GHC.Fixity -> -- Operator and fixity + Expr -> GHC.Fixity -> -- Operator and fixity Expr -> -- Right operand (not an OpApp, but might -- be a NegApp) StateT () IO Expr @@ -151,4 +155,8 @@ -- Internal: help function for the above definitions. fixity :: GHC.FixityDirection -> Int -> [String] -> [(String, GHC.Fixity)] +#if MIN_VERSION_ghc(9,12,0) +fixity a p = map (,Fixity p a) +#else fixity a p = map (,Fixity (SourceText "") p a) +#endif diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -26,6 +27,10 @@ import Control.Monad.Trans.Maybe (MaybeT (..)) import Control.Monad.Trans.State.Strict import Data.Data +#if MIN_VERSION_ghc(9,10,0) +#else +import Data.Default +#endif import Data.Foldable (foldlM, for_) import Data.Functor.Identity (Identity (..)) import Data.Generics (everywhere, everywhereM, extM, listify, mkM, mkQ, mkT, something) @@ -37,6 +42,9 @@ import Data.Tuple.Extra import Debug.Trace import qualified GHC +#if MIN_VERSION_ghc(9,12,0) +import qualified GHC.Data.Strict as Strict +#endif import GHC.IO.Exception (IOErrorType (..)) import GHC.LanguageExtensions.Type (Extension (..)) import Language.Haskell.GHC.ExactPrint @@ -46,17 +54,29 @@ makeDeltaAst, runTransform, setEntryDP, - transferEntryDP, - transferEntryDP', ) import Language.Haskell.GHC.ExactPrint.ExactPrint ( EPOptions, +#if MIN_VERSION_ghc(9,12,0) +#else epRigidity, +#endif exactPrintWithOptions, stringOptions, ) import Language.Haskell.GHC.ExactPrint.Parsers +-- import Language.Haskell.GHC.ExactPrint.Types +#if MIN_VERSION_ghc(9,12,0) +#else import Language.Haskell.GHC.ExactPrint.Types + -- epRigidity, + -- Rigidity(..), +#endif +-- #if MIN_VERSION_ghc(9,12,0) +-- import Language.Haskell.GHC.ExactPrint.Utils (showAst) +-- #else +-- import Language.Haskell.GHC.ExactPrint.ExactPrint (showAst) +-- #endif import Language.Haskell.GHC.ExactPrint.Utils (ss2pos) import Refact.Compat ( AnnSpan, @@ -66,7 +86,7 @@ FunBind, Module, ReplaceWorker, - -- combineSrcSpans, + combineSrcSpansA, composeSrcSpan, getOptions, @@ -88,10 +108,20 @@ xopt_set, xopt_unset, pattern RealSrcSpan', + transferEntryDP, + transferEntryDP', + commentSrcSpan, +#if MIN_VERSION_ghc(9,12,0) +#else + ann, +#endif + #if MIN_VERSION_ghc(9,4,0) mkGeneratedHsDocString, - initParserOpts + initParserOpts, +#else #endif + AnnConstraint ) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R @@ -113,9 +143,14 @@ import System.IO.Error (mkIOError) import System.IO.Extra import System.IO.Unsafe (unsafePerformIO) +-- import qualified GHC refactOptions :: EPOptions Identity String +#if MIN_VERSION_ghc(9,12,0) +refactOptions = stringOptions +#else refactOptions = stringOptions {epRigidity = RigidLayout} +#endif -- | Apply a set of refactorings as supplied by hlint apply :: @@ -315,11 +350,19 @@ GHC.SameLine 0 -> GHC.DifferentLine 1 0 dp' -> dp' (GHC.L l' d') = setEntryDP (GHC.L l d) (GHC.DifferentLine 1 0) +#if MIN_VERSION_ghc(9,12,0) comment = GHC.L + (GHC.EpaDelta (GHC.RealSrcSpan r Strict.Nothing) dp GHC.NoComments) + (GHC.EpaComment (GHC.EpaLineComment newComment) r) + l'' = GHC.addCommentsToEpAnn l' (GHC.EpaComments [comment]) +#else + comment = + GHC.L (GHC.Anchor r (GHC.MovedAnchor dp)) (GHC.EpaComment (GHC.EpaLineComment newComment) r) l'' = GHC.addCommentsToSrcAnn l' (GHC.EpaComments [comment]) +#endif in GHC.L l'' d' else old RemoveAsKeyword {..} -> pure (removeAsKeyword m) @@ -333,6 +376,14 @@ modifyComment :: (Data a) => GHC.SrcSpan -> String -> a -> a modifyComment pos newComment = transformBi go where + +#if MIN_VERSION_ghc(9,12,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 +#else #if MIN_VERSION_ghc(9,4,0) newTok :: GHC.EpaCommentTok -> GHC.EpaCommentTok newTok (GHC.EpaDocComment _) = GHC.EpaDocComment $ mkGeneratedHsDocString newComment @@ -350,11 +401,12 @@ newTok (GHC.EpaBlockComment _) = GHC.EpaBlockComment newComment newTok GHC.EpaEofComment = GHC.EpaEofComment #endif +#endif go :: GHC.LEpaComment -> GHC.LEpaComment - go old@(GHC.L (GHC.Anchor l o) (GHC.EpaComment t r)) = - if ss2pos l == ss2pos (GHC.realSrcSpan pos) - then GHC.L (GHC.Anchor l o) (GHC.EpaComment (newTok t) r) + go old@(GHC.L anc (GHC.EpaComment t r)) = + if ss2pos (GHC.realSrcSpan $ commentSrcSpan old) == ss2pos (GHC.realSrcSpan pos) + then GHC.L anc (GHC.EpaComment (newTok t) r) else old droppedComments :: [Refactoring GHC.SrcSpan] -> Module -> Module -> Bool @@ -430,6 +482,19 @@ -- it is not specific enough. Instead we match on some bigger context which -- is contains the located name we want to replace. identSub :: Data a => a -> [(String, GHC.SrcSpan)] -> FunBind -> M FunBind +#if MIN_VERSION_ghc(9,12,0) +identSub m subs old@(GHC.FunRhs {mc_fun=name}) = + resolveRdrName' subst (findOrError m) old subs (GHC.unLoc name) + where + subst :: FunBind -> Name -> M FunBind + subst f@(GHC.FunRhs{}) new = do + -- Low level version as we need to combine the annotation information + -- from the template RdrName and the original VarPat. + -- modify . first $ + -- replaceAnnKey (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr) + pure $ f {GHC.mc_fun=new} + subst o _ = pure o +#else identSub m subs old@(GHC.FunRhs (GHC.L _ name) _ _) = resolveRdrName' subst (findOrError m) old subs name where @@ -441,6 +506,7 @@ -- replaceAnnKey (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr) pure $ GHC.FunRhs new b s subst o _ = pure o +#endif identSub _ _ e = pure e -- g is usually modifyAnnKey @@ -461,7 +527,7 @@ _ -> pure old resolveRdrName :: - (Data old, Data a, Data an, Typeable an, Monoid an) => + (Data old, Data a, Data an, Typeable an, AnnConstraint an) => a -> (AnnSpan -> M (GHC.LocatedAn an old)) -> GHC.LocatedAn an old -> @@ -470,7 +536,6 @@ M (GHC.LocatedAn an old) resolveRdrName m = resolveRdrName' (modifyAnnKey m) --- Substitute the template into the original AST. doGenReplacement :: forall ast a. DoGenReplacement GHC.AnnListItem ast a doGenReplacement _ p new old | p old = do @@ -488,10 +553,24 @@ let newFile = GHC.srcSpanFile newLocReal newLocal :: GHC.HsLocalBinds GHC.GhcPs newLocal = transformBi (setSrcSpanFile newFile) oldLocal - -- newLocalLoc = GHC.getLocA newLocal newLocalLoc = GHC.spanHsLocaLBinds newLocal + newMG :: GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) newMG = GHC.fun_matches newBind - GHC.L locMG [GHC.L locMatch newMatch] = GHC.mg_alts newMG + -- GHC.L locMG [GHC.L locMatch newMatch] = GHC.mg_alts newMG + -- locMG1 :: GHC.SrcSpanAnnLW + GHC.L locMG1 [GHC.L locMatch newMatch] = GHC.mg_alts newMG + -- xx :: GHC.SrcSpanAnnLW -> GHC.EpAnn (GHC.AnnList ()) + -- xx (GHC.EpAnn anc alw cs) = GHC.EpAnn anc (yy alw) cs + -- yy :: GHC.AnnList (GHC.EpToken "where") -> GHC.AnnList () + -- yy (GHC.AnnList anc bs semis _ lt) = GHC.AnnList anc bs semis () lt + -- = AnnList { + -- al_anchor :: !(Maybe EpaLocation), -- ^ start point of a list having layout + -- al_brackets :: !AnnListBrackets, + -- al_semis :: [EpToken ";"], -- decls + -- al_rest :: !a, + -- al_trailing :: ![TrailingAnn] -- ^ items appearing after the + + locMG = locMG1 newGRHSs = GHC.m_grhss newMatch finalLoc = combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) (GHC.getLoc new) newWithLocalBinds0 = @@ -501,7 +580,7 @@ newBind finalLoc newMG - (combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) locMG) + (combineSrcSpansLW (GHC.noAnnSrcSpan newLocalLoc) locMG) newMatch (combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) locMatch) newGRHSs @@ -511,6 +590,16 @@ pure $ composeSrcSpan newWithLocalBinds | otherwise = pure old + +#if MIN_VERSION_ghc(9,12,0) +combineSrcSpansLW :: GHC.SrcSpanAnnA -> GHC.SrcSpanAnnLW -> GHC.SrcSpanAnnLW +combineSrcSpansLW (GHC.EpAnn anca _ csa) (GHC.EpAnn ancb anb csb) + = GHC.EpAnn (anca <> ancb) anb (csa <> csb) +#else +combineSrcSpansLW :: Semigroup a => GHC.SrcAnn a -> GHC.SrcAnn a -> GHC.SrcAnn a +combineSrcSpansLW = combineSrcSpansA +#endif + -- | If the input is a FunBind with a single match, e.g., "foo a = body where x = y" -- return "Just (foo a = body, x = y)". Otherwise return Nothing. stripLocalBind :: @@ -521,9 +610,13 @@ | let origMG = GHC.fun_matches origBind, GHC.L locMG [GHC.L locMatch origMatch] <- GHC.mg_alts origMG, let origGRHSs = GHC.m_grhss origMatch, +#if MIN_VERSION_ghc(9,12,0) + [GHC.L loc2 _] <- GHC.grhssGRHSs origGRHSs -> +#else [GHC.L _ (GHC.GRHS _ _ (GHC.L loc2 _))] <- GHC.grhssGRHSs origGRHSs -> +#endif let loc1 = GHC.getLoc (GHC.fun_id origBind) - newLoc = combineSrcSpansA (GHC.l2l loc1) loc2 + newLoc = combineSrcSpansA (GHC.l2l loc1) (GHC.l2l loc2) withoutLocalBinds = setLocalBind (GHC.EmptyLocalBinds GHC.noExtField) @@ -545,7 +638,11 @@ GHC.HsBind GHC.GhcPs -> GHC.SrcSpanAnnA -> GHC.MatchGroup GHC.GhcPs Expr -> +#if MIN_VERSION_ghc(9,12,0) + GHC.SrcSpanAnnLW -> +#else GHC.SrcSpanAnnL -> +#endif GHC.Match GHC.GhcPs Expr -> GHC.SrcSpanAnnA -> GHC.GRHSs GHC.GhcPs Expr -> @@ -587,14 +684,22 @@ _ -> True e' = if isDo - && manchorOp an == Just (GHC.MovedAnchor (GHC.SameLine 0)) - && manchorOp (GHC.ann ls) == Just (GHC.MovedAnchor (GHC.SameLine 0)) +#if MIN_VERSION_ghc(9,12,0) + && manchorOp ls == Just (GHC.SameLine 0) +#else + && manchorOp an == Just (GHC.SameLine 0) + && manchorOp (GHC.ann ls) == Just (GHC.SameLine 0) +#endif then GHC.L l (GHC.HsDo an v (setEntryDP (GHC.L ls stmts) (GHC.SameLine 1))) else e ensureExprSpace e@(GHC.L l (GHC.HsApp x (GHC.L la a) (GHC.L lb b))) = e' -- ensureAppSpace where e' = - if manchorOp (GHC.ann lb) == Just (GHC.MovedAnchor (GHC.SameLine 0)) +#if MIN_VERSION_ghc(9,12,0) + if manchorOp lb == Just (GHC.SameLine 0) +#else + if manchorOp (ann lb) == Just (GHC.SameLine 0) +#endif then GHC.L l (GHC.HsApp x (GHC.L la a) (setEntryDP (GHC.L lb b) (GHC.SameLine 1))) else e ensureExprSpace e = e @@ -612,9 +717,14 @@ _ -> pure m replaceWorker m _ _ _ = pure m -manchorOp :: GHC.EpAnn ann -> Maybe GHC.AnchorOperation -manchorOp GHC.EpAnnNotUsed = Nothing -manchorOp (GHC.EpAnn a _ _) = Just (GHC.anchor_op a) +manchorOp :: GHC.EpAnn ann -> Maybe GHC.DeltaPos +#if MIN_VERSION_ghc(9,12,0) +manchorOp (GHC.EpAnn (GHC.EpaSpan{}) _ _) = Nothing +manchorOp (GHC.EpAnn (GHC.EpaDelta _ dp _) _ _) = Just dp +#else +manchorOp (GHC.EpAnn (GHC.Anchor _ (GHC.MovedAnchor dp)) _ _) = Just dp +manchorOp _ = Nothing +#endif data NotFound = NotFound { nfExpected :: String, @@ -681,10 +791,30 @@ -- Deletion from a list doDeleteStmt :: Data a => (Stmt -> Bool) -> a -> a -doDeleteStmt = transformBi . filter +doDeleteStmt = transformBi . filterAndSetDP doDeleteImport :: Data a => (Import -> Bool) -> a -> a -doDeleteImport = transformBi . filter +doDeleteImport = transformBi . filterAndSetDP + +-- | Like `filter`, but after filtering one or multiple consecutive elements +-- out, it applies `setEntryDP` to the next element. +filterAndSetDP :: + forall t a. +#if MIN_VERSION_ghc(9,10,0) +#else + (Default t) => +#endif + (GHC.LocatedAn t a -> Bool) -> + [GHC.LocatedAn t a] -> + [GHC.LocatedAn t a] +filterAndSetDP p = go + where + go xs = case break p xs of + (_, []) -> [] + -- No prefix is filtered out; do not apply `setEntryDP` to `y` + ([], y : ys) -> y : go ys + -- Some prefix is filtered out; apply `setEntryDP` to `y` + (_ : _, y : ys) -> setEntryDP y (GHC.SameLine 0) : go ys addExtensionsToFlags :: [Extension] -> diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs --- a/src/Refact/Run.hs +++ b/src/Refact/Run.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Refact.Run (refactMain, runPipe) where @@ -7,7 +8,11 @@ import Data.Maybe import Data.Version import Debug.Trace +#if MIN_VERSION_ghc(9,12,0) +import Language.Haskell.GHC.ExactPrint.Utils (showAst) +#else import Language.Haskell.GHC.ExactPrint.ExactPrint (showAst) +#endif import qualified GHC.Paths import Options.Applicative import Paths_apply_refact diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -39,7 +40,7 @@ import Data.Generics (everywhere, mkT) import Data.Typeable import qualified GHC -import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint hiding (transferEntryDP) import Refact.Compat ( AnnSpan, FastString, @@ -52,10 +53,12 @@ setSrcSpanFile, srcSpanToAnnSpan, pattern RealSrcLoc', - pattern RealSrcSpan', + pattern RealSrcSpan', AnnConstraint, + transferEntryDP ) import qualified Refact.Types as R + -- Types -- type M a = StateT (Anns, AnnKeyMap) IO a type M a = StateT () IO a @@ -92,7 +95,7 @@ -- GHC.Located new -> -- M (GHC.Located new) modifyAnnKey :: - (Data mod, Data t, Data old, Data new, Monoid t, Typeable t) => + (Data mod, Data t, Data old, Data new, AnnConstraint t, Typeable t) => mod -> GHC.LocatedAn t old -> GHC.LocatedAn t new -> @@ -118,10 +121,11 @@ -- should keep the backquotes, but currently no test case fails because of it. handleBackquotes :: forall t old new. - (Data t, Data old, Data new, Monoid t, Typeable t) => + (Data t, Data old, Data new, AnnConstraint t, Typeable t) => GHC.LocatedAn t old -> GHC.LocatedAn t new -> GHC.LocatedAn t new +#if MIN_VERSION_ghc(9,12,0) handleBackquotes old new@(GHC.L loc _) = everywhere (mkT update) new where @@ -131,6 +135,29 @@ ln' = if GHC.locA l == GHC.locA loc then case cast old :: Maybe (GHC.LHsExpr GHC.GhcPs) of + Just (GHC.L _ (GHC.HsVar _ (GHC.L (GHC.EpAnn _ ann _) _))) + -- scenario 1 + | GHC.NameAnn (GHC.NameBackquotes _ _) _ _ <- ann -> + case ln of + (GHC.EpAnn a _ cs) -> (GHC.EpAnn a ann cs) + -- scenario 2 + | (GHC.EpAnn a ann' cs) <- ln, + GHC.NameAnn (GHC.NameBackquotes _ _) _ _ <- ann' -> + (GHC.EpAnn a ann cs) + Just _ -> ln + Nothing -> ln + else ln + update x = x +#else +handleBackquotes old new@(GHC.L loc _) = + everywhere (mkT update) new + where + update :: GHC.LHsExpr GHC.GhcPs -> GHC.LHsExpr GHC.GhcPs + update (GHC.L l (GHC.HsVar x (GHC.L ln n))) = GHC.L l (GHC.HsVar x (GHC.L ln' n)) + where + ln' = + if GHC.locA l == GHC.locA loc + then case cast old :: Maybe (GHC.LHsExpr GHC.GhcPs) of Just (GHC.L _ (GHC.HsVar _ (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn _ ann _) _) _))) -- scenario 1 | GHC.NameAnn GHC.NameBackquotes _ _ _ _ <- ann -> @@ -146,6 +173,7 @@ Nothing -> ln else ln update x = x +#endif -- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@ toGhcSrcSpan :: FilePath -> R.SrcSpan -> GHC.SrcSpan diff --git a/tests/examples/Import2.hs.expected b/tests/examples/Import2.hs.expected --- a/tests/examples/Import2.hs.expected +++ b/tests/examples/Import2.hs.expected @@ -1,1 +1,1 @@ - import A +import A diff --git a/tests/examples/Import7.hs.expected b/tests/examples/Import7.hs.expected --- a/tests/examples/Import7.hs.expected +++ b/tests/examples/Import7.hs.expected @@ -1,1 +1,1 @@ - import A as Y +import A as Y