retrie 1.2.0.1 → 1.2.1
raw patch · 14 files changed
+257/−32 lines, 14 filesdep ~basedep ~ghcdep ~ghc-exactprint
Dependency ranges changed: base, ghc, ghc-exactprint
Files
- Retrie/CPP.hs +17/−0
- Retrie/Context.hs +9/−0
- Retrie/ExactPrint.hs +9/−5
- Retrie/ExactPrint/Annotated.hs +3/−4
- Retrie/Expr.hs +64/−3
- Retrie/Fixity.hs +2/−4
- Retrie/GHC.hs +4/−0
- Retrie/Options.hs +5/−1
- Retrie/PatternMap/Instances.hs +109/−4
- Retrie/Rewrites.hs +4/−0
- Retrie/Rewrites/Function.hs +4/−0
- Retrie/Rewrites/Patterns.hs +11/−1
- Retrie/Substitution.hs +1/−1
- retrie.cabal +15/−9
Retrie/CPP.hs view
@@ -3,6 +3,7 @@ -- This source code is licensed under the MIT license found in the -- LICENSE file in the root directory of this source tree. --+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Retrie.CPP@@ -26,6 +27,10 @@ import Retrie.ExactPrint import Retrie.GHC import Retrie.Replace+#if __GLASGOW_HASKELL__ < 904+#else+import GHC.Types.PkgQual+#endif -- Note [CPP] -- We can't just run the pre-processor on files and then rewrite them, because@@ -342,8 +347,20 @@ && ((==) `on` ideclQualified) x y && ((==) `on` ideclAs) x y && ((==) `on` ideclHiding) x y+#if __GLASGOW_HASKELL__ < 904 && ((==) `on` ideclPkgQual) x y+#else+ && (eqRawPkgQual `on` ideclPkgQual) x y+#endif && ((==) `on` ideclSource) x y && ((==) `on` ideclSafe) x y -- intentionally leave out ideclImplicit and ideclSourceSrc -- former doesn't matter for this check, latter is prone to whitespace issues+#if __GLASGOW_HASKELL__ < 904+#else+ where+ eqRawPkgQual NoRawPkgQual NoRawPkgQual = True+ eqRawPkgQual NoRawPkgQual (RawPkgQual _) = False+ eqRawPkgQual (RawPkgQual _) NoRawPkgQual = False+ eqRawPkgQual (RawPkgQual s) (RawPkgQual s') = s == s'+#endif
Retrie/Context.hs view
@@ -11,6 +11,11 @@ ( ContextUpdater , updateContext , emptyContext+ -- internal details useful for custom ContextUpdater+ , addInScope+ , addBinders+ , updateSubstitution+ , updateBinder ) where import Control.Monad.IO.Class@@ -61,7 +66,11 @@ -- In left child, prec is 10, so HsApp child will NOT get paren'd -- In right child, prec is 11, so every child gets paren'd (unless atomic) updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }+#if __GLASGOW_HASKELL__ < 904 updExp (HsLet _ lbs _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs+#else+ updExp (HsLet _ _ lbs _ _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs+#endif updExp _ = neverParen updType :: HsType GhcPs -> Context
Retrie/ExactPrint.hs view
@@ -257,14 +257,16 @@ -- Compatibility module with ghc-exactprint parseContentNoFixity :: Parsers.LibDir -> FilePath -> String -> IO AnnotatedModule-parseContentNoFixity libdir fp str = do+parseContentNoFixity libdir fp str = join $ Parsers.withDynFlags libdir $ \dflags -> do r <- Parsers.parseModuleFromString libdir fp str case r of Left msg -> do-#if __GLASGOW_HASKELL__ < 810+#if __GLASGOW_HASKELL__ < 900 fail $ show msg-#else+#elif __GLASGOW_HASKELL__ < 904 fail $ show $ bagToList msg+#else+ fail $ showSDoc dflags $ ppr msg #endif Right m -> return $ unsafeMkA (makeDeltaAst m) 0 @@ -314,10 +316,12 @@ => Parsers.LibDir -> FilePath -> Parsers.Parser a -> String -> IO (Annotated a) parseHelper libdir fp parser str = join $ Parsers.withDynFlags libdir $ \dflags -> case parser dflags fp str of-#if __GLASGOW_HASKELL__ < 810+#if __GLASGOW_HASKELL__ < 900 Left (_, msg) -> throwIO $ ErrorCall msg-#else+#elif __GLASGOW_HASKELL__ < 904 Left errBag -> throwIO $ ErrorCall (show $ bagToList errBag)+#else+ Left msg -> throwIO $ ErrorCall (showSDoc dflags $ ppr msg) #endif Right x -> return $ unsafeMkA (makeDeltaAst x) 0
Retrie/ExactPrint/Annotated.hs view
@@ -87,13 +87,12 @@ def = Annotated D.def 0 instance (Data ast, Monoid ast) => Semigroup (Annotated ast) where- (<>) = mappend+ a1 <> (Annotated ast2 _) =+ runIdentity $ transformA a1 $ \ ast1 ->+ mappend ast1 <$> return ast2 instance (Data ast, Monoid ast) => Monoid (Annotated ast) where mempty = Annotated mempty 0- mappend a1 (Annotated ast2 _) =- runIdentity $ transformA a1 $ \ ast1 ->- mappend ast1 <$> return ast2 -- | Construct an 'Annotated'. -- This should really only be used in the parsing functions, hence the scary name.
Retrie/Expr.hs view
@@ -14,6 +14,7 @@ , grhsToExpr , mkApps , mkConPatIn+ , mkEpAnn , mkHsAppsTy , mkLams , mkLet@@ -138,6 +139,7 @@ mkLet :: Monad m => HsLocalBinds GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs) mkLet EmptyLocalBinds{} e = return e mkLet lbs e = do+#if __GLASGOW_HASKELL__ < 904 an <- mkEpAnn (DifferentLine 1 5) (AnnsLet { alLet = EpaDelta (SameLine 0) [],@@ -145,8 +147,13 @@ }) le <- mkLocA (SameLine 1) $ HsLet an lbs e return le--+#else+ an <- mkEpAnn (DifferentLine 1 5) NoEpAnns+ let tokLet = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ tokIn = L (TokenLoc (EpaDelta (DifferentLine 1 1) [])) HsTok+ le <- mkLocA (SameLine 1) $ HsLet an tokLet lbs tokIn e+ return le+#endif mkApps :: MonadIO m => LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT m (LHsExpr GhcPs) mkApps e [] = return e@@ -261,9 +268,17 @@ negE <- maybe (return e) (mkLocA (SameLine 0) . NegApp noAnn e) mbNeg -- addAllAnnsT llit negE return negE+#if __GLASGOW_HASKELL__ < 904 go (ParPat an p') = do p <- patToExpr p' lift $ mkLocA (SameLine 1) (HsPar an p)+#else+ go (ParPat an _ p' _) = do+ p <- patToExpr p'+ let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ lift $ mkLocA (SameLine 1) (HsPar an tokLP p tokRP)+#endif go SigPat{} = error "patToExpr SigPat" go (TuplePat an ps boxity) = do es <- forM ps $ \pat -> do@@ -311,8 +326,15 @@ parenify :: Monad m => Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs) parenify Context{..} le@(L _ e)+#if __GLASGOW_HASKELL__ < 904 | needed ctxtParentPrec (precedence ctxtFixityEnv e) && needsParens e = mkParen' (getEntryDP le) (\an -> HsPar an (setEntryDP le (SameLine 0)))+#else+ | needed ctxtParentPrec (precedence ctxtFixityEnv e) && needsParens e = do+ let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ in mkParen' (getEntryDP le) (\an -> HsPar an tokLP (setEntryDP le (SameLine 0)) tokRP)+#endif | otherwise = return le where {- parent -} {- child -}@@ -327,7 +349,11 @@ -- TODO: what about comments? unparen :: LHsExpr GhcPs -> LHsExpr GhcPs+#if __GLASGOW_HASKELL__ < 904 unparen (L _ (HsPar _ e)) = e+#else+unparen (L _ (HsPar _ _ e _)) = e+#endif unparen e = e -- | hsExprNeedsParens is not always up-to-date, so this allows us to override@@ -342,6 +368,7 @@ (e0,pe0) <- swapEntryDPT e pe return pe0 +#if __GLASGOW_HASKELL__ < 904 mkParen' :: (Data x, Monad m, Monoid an) => DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x) mkParen' dp k = do@@ -350,7 +377,26 @@ let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0)) pe <- mkLocA dp (k (EpAnn anc an emptyComments)) return pe+#else+mkParen' :: (Data x, Monad m, Monoid an)+ => DeltaPos -> (EpAnn NoEpAnns -> x) -> TransformT m (LocatedAn an x)+mkParen' dp k = do+ let an = NoEpAnns+ l <- uniqueSrcSpanT+ let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))+ pe <- mkLocA dp (k (EpAnn anc an emptyComments))+ return pe +mkParenTy :: (Data x, Monad m, Monoid an)+ => DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)+mkParenTy dp k = do+ let an = AnnParen AnnParens d0 d0+ l <- uniqueSrcSpanT+ let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))+ pe <- mkLocA dp (k (EpAnn anc an emptyComments))+ return pe+#endif+ -- This explicitly operates on 'Located (Pat GhcPs)' instead of 'LPat GhcPs' -- because it is applied at that type by SYB. parenifyP@@ -361,7 +407,13 @@ parenifyP Context{..} p@(L _ pat) | IsLhs <- ctxtParentPrec , needed pat =+#if __GLASGOW_HASKELL__ < 904 mkParen' (getEntryDP p) (\an -> ParPat an (setEntryDP p (SameLine 0)))+#else+ let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+ in mkParen' (getEntryDP p) (\an -> ParPat an tokLP (setEntryDP p (SameLine 0)) tokRP)+#endif | otherwise = return p where needed BangPat{} = False@@ -384,7 +436,12 @@ parenifyT :: Monad m => Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs) parenifyT Context{..} lty@(L _ ty)- | needed ty = mkParen' (getEntryDP lty) (\an -> HsParTy an (setEntryDP lty (SameLine 0)))+ | needed ty =+#if __GLASGOW_HASKELL__ < 904+ mkParen' (getEntryDP lty) (\an -> HsParTy an (setEntryDP lty (SameLine 0)))+#else+ mkParenTy (getEntryDP lty) (\an -> HsParTy an (setEntryDP lty (SameLine 0)))+#endif | otherwise = return lty where needed HsAppTy{}@@ -397,7 +454,11 @@ unparenT ty = ty unparenP :: LPat GhcPs -> LPat GhcPs+#if __GLASGOW_HASKELL__ < 904 unparenP (L _ (ParPat _ p)) = p+#else+unparenP (L _ (ParPat _ _ p _)) = p+#endif unparenP p = p --------------------------------------------------------------------
Retrie/Fixity.hs view
@@ -22,12 +22,10 @@ instance Semigroup FixityEnv where -- | 'mappend' for 'FixityEnv' is right-biased- (<>) = mappend+ (FixityEnv e1) <> (FixityEnv e2) = FixityEnv (plusFsEnv e1 e2) instance Monoid FixityEnv where mempty = mkFixityEnv []- -- | 'mappend' for 'FixityEnv' is right-biased- mappend (FixityEnv e1) (FixityEnv e2) = FixityEnv (plusFsEnv e1 e2) lookupOp :: LHsExpr GhcPs -> FixityEnv -> Fixity lookupOp (L _ e) | Just n <- varRdrName e = lookupOpRdrName n@@ -45,7 +43,7 @@ FixityEnv $ extendFsEnvList env [ (fs, p) | p@(fs,_) <- l ] ppFixityEnv :: FixityEnv -> String-ppFixityEnv = unlines . map ppFixity . eltsUFM . unFixityEnv+ppFixityEnv = unlines . map ppFixity . nonDetEltsUFM . unFixityEnv where ppFixity (fs, Fixity _ p d) = unwords [ case d of
Retrie/GHC.hs view
@@ -15,6 +15,7 @@ , module GHC.Hs.Expr , module GHC.Parser.Annotation , module GHC.Parser.Errors.Ppr+ , module GHC.Plugins , module GHC.Types.Basic , module GHC.Types.Error , module GHC.Types.Fixity@@ -27,6 +28,7 @@ , module GHC.Types.Unique.FM , module GHC.Types.Unique.Set , module GHC.Unit.Module.Name+ , module GHC.Utils.Outputable ) where import GHC@@ -39,6 +41,7 @@ import GHC.Hs.Expr import GHC.Parser.Annotation import GHC.Parser.Errors.Ppr+import GHC.Plugins (showSDoc) import GHC.Types.Basic hiding (EP) import GHC.Types.Error import GHC.Types.Fixity@@ -51,6 +54,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Unit.Module.Name+import GHC.Utils.Outputable (Outputable (ppr)) import Data.Bifunctor (second) import Data.Maybe
Retrie/Options.hs view
@@ -465,13 +465,17 @@ hsExtension = "\"*.hs\"" - esc s = "'" ++ intercalate "[[:space:]]\\+" (words $ escChars s) ++ "'"+ esc s = osquote $ intercalate "[[:space:]]\\+" (words $ escChars s) escChars = concatMap escChar escChar c | c `elem` magicChars = "\\" <> [c] | otherwise = [c] magicChars :: [Char] magicChars = "*?[#˜=%\\"++ osquote s = "'" ++ concatMap escapeQuote s ++ "'"+ where escapeQuote '\'' = "'\"'\"'"+ escapeQuote c = [c] type CommandLine = String
Retrie/PatternMap/Instances.hs view
@@ -8,10 +8,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+-- NOTE: This was needed for GHC 9.4 due to+-- type Key RFMap = LocatedA (HsRecField GhcPS (LocatedA (HsExpr GhcPs)))+{-# LANGUAGE UndecidableInstances #-} module Retrie.PatternMap.Instances where import Control.Monad@@ -334,7 +338,7 @@ , emExprWithTySig = unionOn emExprWithTySig m1 m2 } - mAlter :: AlphaEnv -> Quantifiers -> Key EMap -> A a -> EMap a -> EMap a+ mAlter :: forall a. AlphaEnv -> Quantifiers -> Key EMap -> A a -> EMap a -> EMap a mAlter env vs e f EMEmpty = mAlter env vs e f emptyEMapWrapper mAlter env vs e f m@EM{} = go (unLoc e) where@@ -362,18 +366,31 @@ go (HsLam _ mg) = m { emLam = mAlter env vs mg f (emLam m) } go (HsOverLit _ ol) = m { emOverLit = mAlter env vs (ol_val ol) f (emOverLit m) } go (NegApp _ e' _) = m { emNegApp = mAlter env vs e' f (emNegApp m) }+#if __GLASGOW_HASKELL__ < 904 go (HsPar _ e') = m { emPar = mAlter env vs e' f (emPar m) }+#else+ go (HsPar _ _ e' _) = m { emPar = mAlter env vs e' f (emPar m) }+#endif go (OpApp _ l o r) = m { emOpApp = mAlter env vs o (toA (mAlter env vs l (toA (mAlter env vs r f)))) (emOpApp m) }+#if __GLASGOW_HASKELL__ < 904 go (RecordCon _ v fs) = m { emRecordCon = mAlter env vs (unLoc v) (toA (mAlter env vs (fieldsToRdrNames $ rec_flds fs) f)) (emRecordCon m) }+#else+ go (RecordCon _ v fs) =+ m { emRecordCon = mAlter env vs (unLoc v :: RdrName) (toA (mAlter env vs (rec_flds fs) f)) (emRecordCon m) }+#endif go (RecordUpd _ e' fs) = m { emRecordUpd = mAlter env vs e' (toA (mAlter env vs (fieldsToRdrNamesUpd fs) f)) (emRecordUpd m) } go (SectionL _ lhs o) = m { emSecL = mAlter env vs o (toA (mAlter env vs lhs f)) (emSecL m) } go (SectionR _ o rhs) = m { emSecR = mAlter env vs o (toA (mAlter env vs rhs f)) (emSecR m) }+#if __GLASGOW_HASKELL__ < 904 go (HsLet _ lbs e') =+#else+ go (HsLet _ _ lbs _ e') =+#endif let bs = collectLocalBinders CollNoDictBinders lbs env' = foldr extendAlphaEnvInternal env bs@@ -395,12 +412,18 @@ #else go HsPragE{} = missingSyntax "HsPragE" #endif+#if __GLASGOW_HASKELL__ < 904 go HsBracket{} = missingSyntax "HsBracket" go HsRnBracketOut{} = missingSyntax "HsRnBracketOut" go HsTcBracketOut{} = missingSyntax "HsTcBracketOut" go HsSpliceE{} = missingSyntax "HsSpliceE" go HsProc{} = missingSyntax "HsProc" go HsStatic{} = missingSyntax "HsStatic"+#else+ go HsTypedBracket{} = missingSyntax "HsTypedBracket"+ go HsUntypedBracket{} = missingSyntax "HsUntypedBracket"+ go HsSpliceE{} = missingSyntax "HsSpliceE"+#endif #if __GLASGOW_HASKELL__ < 810 go HsArrApp{} = missingSyntax "HsArrApp" go HsArrForm{} = missingSyntax "HsArrForm"@@ -409,13 +432,19 @@ go EViewPat{} = missingSyntax "EViewPat" go ELazyPat{} = missingSyntax "ELazyPat" #endif+#if __GLASGOW_HASKELL__ < 904 go HsTick{} = missingSyntax "HsTick" go HsBinTick{} = missingSyntax "HsBinTick"+#endif go HsUnboundVar{} = missingSyntax "HsUnboundVar"+#if __GLASGOW_HASKELL__ < 904 go HsRecFld{} = missingSyntax "HsRecFld"+#endif go HsOverLabel{} = missingSyntax "HsOverLabel" go HsAppType{} = missingSyntax "HsAppType"+#if __GLASGOW_HASKELL__ < 904 go HsConLikeOut{} = missingSyntax "HsConLikeOut"+#endif go ExplicitSum{} = missingSyntax "ExplicitSum" mMatch :: MatchEnv -> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)]@@ -438,18 +467,31 @@ go (HsLam _ mg) = mapFor emLam >=> mMatch env mg go (HsLit _ l) = mapFor emLit >=> mMatch env l go (HsOverLit _ ol) = mapFor emOverLit >=> mMatch env (ol_val ol)+#if __GLASGOW_HASKELL__ < 904 go (HsPar _ e') = mapFor emPar >=> mMatch env e'+#else+ go (HsPar _ _ e' _) = mapFor emPar >=> mMatch env e'+#endif go (HsVar _ v) = mapFor emVar >=> mMatch env (unLoc v) go (OpApp _ l o r) = mapFor emOpApp >=> mMatch env o >=> mMatch env l >=> mMatch env r go (NegApp _ e' _) = mapFor emNegApp >=> mMatch env e'+#if __GLASGOW_HASKELL__ < 904 go (RecordCon _ v fs) = mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (fieldsToRdrNames $ rec_flds fs)+#else+ go (RecordCon _ v fs) =+ mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (rec_flds fs)+#endif go (RecordUpd _ e' fs) = mapFor emRecordUpd >=> mMatch env e' >=> mMatch env (fieldsToRdrNamesUpd fs) go (SectionL _ lhs o) = mapFor emSecL >=> mMatch env o >=> mMatch env lhs go (SectionR _ o rhs) = mapFor emSecR >=> mMatch env o >=> mMatch env rhs+#if __GLASGOW_HASKELL__ < 904 go (HsLet _ lbs e') =+#else+ go (HsLet _ _ lbs _ e') =+#endif let bs = collectLocalBinders CollNoDictBinders lbs env' = extendMatchEnv env bs@@ -509,10 +551,12 @@ instance PatternMap SCMap where #if __GLASGOW_HASKELL__ < 900 type Key SCMap = HsStmtContext Name -- see comment on HsDo in GHC-#elif __GLASGOW_HASKELL__ < 920+#elif __GLASGOW_HASKELL__ < 902 type Key SCMap = HsStmtContext GhcRn-#else+#elif __GLASGOW_HASKELL__ < 904 type Key SCMap = HsStmtContext (HsDoRn GhcPs)+#else+ type Key SCMap = HsDoFlavour #endif mEmpty :: SCMap a@@ -539,11 +583,13 @@ go (DoExpr mname) = m { scmDoExpr = mAlter env vs (maybe "" moduleNameFS mname) f (scmDoExpr m) } #endif go MDoExpr{} = missingSyntax "MDoExpr"+#if __GLASGOW_HASKELL__ < 904 go ArrowExpr = missingSyntax "ArrowExpr"- go GhciStmtCtxt = missingSyntax "GhciStmtCtxt" go (PatGuard _) = missingSyntax "PatGuard" go (ParStmtCtxt _) = missingSyntax "ParStmtCtxt" go (TransStmtCtxt _) = missingSyntax "TransStmtCtxt"+#endif+ go GhciStmtCtxt = missingSyntax "GhciStmtCtxt" mMatch :: MatchEnv -> Key SCMap -> (Substitution, SCMap a) -> [(Substitution, a)] mMatch _ _ (_,SCEmpty) = []@@ -736,7 +782,11 @@ go LitPat{} = missingSyntax "LitPat" go NPat{} = missingSyntax "NPat" go NPlusKPat{} = missingSyntax "NPlusKPat"+#if __GLASGOW_HASKELL__ < 904 go (ParPat _ p) = m { pmParPat = mAlter env vs p f (pmParPat m) }+#else+ go (ParPat _ _ p _) = m { pmParPat = mAlter env vs p f (pmParPat m) }+#endif go (TuplePat _ ps b) = m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) } go SigPat{} = missingSyntax "SigPat"@@ -751,7 +801,11 @@ hss lp = extendResult (pmHole m) (HolePat $ mePruneA env lp) hs go (WildPat _) = mapFor pmWild >=> mMatch env ()+#if __GLASGOW_HASKELL__ < 904 go (ParPat _ p) = mapFor pmParPat >=> mMatch env p+#else+ go (ParPat _ _ p _) = mapFor pmParPat >=> mMatch env p+#endif go (TuplePat _ ps b) = mapFor pmTuplePat >=> mMatch env b >=> mMatch env ps go (VarPat _ _) = mapFor pmVar >=> mMatch env () #if __GLASGOW_HASKELL__ < 900@@ -987,7 +1041,9 @@ go (PatBind _ lhs rhs _) = m { bmPatBind = mAlter env vs lhs (toA $ mAlter env vs rhs f) (bmPatBind m) }+#if __GLASGOW_HASKELL__ < 904 go AbsBinds{} = missingSyntax "AbsBinds"+#endif go PatSynBind{} = missingSyntax "PatSynBind" mMatch :: MatchEnv -> Key BMap -> (Substitution, BMap a) -> [(Substitution, a)]@@ -1155,7 +1211,11 @@ go (HsListTy _ ty') = m { tyHsListTy = mAlter env vs ty' f (tyHsListTy m) } go (HsParTy _ ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) } go (HsQualTy _ cons ty') =+#if __GLASGOW_HASKELL__ < 904 m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs (fromMaybeContext cons) f)) (tyHsQualTy m) }+#else+ m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs (fromMaybeContext (Just cons)) f)) (tyHsQualTy m) }+#endif go HsStarTy{} = missingSyntax "HsStarTy" go (HsSumTy _ tys) = m { tyHsSumTy = mAlter env vs tys f (tyHsSumTy m) } go (HsTupleTy _ ts tys) =@@ -1191,7 +1251,11 @@ #endif go (HsListTy _ ty') = mapFor tyHsListTy >=> mMatch env ty' go (HsParTy _ ty') = mapFor tyHsParTy >=> mMatch env ty'+#if __GLASGOW_HASKELL__ < 904 go (HsQualTy _ cons ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env (fromMaybeContext cons)+#else+ go (HsQualTy _ cons ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env (fromMaybeContext (Just cons))+#endif go (HsSumTy _ tys) = mapFor tyHsSumTy >=> mMatch env tys go (HsTupleTy _ ts tys) = mapFor tyHsTupleTy >=> mMatch env ts >=> mMatch env tys go (HsTyVar _ _ v) = mapFor tyHsTyVar >=> mMatch env (unLoc v)@@ -1223,7 +1287,11 @@ deriving (Functor) instance PatternMap RFMap where+#if __GLASGOW_HASKELL__ < 904 type Key RFMap = LocatedA (HsRecField' RdrName (LocatedA (HsExpr GhcPs)))+#else+ type Key RFMap = LocatedA (HsRecField GhcPs (LocatedA (HsExpr GhcPs)))+#endif mEmpty :: RFMap a mEmpty = RFM mEmpty@@ -1234,14 +1302,24 @@ mAlter :: AlphaEnv -> Quantifiers -> Key RFMap -> A a -> RFMap a -> RFMap a mAlter env vs lf f m = go (unLoc lf) where+#if __GLASGOW_HASKELL__ < 904 go (HsRecField _ lbl arg _pun) = m { rfmField = mAlter env vs (unLoc lbl) (toA (mAlter env vs arg f)) (rfmField m) }+#else+ go (HsFieldBind _ lbl arg _pun) =+ m { rfmField = mAlter env vs (unLoc (foLabel (unLoc lbl))) (toA (mAlter env vs arg f)) (rfmField m) }+#endif mMatch :: MatchEnv -> Key RFMap -> (Substitution, RFMap a) -> [(Substitution, a)] mMatch env lf (hs,m) = go (unLoc lf) (hs,m) where+#if __GLASGOW_HASKELL__ < 904 go (HsRecField _ lbl arg _pun) = mapFor rfmField >=> mMatch env (unLoc lbl) >=> mMatch env arg+#else+ go (HsFieldBind _ lbl arg _pun) =+ mapFor rfmField >=> mMatch env (unLoc (foLabel (unLoc lbl))) >=> mMatch env arg+#endif -- Helper class to collapse the complex encoding of record fields into RdrNames. -- (The complexity is to support punning/duplicate/overlapping fields, which@@ -1252,12 +1330,18 @@ instance RecordFieldToRdrName (AmbiguousFieldOcc GhcPs) where recordFieldToRdrName = rdrNameAmbiguousFieldOcc +#if __GLASGOW_HASKELL__ < 904 instance RecordFieldToRdrName (FieldOcc p) where recordFieldToRdrName = unLoc . rdrNameFieldOcc+#else+instance RecordFieldToRdrName (FieldOcc GhcPs) where+ recordFieldToRdrName = unLoc . foLabel+#endif instance RecordFieldToRdrName (FieldLabelStrings GhcPs) where recordFieldToRdrName = error "TBD" +#if __GLASGOW_HASKELL__ < 904 -- Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs] fieldsToRdrNamesUpd :: Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]@@ -1270,7 +1354,27 @@ where go (L l (HsRecField a (L l2 f) arg pun)) = L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)+#else+fieldsToRdrNamesUpd :: Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]+ -> [LHsRecField GhcPs (LHsExpr GhcPs)]+fieldsToRdrNamesUpd (Left xs) = map go xs+ where+ go (L l (HsFieldBind a (L l2 f) arg pun)) =+ let lrdrName = case f of+ Unambiguous _ n -> n+ Ambiguous _ n -> n+ XAmbiguousFieldOcc{} -> error "XAmbiguousFieldOcc"+ f' = FieldOcc NoExtField lrdrName+ in L l (HsFieldBind a (L l2 f') arg pun)+fieldsToRdrNamesUpd (Right xs) = map go xs+ where+ go (L l (HsFieldBind a (L l2 _f) arg pun)) =+ let lrdrName = error "TBD" -- same as GHC 9.2+ f' = FieldOcc NoExtField lrdrName+ in L l (HsFieldBind a (L l2 f') arg pun)+#endif +#if __GLASGOW_HASKELL__ < 904 fieldsToRdrNames :: RecordFieldToRdrName f => [LHsRecField' GhcPs f arg]@@ -1279,6 +1383,7 @@ where go (L l (HsRecField a (L l2 f) arg pun)) = L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)+#endif ------------------------------------------------------------------------
Retrie/Rewrites.hs view
@@ -25,7 +25,11 @@ import Retrie.CPP import Retrie.ExactPrint import Retrie.Fixity+#if __GLASGOW_HASKELL__ < 904 import Retrie.GHC+#else+import Retrie.GHC hiding (Pattern)+#endif import Retrie.Rewrites.Function import Retrie.Rewrites.Patterns import Retrie.Rewrites.Rules
Retrie/Rewrites/Function.hs view
@@ -82,7 +82,11 @@ go VarPat{} = True go (LazyPat _ p) = irrefutablePat p go (AsPat _ _ p) = irrefutablePat p+#if __GLASGOW_HASKELL__ < 904 go (ParPat _ p) = irrefutablePat p+#else+ go (ParPat _ _ p _) = irrefutablePat p+#endif go (BangPat _ p) = irrefutablePat p go _ = False
Retrie/Rewrites/Patterns.hs view
@@ -97,12 +97,22 @@ convertField :: (Monad m) => RecordPatSynField GhcPs -> TransformT m (LHsRecField GhcPs (LPat GhcPs)) convertField RecordPatSynField{..} = do+#if __GLASGOW_HASKELL__ < 904 hsRecFieldLbl <- mkLoc $ recordPatSynField hsRecFieldArg <- mkVarPat recordPatSynPatVar let hsRecPun = False let hsRecFieldAnn = noAnn mkLocA (SameLine 0) HsRecField{..}-+#else+ s <- uniqueSrcSpanT+ an <- mkEpAnn (SameLine 0) NoEpAnns+ let srcspan = SrcSpanAnn an s+ hfbLHS = L srcspan recordPatSynField+ hfbRHS <- mkVarPat recordPatSynPatVar+ let hfbPun = False+ hfbAnn = noAnn+ mkLocA (SameLine 0) HsFieldBind{..}+#endif mkExpRewrite :: Direction
Retrie/Substitution.hs view
@@ -22,7 +22,7 @@ -- See Note [Why not RdrNames?] for explanation of use of FastString instance Show Substitution where- show (Substitution m) = show (eltsUFM m)+ show (Substitution m) = show (nonDetEltsUFM m) -- | Sum type of possible substitution values. data HoleVal
retrie.cabal view
@@ -4,7 +4,7 @@ -- LICENSE file in the root directory of this source tree. -- name: retrie-version: 1.2.0.1+version: 1.2.1 synopsis: A powerful, easy-to-use codemodding tool for Haskell. homepage: https://github.com/facebookincubator/retrie bug-reports: https://github.com/facebookincubator/retrie/issues@@ -23,7 +23,7 @@ README.md tests/inputs/*.custom tests/inputs/*.test-tested-with: GHC ==9.2.1+tested-with: GHC ==9.2.1, GHC ==9.4.1 description: Retrie is a tool for codemodding Haskell. Key goals include:@@ -77,23 +77,29 @@ build-depends: ansi-terminal >= 0.10.3 && < 0.12, async >= 2.2.2 && < 2.3,- base >= 4.11 && < 4.17,+ base >= 4.11 && < 4.18, bytestring >= 0.10.8 && < 0.12, containers >= 0.5.11 && < 0.7, data-default >= 0.7.1 && < 0.8, directory >= 1.3.1 && < 1.4, filepath >= 1.4.2 && < 1.5,- ghc >= 9.2,- ghc-exactprint >= 1.4.0 && < 1.5, list-t >= 1.0.4 && < 1.1, mtl >= 2.2.2 && < 2.3, optparse-applicative >= 0.15.1 && < 0.17, process >= 1.6.3 && < 1.7, random-shuffle >= 0.0.4 && < 0.1, syb >= 0.7.1 && < 0.8,- text >= 1.2.3 && < 2.0,+ text >= 1.2.3 && < 2.1, transformers >= 0.5.5 && < 0.6, unordered-containers >= 0.2.10 && < 0.3+ if impl (ghc >= 9.4) && (impl (ghc < 9.5))+ build-depends:+ ghc == 9.4.*,+ ghc-exactprint >= 1.6.0 && < 1.7+ if impl (ghc >= 9.2) && (impl (ghc < 9.3))+ build-depends:+ ghc == 9.2.*,+ ghc-exactprint < 1.6.0 && > 1.4.0 default-language: Haskell2010 Flag BuildExecutable@@ -112,7 +118,7 @@ GHC-Options: -Wall build-depends: retrie,- base >= 4.11 && < 4.17,+ base >= 4.11 && < 4.18, haskell-src-exts >= 1.23.0 && < 1.24, ghc-paths default-language: Haskell2010@@ -129,7 +135,7 @@ GHC-Options: -Wall build-depends: retrie,- base >= 4.11 && < 4.17,+ base >= 4.11 && < 4.18, haskell-src-exts >= 1.23.0 && < 1.24, ghc-paths default-language: Haskell2010@@ -157,7 +163,7 @@ build-depends: retrie, HUnit,- base, + base, containers, data-default, deepseq,