Support ghc-9.4 (#421)

lib/Language/Haskell/Stylish/Config.hs

@@ -264,7 +264,7 @@ parseIndent = \case
     A.String "same_line" -> return Data.SameLine
     A.String t | "indent " `T.isPrefixOf` t ->
         case readMaybe (T.unpack $ T.drop 7 t) of
-             Just n -> return $ Data.Indent n
+             Just n  -> return $ Data.Indent n
              Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
     A.String t -> fail $ "can't parse indent setting: " <> T.unpack t
     _ -> fail "Expected string for indent value"

lib/Language/Haskell/Stylish/Config/Cabal.hs

@@ -5,16 +5,21 @@ module Language.Haskell.Stylish.Config.Cabal
 
 
 --------------------------------------------------------------------------------
+import           Control.Monad                            (unless)
+import qualified Data.ByteString.Char8                    as BS
 import           Data.Either                              (isRight)
+import           Data.Foldable                            (traverse_)
 import           Data.List                                (nub)
 import           Data.Maybe                               (maybeToList)
 import qualified Distribution.PackageDescription          as Cabal
 import qualified Distribution.PackageDescription.Parsec   as Cabal
+import qualified Distribution.Parsec                      as Cabal
 import qualified Distribution.Simple.Utils                as Cabal
 import qualified Distribution.Verbosity                   as Cabal
 import qualified Language.Haskell.Extension               as Language
 import           Language.Haskell.Stylish.Verbose
-import           System.Directory                         (getCurrentDirectory)
+import           System.Directory                         (doesFileExist,
+                                                           getCurrentDirectory)
 
 
 --------------------------------------------------------------------------------
@@ -49,7 +54,7 @@ findCabalFile verbose = do
 readDefaultLanguageExtensions :: Verbose -> FilePath -> IO [Language.KnownExtension]
 readDefaultLanguageExtensions verbose cabalFile = do
   verbose $ "Parsing " <> cabalFile <> "..."
-  packageDescription <- Cabal.readGenericPackageDescription Cabal.silent cabalFile
+  packageDescription <- readGenericPackageDescription Cabal.silent cabalFile
   let library :: [Cabal.Library]
       library = maybeToList $ fst . Cabal.ignoreConditions <$>
         Cabal.condLibrary packageDescription
@@ -89,3 +94,23 @@ readDefaultLanguageExtensions verbose cabalFile = do
                         "invalid LANGUAGE pragma:  " <> show x
   verbose $ "Gathered default-extensions: " <> show defaultExtensions
   pure $ nub defaultExtensions
+
+readGenericPackageDescription :: Cabal.Verbosity -> FilePath -> IO Cabal.GenericPackageDescription
+readGenericPackageDescription = readAndParseFile Cabal.parseGenericPackageDescription
+  where
+    readAndParseFile parser verbosity fpath = do
+      exists <- doesFileExist fpath
+      unless exists $
+        Cabal.die' verbosity $
+          "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
+      bs <- BS.readFile fpath
+      parseString parser verbosity fpath bs
+
+    parseString parser verbosity name bs = do
+      let (warnings, result) = Cabal.runParseResult (parser bs)
+      traverse_ (Cabal.warn verbosity . Cabal.showPWarning name) warnings
+      case result of
+          Right x -> return x
+          Left (_, errors) -> do
+              traverse_ (Cabal.warn verbosity . Cabal.showPError name) errors
+              Cabal.die' verbosity $ "Failed parsing \"" ++ name ++ "\"."

lib/Language/Haskell/Stylish/Module.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TupleSections              #-}
 module Language.Haskell.Stylish.Module
   ( -- * Data types
@@ -37,6 +38,7 @@ import           GHC.Hs                       (ImportDecl (..),
                                                ImportDeclQualifiedStyle (..))
 import qualified GHC.Hs                       as GHC
 import           GHC.Hs.Extension             (GhcPs)
+import qualified GHC.Types.PkgQual            as GHC
 import           GHC.Types.SrcLoc             (GenLocated (..),
                                                RealSrcSpan (..), unLoc)
 import qualified GHC.Types.SrcLoc             as GHC
@@ -50,6 +52,7 @@ import           Language.Haskell.Stylish.GHC
 --------------------------------------------------------------------------------
 type Lines = [String]
 
+deriving instance Eq GHC.RawPkgQual
 
 --------------------------------------------------------------------------------
 -- | Concrete module type

lib/Language/Haskell/Stylish/Ordering.hs

@@ -12,16 +12,16 @@ module Language.Haskell.Stylish.Ordering
 
 
 --------------------------------------------------------------------------------
-import           Data.Char                       (isUpper, toLower)
-import           Data.Function                   (on)
-import           Data.Ord                        (comparing)
+import           Data.Char                    (isUpper, toLower)
+import           Data.Function                (on)
+import           Data.Ord                     (comparing)
 import           GHC.Hs
-import qualified GHC.Hs                          as GHC
-import           GHC.Types.Name.Reader           (RdrName)
-import           GHC.Types.SrcLoc                (unLoc)
-import           GHC.Utils.Outputable            (Outputable)
-import qualified GHC.Utils.Outputable            as GHC
-import           Language.Haskell.Stylish.GHC    (showOutputable)
+import qualified GHC.Hs                       as GHC
+import           GHC.Types.Name.Reader        (RdrName)
+import           GHC.Types.SrcLoc             (unLoc)
+import           GHC.Utils.Outputable         (Outputable)
+import qualified GHC.Utils.Outputable         as GHC
+import           Language.Haskell.Stylish.GHC (showOutputable)
 
 
 --------------------------------------------------------------------------------
@@ -31,8 +31,8 @@ compareImports
     :: GHC.ImportDecl GHC.GhcPs -> GHC.ImportDecl GHC.GhcPs -> Ordering
 compareImports i0 i1 =
     ideclName i0 `compareOutputableCI` ideclName i1 <>
-    fmap showOutputable (ideclPkgQual i0) `compare`
-        fmap showOutputable (ideclPkgQual i1) <>
+    showOutputable (ideclPkgQual i0) `compare`
+        showOutputable (ideclPkgQual i1) <>
     compareOutputableCI i0 i1
 
 

lib/Language/Haskell/Stylish/Parse.hs

@@ -14,15 +14,14 @@ import           Data.Maybe                                         (catMaybes,
                                                                      mapMaybe)
 import           Data.Traversable                                   (for)
 import qualified GHC.Data.StringBuffer                              as GHC
+import qualified GHC.Driver.Config.Parser                           as GHC
 import           GHC.Driver.Ppr                                     as GHC
 import qualified GHC.Driver.Session                                 as GHC
 import qualified GHC.LanguageExtensions.Type                        as LangExt
-import qualified GHC.Parser.Errors.Ppr                              as GHC
 import qualified GHC.Parser.Header                                  as GHC
 import qualified GHC.Parser.Lexer                                   as GHC
 import qualified GHC.Types.SrcLoc                                   as GHC
 import qualified GHC.Utils.Error                                    as GHC
-import qualified GHC.Utils.Outputable                               as GHC
 import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx
 import qualified Language.Haskell.GhclibParserEx.GHC.Parser         as GHCEx
 
@@ -94,7 +93,7 @@ parseModule externalExts0 fp string = do
     let dynFlags0 = foldl' toggleExt baseDynFlags externalExts1
 
     -- Parse options from file
-    let fileOptions = fmap GHC.unLoc $ GHC.getOptions dynFlags0
+    let fileOptions = fmap GHC.unLoc $ snd $ GHC.getOptions (GHC.initParserOpts dynFlags0)
             (GHC.stringToStringBuffer string)
             (fromMaybe "-" fp)
         fileExtensions = mapMaybe (\str -> do
@@ -115,9 +114,8 @@ parseModule externalExts0 fp string = do
     -- Actual parse.
     case GHCEx.parseModule input dynFlags1 of
         GHC.POk _ m -> Right m
-        GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 .
-            GHC.vcat . GHC.pprMsgEnvelopeBagWithLoc . fmap GHC.pprError . snd $
-            GHC.getMessages ps
+        GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 . GHC.pprMessages . snd $
+            GHC.getPsMessages ps
   where
     withFileName x = maybe "" (<> ": ") fp <> x
 

lib/Language/Haskell/Stylish/Printer.hs

@@ -136,14 +136,11 @@ putAllSpanComments suff = \case
 -- | Print any comment
 putComment :: GHC.EpaComment -> P ()
 putComment epaComment = case GHC.ac_tok epaComment of
-  GHC.EpaLineComment s     -> putText s
-  GHC.EpaDocCommentNext s  -> putText s
-  GHC.EpaDocCommentPrev s  -> putText s
-  GHC.EpaDocCommentNamed s -> putText s
-  GHC.EpaDocSection _ s    -> putText s
-  GHC.EpaDocOptions s      -> putText s
-  GHC.EpaBlockComment s    -> putText s
-  GHC.EpaEofComment        -> pure ()
+  GHC.EpaDocComment hs  -> putText $ show hs
+  GHC.EpaLineComment s  -> putText s
+  GHC.EpaDocOptions s   -> putText s
+  GHC.EpaBlockComment s -> putText s
+  GHC.EpaEofComment     -> pure ()
 
 putMaybeLineComment :: Maybe GHC.EpaComment -> P ()
 putMaybeLineComment = \case
@@ -176,6 +173,7 @@ nameAnnAdornment :: GHC.NameAnn -> (String, String)
 nameAnnAdornment = \case
     GHC.NameAnn {..}       -> fromAdornment nann_adornment
     GHC.NameAnnCommas {..} -> fromAdornment nann_adornment
+    GHC.NameAnnBars {..}   -> fromAdornment nann_adornment
     GHC.NameAnnOnly {..}   -> fromAdornment nann_adornment
     GHC.NameAnnRArrow {}   -> (mempty, mempty)
     GHC.NameAnnQuote {}    -> ("'", mempty)
@@ -216,7 +214,7 @@ putType ltp = case GHC.unLoc ltp of
       (comma >> space)
       (fmap putType xs)
     putText ")"
-  GHC.HsOpTy _ lhs op rhs -> do
+  GHC.HsOpTy _ _ lhs op rhs -> do
     putType lhs
     space
     putRdrName op

lib/Language/Haskell/Stylish/Step/Data.hs

@@ -330,7 +330,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
     -- Put argument to constructor first:
     case con_g_args of
       GHC.PrefixConGADT _ -> sep (comma >> space) $ fmap putRdrName con_names
-      GHC.RecConGADT _ -> error . mconcat $
+      GHC.RecConGADT _ _ -> error . mconcat $
           [ "Language.Haskell.Stylish.Step.Data.putConstructor: "
           , "encountered a GADT with record constructors, not supported yet"
           ]
@@ -352,7 +352,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
         GHC.PrefixConGADT scaledTys -> forM_ scaledTys $ \scaledTy -> do
             putType $ GHC.hsScaledThing scaledTy
             space >> putText "->" >> space
-        GHC.RecConGADT _ -> error . mconcat $
+        GHC.RecConGADT _ _ -> error . mconcat $
             [ "Language.Haskell.Stylish.Step.Data.putConstructor: "
             , "encountered a GADT with record constructors, not supported yet"
             ]
@@ -371,7 +371,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
       GHC.PrefixCon _tyargs args -> do
         putRdrName con_name
         unless (null args) space
-        sep space (fmap putOutputable args)
+        sep space (fmap (putOutputable . GHC.hsScaledThing) args)
       GHC.RecCon largs | _ : _ <- GHC.unLoc largs -> do
         putRdrName con_name
         skipToBrace
@@ -442,7 +442,7 @@ putNewtypeConstructor cfg lcons = case GHC.unLoc lcons of
     putRdrName con_name >> case con_args of
       GHC.PrefixCon _ args -> do
         unless (null args) space
-        sep space (fmap putOutputable args)
+        sep space (fmap (putOutputable . GHC.hsScaledThing) args)
       GHC.RecCon largs | [firstArg] <- GHC.unLoc largs -> do
         space
         putText "{"
@@ -515,7 +515,7 @@ putType' cfg lty = case GHC.unLoc lty of
         space
         putType' cfg tp
     GHC.HsQualTy GHC.NoExtField ctx tp -> do
-        forM_ ctx $ putContext cfg
+        putContext cfg ctx
         putType' cfg tp
     _ -> putType lty
 

lib/Language/Haskell/Stylish/Step/Imports.hs

@@ -41,12 +41,13 @@ import qualified Data.Text                         as T
 import qualified GHC.Data.FastString               as GHC
 import qualified GHC.Hs                            as GHC
 import qualified GHC.Types.Name.Reader             as GHC
+import qualified GHC.Types.PkgQual                 as GHC
 import qualified GHC.Types.SourceText              as GHC
 import qualified GHC.Types.SrcLoc                  as GHC
 import qualified GHC.Unit.Module.Name              as GHC
 import qualified GHC.Unit.Types                    as GHC
-import           Text.Regex.TDFA                   (Regex)
 import qualified Text.Regex.TDFA                   as Regex
+import           Text.Regex.TDFA                   (Regex)
 import           Text.Regex.TDFA.ReadRegex         (parseRegex)
 
 --------------------------------------------------------------------------------
@@ -358,8 +359,9 @@ printQualified Options{..} padNames stats ldecl = do
 
     let module_ = do
             moduleNamePosition <- length <$> getCurrentLine
-            forM_ (GHC.ideclPkgQual decl) $ \pkg ->
-                putText (stringLiteral pkg) >> space
+            case GHC.ideclPkgQual decl of
+              GHC.NoRawPkgQual   -> pure ()
+              GHC.RawPkgQual pkg -> putText (stringLiteral pkg) >> space
             putText (importModuleName decl)
 
             -- Only print spaces if something follows.
@@ -584,8 +586,8 @@ importStats i =
 importModuleNameLength :: GHC.ImportDecl GHC.GhcPs -> Int
 importModuleNameLength imp =
     (case GHC.ideclPkgQual imp of
-        Nothing -> 0
-        Just sl -> 1 + length (stringLiteral sl)) +
+        GHC.NoRawPkgQual  -> 0
+        GHC.RawPkgQual sl -> 1 + length (stringLiteral sl)) +
     (length $ importModuleName imp)
 
 

lib/Language/Haskell/Stylish/Step/ModuleHeader.hs

@@ -69,7 +69,6 @@ printModuleHeader :: Maybe Int -> Config -> Lines -> Module -> Lines
 printModuleHeader maxCols conf ls lmodul =
     let modul = GHC.unLoc lmodul
         name = GHC.unLoc <$> GHC.hsmodName modul
-        haddocks = GHC.hsmodHaddockModHeader modul
 
         startLine = fromMaybe 1 $ moduleLine <|>
             (fmap GHC.srcSpanStartLine . GHC.srcSpanToRealSrcSpan $
@@ -108,7 +107,7 @@ printModuleHeader maxCols conf ls lmodul =
         printedModuleHeader = runPrinter_
             (PrinterConfig maxCols)
             (printHeader
-                conf name exportGroups haddocks moduleComment whereComment)
+                conf name exportGroups moduleComment whereComment)
 
         changes = Editor.changeLines
             (Editor.Block startLine endLine)
@@ -122,11 +121,10 @@ printHeader
     :: Config
     -> Maybe GHC.ModuleName
     -> Maybe [CommentGroup (GHC.LIE GHC.GhcPs)]
-    -> Maybe GHC.LHsDocString
     -> Maybe GHC.LEpaComment  -- Comment attached to 'module'
     -> Maybe GHC.LEpaComment  -- Comment attached to 'where'
     -> P ()
-printHeader conf mbName mbExps _ mbModuleComment mbWhereComment = do
+printHeader conf mbName mbExps mbModuleComment mbWhereComment = do
     forM_ mbName $ \name -> do
         putText "module"
         space

lib/Language/Haskell/Stylish/Step/SimpleAlign.hs

@@ -15,13 +15,13 @@ import           Data.Foldable                   (toList)
 import           Data.List                       (foldl', foldl1', sortOn)
 import           Data.Maybe                      (fromMaybe)
 import qualified GHC.Hs                          as Hs
-import qualified GHC.Parser.Annotation as GHC
-import qualified GHC.Types.SrcLoc as GHC
+import qualified GHC.Parser.Annotation           as GHC
+import qualified GHC.Types.SrcLoc                as GHC
 
 
 --------------------------------------------------------------------------------
 import           Language.Haskell.Stylish.Align
-import          qualified Language.Haskell.Stylish.Editor as Editor
+import qualified Language.Haskell.Stylish.Editor as Editor
 import           Language.Haskell.Stylish.Module
 import           Language.Haskell.Stylish.Step
 import           Language.Haskell.Stylish.Util
@@ -88,7 +88,7 @@ fieldDeclToAlignable
     :: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan)
 fieldDeclToAlignable (GHC.L matchLoc (Hs.ConDeclField _ names ty _)) = do
   matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc
-  leftPos  <- GHC.srcSpanToRealSrcSpan $ GHC.getLoc $ last names
+  leftPos  <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA $ last names
   tyPos    <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA ty
   Just $ Alignable
     { aContainer = matchPos
@@ -162,9 +162,9 @@ multiWayIfToAlignable _conf _ = []
 
 --------------------------------------------------------------------------------
 grhsToAlignable
-    :: GHC.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
+    :: GHC.GenLocated (GHC.SrcSpanAnn' a) (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
     -> Maybe (Alignable GHC.RealSrcSpan)
-grhsToAlignable (GHC.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do
+grhsToAlignable (GHC.L (GHC.SrcSpanAnn _ grhsloc) (Hs.GRHS _ guards@(_ : _) body)) = do
     let guardsLocs = map GHC.getLocA guards
         bodyLoc    = GHC.getLocA $ body
         left       = foldl1' GHC.combineSrcSpans guardsLocs

lib/Language/Haskell/Stylish/Step/Squash.hs

@@ -37,7 +37,7 @@ squash l r
 --------------------------------------------------------------------------------
 squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Editor.Edits
 squashFieldDecl (GHC.ConDeclField ext names@(_ : _) type' _)
-    | Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLoc $ last names
+    | Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last names
     , Just sep <- fieldDeclSeparator ext
     , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA type' =
         squash left sep <> squash sep right

lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs

@@ -5,7 +5,7 @@ module Language.Haskell.Stylish.Step.TrailingWhitespace
 
 
 --------------------------------------------------------------------------------
-import           Data.Char           (isSpace)
+import           Data.Char                     (isSpace)
 
 
 --------------------------------------------------------------------------------

lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs

@@ -19,17 +19,15 @@ import           Language.Haskell.Stylish.Util                 (everything)
 
 --------------------------------------------------------------------------------
 hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits
-hsTyReplacements (GHC.HsFunTy xann arr _ _)
-    | GHC.HsUnrestrictedArrow GHC.NormalSyntax <- arr
-    , GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann =
-        Editor.replaceRealSrcSpan loc "→"
-hsTyReplacements (GHC.HsQualTy _ (Just ctx) _)
+hsTyReplacements (GHC.HsFunTy _ arr _ _)
+    | GHC.HsUnrestrictedArrow (GHC.L (GHC.TokenLoc epaLoc) GHC.HsNormalTok) <- arr=
+        Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan epaLoc) "→"
+hsTyReplacements (GHC.HsQualTy _ ctx _)
     | Just arrow <- GHC.ac_darrow . GHC.anns . GHC.ann $ GHC.getLoc ctx
     , (GHC.NormalSyntax, GHC.EpaSpan loc) <- arrow =
         Editor.replaceRealSrcSpan loc "⇒"
 hsTyReplacements _ = mempty
 
-
 --------------------------------------------------------------------------------
 hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits
 hsSigReplacements (GHC.TypeSig ann _ _)