Update to GHC 9.4

.github/workflows/test.yml

@@ -9,11 +9,11 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc: ['9.2.1']
+        ghc: ['9.4.1', '9.2.4']
 
     steps:
     - uses: actions/checkout@v2
-    - uses: haskell/actions/setup@v1
+    - uses: haskell/actions/setup@v2.0.1
       with:
         ghc-version: ${{ matrix.ghc }}
 

Retrie/CPP.hs

@@ -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 Debug.Trace
 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 @@ eqImportDecl x y =
   && ((==) `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

@@ -61,7 +61,11 @@ updateContext c i =
     -- 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

@@ -257,14 +257,16 @@ swapEntryDPT a b = do
 -- 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 @@ parseHelper :: (ExactPrint a)
   => 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

@@ -87,13 +87,12 @@ instance Default ast => Default (Annotated ast) where
   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

@@ -14,6 +14,7 @@ module Retrie.Expr
   , grhsToExpr
   , mkApps
   , mkConPatIn
+  , mkEpAnn
   , mkHsAppsTy
   , mkLams
   , mkLet
@@ -138,15 +139,21 @@ mkLams vs e = do
 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) [],
                    alIn = EpaDelta (DifferentLine 1 1) []
                  })
   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 @@ patToExpr orig = case dLPat orig of
       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 @@ precedence _        _                = Nothing
 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 @@ getUnparened = mkT unparen `extT` unparenT `extT` unparenP
 
 -- 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 @@ mkParen k e = do
   (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,6 +377,25 @@ mkParen' dp k = do
   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.
@@ -361,7 +407,13 @@ parenifyP
 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 @@ parenifyP Context{..} p@(L _ pat)
 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 (L _ (HsParTy _ ty)) = ty
 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

@@ -22,12 +22,10 @@ newtype FixityEnv = FixityEnv
 
 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 @@ extendFixityEnv l (FixityEnv env) =
   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

@@ -15,6 +15,7 @@ module Retrie.GHC
   , 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 Retrie.GHC
   , 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
 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
 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