From 739e82a20b089f5469a8372ed6f1f72558959462 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 28 Nov 2024 18:10:18 +0000 Subject: [PATCH 1/6] WIP on ghc 9.12.1 support --- apply-refact.cabal | 5 ++- src/Refact/Compat.hs | 45 +++++++++++++++++++++- src/Refact/Internal.hs | 84 ++++++++++++++++++++++++++++++++++++------ src/Refact/Utils.hs | 34 +++++++++++++++++ 4 files changed, 154 insertions(+), 14 deletions(-) diff --git a/apply-refact.cabal b/apply-refact.cabal index abf3920..a6944f9 100644 --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -22,7 +22,7 @@ extra-source-files: tests/examples/*.hs.expected tests/examples/*.hs.refact -tested-with: GHC ==9.2.8 || ==9.4.6 || ==9.6.6 || ==9.8.2 +tested-with: GHC ==9.2.8 || ==9.4.6 || ==9.6.6 || ==9.8.2 || ==9.12.1 source-repository head type: git @@ -44,8 +44,9 @@ library , 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 + , ghc-exactprint ^>=1.5.0 || ^>=1.6.0 || ^>=1.7.0 || ^>=1.8.0 || ^>=1.11.0 , process >=1.6 , refact >=0.2 , syb >=0.7.1 diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs index f497969..1bdb96c 100644 --- 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,9 @@ module Refact.Compat ( setSrcSpanFile, srcSpanToAnnSpan, AnnSpan, + commentSrcSpan, + ann, + transferEntryDP, #if MIN_VERSION_ghc(9,4,0) -- * GHC 9.4 stuff @@ -101,7 +107,11 @@ module Refact.Compat ( ) 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,7 +125,7 @@ import GHC.Driver.Errors.Types (ErrorMessages, ghcUnknownMessage, GhcMessage) #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) #endif @@ -148,6 +158,11 @@ import GHC.Utils.Panic 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) +#endif type MonadFail' = MonadFail @@ -171,7 +186,11 @@ ppp pst = concatMap unDecorated $ fmap (diagnosticMessage . errMsgDiagnostic) $ ppp pst = concatMap unDecorated (errMsgDiagnostic <$> bagToList pst) #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 +285,27 @@ type ReplaceWorker a mod = 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 +#else +commentSrcSpan (GHC.L (GHC.Anchor l _) _) = GHC.RealSrcSpan l Strict.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) +ann :: EpAnn a -> EpAnn a +ann ls = ls +#else +ann :: SrcSpanAnn' a -> a +ann = GHC.ann +#endif diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs index 69338dd..43837cc 100644 --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -41,6 +41,9 @@ import Data.Ord (comparing) 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 @@ -50,12 +53,14 @@ import Language.Haskell.GHC.ExactPrint makeDeltaAst, runTransform, setEntryDP, - transferEntryDP, transferEntryDP', ) import Language.Haskell.GHC.ExactPrint.ExactPrint ( EPOptions, +#if MIN_VERSION_ghc(9,12,0) +#else epRigidity, +#endif exactPrintWithOptions, stringOptions, ) @@ -92,6 +97,9 @@ import Refact.Compat xopt_set, xopt_unset, pattern RealSrcSpan', + transferEntryDP, + commentSrcSpan, + ann, #if MIN_VERSION_ghc(9,4,0) mkGeneratedHsDocString, initParserOpts @@ -117,9 +125,14 @@ import Refact.Utils 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 :: @@ -319,11 +332,19 @@ runRefactoring m = \case 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) @@ -337,6 +358,14 @@ runRefactoring m = \case 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 @@ -353,12 +382,13 @@ modifyComment pos newComment = transformBi go newTok (GHC.EpaLineComment _) = GHC.EpaLineComment newComment 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 @@ -434,6 +464,19 @@ exprSub _ _ e = pure e -- 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 @@ -445,6 +488,7 @@ identSub m subs old@(GHC.FunRhs (GHC.L _ name) _ _) = -- 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 @@ -505,7 +549,7 @@ doGenReplacement _ p new old newBind finalLoc newMG - (combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) locMG) + (combineSrcSpansLW (GHC.noAnnSrcSpan newLocalLoc) locMG) newMatch (combineSrcSpansA (GHC.noAnnSrcSpan newLocalLoc) locMatch) newGRHSs @@ -515,6 +559,15 @@ doGenReplacement _ p new old pure $ composeSrcSpan newWithLocalBinds | otherwise = pure old + +#if MIN_VERSION_ghc(9,12,0) +combineSrcSpansLW :: Semigroup a => GHC.EpAnn a -> EpAnn b -> EpAnn b +combineSrcSpansLW aa ab = aa <> ab +#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 :: @@ -555,7 +608,11 @@ setLocalBind :: GHC.MatchGroup GHC.GhcPs Expr -> GHC.SrcSpanAnnL -> GHC.Match GHC.GhcPs Expr -> +#if MIN_VERSION_ghc(9,12,0) + GHC.SrcSpanAnnLW -> +#else GHC.SrcSpanAnnA -> +#endif GHC.GRHSs GHC.GhcPs Expr -> Decl setLocalBind newLocalBinds xvald origBind newLoc origMG locMG origMatch locMatch origGRHSs = @@ -595,14 +652,14 @@ replaceWorker m parser seed Replace {..} = do _ -> True e' = if isDo - && manchorOp an == Just (GHC.MovedAnchor (GHC.SameLine 0)) - && manchorOp (GHC.ann ls) == Just (GHC.MovedAnchor (GHC.SameLine 0)) + && manchorOp an == Just (GHC.SameLine 0) + && manchorOp (ann ls) == Just (GHC.SameLine 0) 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 manchorOp (ann lb) == Just (GHC.SameLine 0) then GHC.L l (GHC.HsApp x (GHC.L la a) (setEntryDP (GHC.L lb b) (GHC.SameLine 1))) else e ensureExprSpace e = e @@ -620,9 +677,14 @@ replaceWorker m parser seed Replace {..} = do _ -> 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, diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs index c957d07..4feac9e 100644 --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -39,7 +40,11 @@ import Data.Data import Data.Generics (everywhere, mkT) import Data.Typeable import qualified GHC +#if MIN_VERSION_ghc(9,12,0) +import Language.Haskell.GHC.ExactPrint hiding (transferEntryDP) +#else import Language.Haskell.GHC.ExactPrint +#endif import Refact.Compat ( AnnSpan, FastString, @@ -53,9 +58,13 @@ import Refact.Compat srcSpanToAnnSpan, pattern RealSrcLoc', pattern RealSrcSpan', +#if MIN_VERSION_ghc(9,12,0) + transferEntryDP, +#endif ) import qualified Refact.Types as R + -- Types -- type M a = StateT (Anns, AnnKeyMap) IO a type M a = StateT () IO a @@ -122,6 +131,30 @@ handleBackquotes :: 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 + 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.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 @@ -146,6 +179,7 @@ handleBackquotes old new@(GHC.L loc _) = Nothing -> ln else ln update x = x +#endif -- | Convert a @Refact.Types.SrcSpan@ to a @SrcLoc.SrcSpan@ toGhcSrcSpan :: FilePath -> R.SrcSpan -> GHC.SrcSpan From 166f6d1a63f4c79080947ff07b8218f1dd2ab12a Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 28 Nov 2024 20:15:44 +0000 Subject: [PATCH 2/6] Initial part compiles enough for typechecker to kick in --- src/Refact/Compat.hs | 13 ++++++++++--- src/Refact/Internal.hs | 39 +++++++++++++++++++++++++++------------ 2 files changed, 37 insertions(+), 15 deletions(-) diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs index 1bdb96c..ac15508 100644 --- a/src/Refact/Compat.hs +++ b/src/Refact/Compat.hs @@ -99,6 +99,7 @@ module Refact.Compat ( commentSrcSpan, ann, transferEntryDP, + transferEntryDP', #if MIN_VERSION_ghc(9,4,0) -- * GHC 9.4 stuff @@ -161,7 +162,7 @@ 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) +import Language.Haskell.GHC.ExactPrint (transferEntryDP, transferEntryDP') #endif type MonadFail' = MonadFail @@ -301,10 +302,16 @@ transferEntryDP :: (Typeable t1, Typeable t2, Exact.HasTransform m) 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 -> EpAnn a -ann ls = ls +ann :: EpAnn a -> a +ann ls = GHC.anns ls #else ann :: SrcSpanAnn' a -> a ann = GHC.ann diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs index 43837cc..b4f340d 100644 --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -53,7 +54,6 @@ import Language.Haskell.GHC.ExactPrint makeDeltaAst, runTransform, setEntryDP, - transferEntryDP', ) import Language.Haskell.GHC.ExactPrint.ExactPrint ( EPOptions, @@ -98,6 +98,7 @@ import Refact.Compat xopt_unset, pattern RealSrcSpan', transferEntryDP, + transferEntryDP', commentSrcSpan, ann, #if MIN_VERSION_ghc(9,4,0) @@ -518,7 +519,6 @@ resolveRdrName :: 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 @@ -536,10 +536,24 @@ doGenReplacement _ p new old 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 = @@ -561,8 +575,9 @@ doGenReplacement _ p new old #if MIN_VERSION_ghc(9,12,0) -combineSrcSpansLW :: Semigroup a => GHC.EpAnn a -> EpAnn b -> EpAnn b -combineSrcSpansLW aa ab = aa <> ab +combineSrcSpansLW :: GHC.SrcSpanAnnA -> GHC.SrcSpanAnnLW -> GHC.SrcSpanAnnLW +combineSrcSpansLW (GHC.EpAnn anca an 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 @@ -606,13 +621,13 @@ setLocalBind :: GHC.HsBind GHC.GhcPs -> GHC.SrcSpanAnnA -> GHC.MatchGroup GHC.GhcPs Expr -> - GHC.SrcSpanAnnL -> - GHC.Match GHC.GhcPs Expr -> #if MIN_VERSION_ghc(9,12,0) GHC.SrcSpanAnnLW -> #else - GHC.SrcSpanAnnA -> + GHC.SrcSpanAnnL -> #endif + GHC.Match GHC.GhcPs Expr -> + GHC.SrcSpanAnnA -> GHC.GRHSs GHC.GhcPs Expr -> Decl setLocalBind newLocalBinds xvald origBind newLoc origMG locMG origMatch locMatch origGRHSs = @@ -652,14 +667,14 @@ replaceWorker m parser seed Replace {..} = do _ -> True e' = if isDo - && manchorOp an == Just (GHC.SameLine 0) - && manchorOp (ann ls) == Just (GHC.SameLine 0) + && manchorOp ls == Just (GHC.SameLine 0) 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 (ann lb) == Just (GHC.SameLine 0) + -- if manchorOp (ann (_ lb)) == Just (GHC.SameLine 0) + if manchorOp lb == Just (GHC.SameLine 0) then GHC.L l (GHC.HsApp x (GHC.L la a) (setEntryDP (GHC.L lb b) (GHC.SameLine 1))) else e ensureExprSpace e = e From 323236d0dd1b5184e35b23fe9bfca388985be5cd Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 28 Nov 2024 21:08:57 +0000 Subject: [PATCH 3/6] Tests Run, 15/449 fail --- src/Refact/Compat.hs | 11 ++++++++++- src/Refact/Fixity.hs | 13 +++++++++++-- src/Refact/Internal.hs | 16 ++++++++-------- src/Refact/Run.hs | 5 +++++ src/Refact/Utils.hs | 14 ++++---------- 5 files changed, 38 insertions(+), 21 deletions(-) diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs index ac15508..55a7f40 100644 --- a/src/Refact/Compat.hs +++ b/src/Refact/Compat.hs @@ -100,6 +100,8 @@ module Refact.Compat ( ann, transferEntryDP, transferEntryDP', + AnnConstraint, + showAst, #if MIN_VERSION_ghc(9,4,0) -- * GHC 9.4 stuff @@ -162,7 +164,14 @@ 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') +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 diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs index f27cc8e..3fd55aa 100644 --- 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 Control.Monad.Trans.State 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,7 +32,11 @@ getIdent _ = error "Must be HsVar" 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 @@ -151,4 +156,8 @@ infix_ = fixity GHC.InfixN -- 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 index b4f340d..ab096f2 100644 --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -65,7 +65,7 @@ import Language.Haskell.GHC.ExactPrint.ExactPrint stringOptions, ) import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.GHC.ExactPrint.Types +-- import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils (ss2pos) import Refact.Compat ( AnnSpan, @@ -75,7 +75,7 @@ import Refact.Compat FunBind, Module, ReplaceWorker, - -- combineSrcSpans, + combineSrcSpansA, composeSrcSpan, getOptions, @@ -100,11 +100,11 @@ import Refact.Compat transferEntryDP, transferEntryDP', commentSrcSpan, - ann, -#if MIN_VERSION_ghc(9,4,0) + -- ann, + mkGeneratedHsDocString, - initParserOpts -#endif + initParserOpts, AnnConstraint + ) import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R @@ -510,7 +510,7 @@ resolveRdrName' g f old subs name = _ -> 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 -> @@ -576,7 +576,7 @@ doGenReplacement _ p new old #if MIN_VERSION_ghc(9,12,0) combineSrcSpansLW :: GHC.SrcSpanAnnA -> GHC.SrcSpanAnnLW -> GHC.SrcSpanAnnLW -combineSrcSpansLW (GHC.EpAnn anca an csa) (GHC.EpAnn ancb anb csb) +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 diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs index e7c9b81..9ff6f0a 100644 --- 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.List hiding (find) 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 index 4feac9e..c499534 100644 --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -40,11 +40,7 @@ import Data.Data import Data.Generics (everywhere, mkT) import Data.Typeable import qualified GHC -#if MIN_VERSION_ghc(9,12,0) import Language.Haskell.GHC.ExactPrint hiding (transferEntryDP) -#else -import Language.Haskell.GHC.ExactPrint -#endif import Refact.Compat ( AnnSpan, FastString, @@ -57,10 +53,8 @@ import Refact.Compat setSrcSpanFile, srcSpanToAnnSpan, pattern RealSrcLoc', - pattern RealSrcSpan', -#if MIN_VERSION_ghc(9,12,0) - transferEntryDP, -#endif + pattern RealSrcSpan', AnnConstraint, + transferEntryDP ) import qualified Refact.Types as R @@ -101,7 +95,7 @@ getAnnSpan = srcSpanToAnnSpan . GHC.getLoc -- 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 -> @@ -127,7 +121,7 @@ modifyAnnKey _m e1 e2 = do -- 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 From 714516c13398a0180a834a93381f8a0947771b04 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 2 Dec 2024 13:04:08 +0000 Subject: [PATCH 4/6] Restore GHC 9.8.2 --- src/Refact/Internal.hs | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs index ab096f2..197dc60 100644 --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -66,6 +66,12 @@ import Language.Haskell.GHC.ExactPrint.ExactPrint ) 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 import Language.Haskell.GHC.ExactPrint.Utils (ss2pos) import Refact.Compat ( AnnSpan, @@ -100,7 +106,10 @@ import Refact.Compat transferEntryDP, transferEntryDP', commentSrcSpan, - -- ann, +#if MIN_VERSION_ghc(9,12,0) +#else + ann, +#endif mkGeneratedHsDocString, initParserOpts, AnnConstraint @@ -540,7 +549,7 @@ doGenReplacement _ p new old 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 - locMG1 :: GHC.SrcSpanAnnLW + -- 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 @@ -667,14 +676,22 @@ replaceWorker m parser seed Replace {..} = do _ -> True e' = if isDo +#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 (ann (_ lb)) == Just (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 From f7819f57aea3f0c565cd56840f9415b6b2d8ef92 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 2 Dec 2024 17:50:16 +0000 Subject: [PATCH 5/6] Tweak, so comment makes sense --- src/Refact/Fixity.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs index 3fd55aa..ceec453 100644 --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -38,8 +38,7 @@ mkOpAppRn :: 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 From 72b467de74ca0c5e003aa363c8c37310a4efd5c7 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 21 Jan 2025 20:08:05 +0000 Subject: [PATCH 6/6] Tests now pass, using updated ghc-exactprint v1.12 --- apply-refact.cabal | 2 +- src/Refact/Internal.hs | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/apply-refact.cabal b/apply-refact.cabal index a6944f9..bd25c7e 100644 --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -46,7 +46,7 @@ library , 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.11.0 + , 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 diff --git a/src/Refact/Internal.hs b/src/Refact/Internal.hs index 197dc60..8b75884 100644 --- a/src/Refact/Internal.hs +++ b/src/Refact/Internal.hs @@ -72,6 +72,11 @@ 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,