Skip to content

Commit 05cc9e1

Browse files
July541July541
authored
Support ghc-9.4 (#421)
1 parent ba8f471 commit 05cc9e1

17 files changed

+106
-82
lines changed

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -264,7 +264,7 @@ parseIndent = \case
264264
A.String "same_line" -> return Data.SameLine
265265
A.String t | "indent " `T.isPrefixOf` t ->
266266
case readMaybe (T.unpack $ T.drop 7 t) of
267-
Just n -> return $ Data.Indent n
267+
Just n -> return $ Data.Indent n
268268
Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
269269
A.String t -> fail $ "can't parse indent setting: " <> T.unpack t
270270
_ -> fail "Expected string for indent value"

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

+27-2
Original file line numberDiff line numberDiff line change
@@ -5,16 +5,21 @@ module Language.Haskell.Stylish.Config.Cabal
55

66

77
--------------------------------------------------------------------------------
8+
import Control.Monad (unless)
9+
import qualified Data.ByteString.Char8 as BS
810
import Data.Either (isRight)
11+
import Data.Foldable (traverse_)
912
import Data.List (nub)
1013
import Data.Maybe (maybeToList)
1114
import qualified Distribution.PackageDescription as Cabal
1215
import qualified Distribution.PackageDescription.Parsec as Cabal
16+
import qualified Distribution.Parsec as Cabal
1317
import qualified Distribution.Simple.Utils as Cabal
1418
import qualified Distribution.Verbosity as Cabal
1519
import qualified Language.Haskell.Extension as Language
1620
import Language.Haskell.Stylish.Verbose
17-
import System.Directory (getCurrentDirectory)
21+
import System.Directory (doesFileExist,
22+
getCurrentDirectory)
1823

1924

2025
--------------------------------------------------------------------------------
@@ -49,7 +54,7 @@ findCabalFile verbose = do
4954
readDefaultLanguageExtensions :: Verbose -> FilePath -> IO [Language.KnownExtension]
5055
readDefaultLanguageExtensions verbose cabalFile = do
5156
verbose $ "Parsing " <> cabalFile <> "..."
52-
packageDescription <- Cabal.readGenericPackageDescription Cabal.silent cabalFile
57+
packageDescription <- readGenericPackageDescription Cabal.silent cabalFile
5358
let library :: [Cabal.Library]
5459
library = maybeToList $ fst . Cabal.ignoreConditions <$>
5560
Cabal.condLibrary packageDescription
@@ -89,3 +94,23 @@ readDefaultLanguageExtensions verbose cabalFile = do
8994
"invalid LANGUAGE pragma: " <> show x
9095
verbose $ "Gathered default-extensions: " <> show defaultExtensions
9196
pure $ nub defaultExtensions
97+
98+
readGenericPackageDescription :: Cabal.Verbosity -> FilePath -> IO Cabal.GenericPackageDescription
99+
readGenericPackageDescription = readAndParseFile Cabal.parseGenericPackageDescription
100+
where
101+
readAndParseFile parser verbosity fpath = do
102+
exists <- doesFileExist fpath
103+
unless exists $
104+
Cabal.die' verbosity $
105+
"Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
106+
bs <- BS.readFile fpath
107+
parseString parser verbosity fpath bs
108+
109+
parseString parser verbosity name bs = do
110+
let (warnings, result) = Cabal.runParseResult (parser bs)
111+
traverse_ (Cabal.warn verbosity . Cabal.showPWarning name) warnings
112+
case result of
113+
Right x -> return x
114+
Left (_, errors) -> do
115+
traverse_ (Cabal.warn verbosity . Cabal.showPError name) errors
116+
Cabal.die' verbosity $ "Failed parsing \"" ++ name ++ "\"."

‎lib/Language/Haskell/Stylish/Module.hs

+3
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE LambdaCase #-}
55
{-# LANGUAGE OverloadedStrings #-}
66
{-# LANGUAGE RecordWildCards #-}
7+
{-# LANGUAGE StandaloneDeriving #-}
78
{-# LANGUAGE TupleSections #-}
89
module Language.Haskell.Stylish.Module
910
( -- * Data types
@@ -37,6 +38,7 @@ import GHC.Hs (ImportDecl (..),
3738
ImportDeclQualifiedStyle (..))
3839
import qualified GHC.Hs as GHC
3940
import GHC.Hs.Extension (GhcPs)
41+
import qualified GHC.Types.PkgQual as GHC
4042
import GHC.Types.SrcLoc (GenLocated (..),
4143
RealSrcSpan (..), unLoc)
4244
import qualified GHC.Types.SrcLoc as GHC
@@ -50,6 +52,7 @@ import Language.Haskell.Stylish.GHC
5052
--------------------------------------------------------------------------------
5153
type Lines = [String]
5254

55+
deriving instance Eq GHC.RawPkgQual
5356

5457
--------------------------------------------------------------------------------
5558
-- | Concrete module type

‎lib/Language/Haskell/Stylish/Ordering.hs

+11-11
Original file line numberDiff line numberDiff line change
@@ -12,16 +12,16 @@ module Language.Haskell.Stylish.Ordering
1212

1313

1414
--------------------------------------------------------------------------------
15-
import Data.Char (isUpper, toLower)
16-
import Data.Function (on)
17-
import Data.Ord (comparing)
15+
import Data.Char (isUpper, toLower)
16+
import Data.Function (on)
17+
import Data.Ord (comparing)
1818
import GHC.Hs
19-
import qualified GHC.Hs as GHC
20-
import GHC.Types.Name.Reader (RdrName)
21-
import GHC.Types.SrcLoc (unLoc)
22-
import GHC.Utils.Outputable (Outputable)
23-
import qualified GHC.Utils.Outputable as GHC
24-
import Language.Haskell.Stylish.GHC (showOutputable)
19+
import qualified GHC.Hs as GHC
20+
import GHC.Types.Name.Reader (RdrName)
21+
import GHC.Types.SrcLoc (unLoc)
22+
import GHC.Utils.Outputable (Outputable)
23+
import qualified GHC.Utils.Outputable as GHC
24+
import Language.Haskell.Stylish.GHC (showOutputable)
2525

2626

2727
--------------------------------------------------------------------------------
@@ -31,8 +31,8 @@ compareImports
3131
:: GHC.ImportDecl GHC.GhcPs -> GHC.ImportDecl GHC.GhcPs -> Ordering
3232
compareImports i0 i1 =
3333
ideclName i0 `compareOutputableCI` ideclName i1 <>
34-
fmap showOutputable (ideclPkgQual i0) `compare`
35-
fmap showOutputable (ideclPkgQual i1) <>
34+
showOutputable (ideclPkgQual i0) `compare`
35+
showOutputable (ideclPkgQual i1) <>
3636
compareOutputableCI i0 i1
3737

3838

‎lib/Language/Haskell/Stylish/Parse.hs

+4-6
Original file line numberDiff line numberDiff line change
@@ -14,15 +14,14 @@ import Data.Maybe (catMaybes,
1414
mapMaybe)
1515
import Data.Traversable (for)
1616
import qualified GHC.Data.StringBuffer as GHC
17+
import qualified GHC.Driver.Config.Parser as GHC
1718
import GHC.Driver.Ppr as GHC
1819
import qualified GHC.Driver.Session as GHC
1920
import qualified GHC.LanguageExtensions.Type as LangExt
20-
import qualified GHC.Parser.Errors.Ppr as GHC
2121
import qualified GHC.Parser.Header as GHC
2222
import qualified GHC.Parser.Lexer as GHC
2323
import qualified GHC.Types.SrcLoc as GHC
2424
import qualified GHC.Utils.Error as GHC
25-
import qualified GHC.Utils.Outputable as GHC
2625
import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx
2726
import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx
2827

@@ -94,7 +93,7 @@ parseModule externalExts0 fp string = do
9493
let dynFlags0 = foldl' toggleExt baseDynFlags externalExts1
9594

9695
-- Parse options from file
97-
let fileOptions = fmap GHC.unLoc $ GHC.getOptions dynFlags0
96+
let fileOptions = fmap GHC.unLoc $ snd $ GHC.getOptions (GHC.initParserOpts dynFlags0)
9897
(GHC.stringToStringBuffer string)
9998
(fromMaybe "-" fp)
10099
fileExtensions = mapMaybe (\str -> do
@@ -115,9 +114,8 @@ parseModule externalExts0 fp string = do
115114
-- Actual parse.
116115
case GHCEx.parseModule input dynFlags1 of
117116
GHC.POk _ m -> Right m
118-
GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 .
119-
GHC.vcat . GHC.pprMsgEnvelopeBagWithLoc . fmap GHC.pprError . snd $
120-
GHC.getMessages ps
117+
GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 . GHC.pprMessages . snd $
118+
GHC.getPsMessages ps
121119
where
122120
withFileName x = maybe "" (<> ": ") fp <> x
123121

‎lib/Language/Haskell/Stylish/Printer.hs

+7-9
Original file line numberDiff line numberDiff line change
@@ -136,14 +136,11 @@ putAllSpanComments suff = \case
136136
-- | Print any comment
137137
putComment :: GHC.EpaComment -> P ()
138138
putComment epaComment = case GHC.ac_tok epaComment of
139-
GHC.EpaLineComment s -> putText s
140-
GHC.EpaDocCommentNext s -> putText s
141-
GHC.EpaDocCommentPrev s -> putText s
142-
GHC.EpaDocCommentNamed s -> putText s
143-
GHC.EpaDocSection _ s -> putText s
144-
GHC.EpaDocOptions s -> putText s
145-
GHC.EpaBlockComment s -> putText s
146-
GHC.EpaEofComment -> pure ()
139+
GHC.EpaDocComment hs -> putText $ show hs
140+
GHC.EpaLineComment s -> putText s
141+
GHC.EpaDocOptions s -> putText s
142+
GHC.EpaBlockComment s -> putText s
143+
GHC.EpaEofComment -> pure ()
147144

148145
putMaybeLineComment :: Maybe GHC.EpaComment -> P ()
149146
putMaybeLineComment = \case
@@ -176,6 +173,7 @@ nameAnnAdornment :: GHC.NameAnn -> (String, String)
176173
nameAnnAdornment = \case
177174
GHC.NameAnn {..} -> fromAdornment nann_adornment
178175
GHC.NameAnnCommas {..} -> fromAdornment nann_adornment
176+
GHC.NameAnnBars {..} -> fromAdornment nann_adornment
179177
GHC.NameAnnOnly {..} -> fromAdornment nann_adornment
180178
GHC.NameAnnRArrow {} -> (mempty, mempty)
181179
GHC.NameAnnQuote {} -> ("'", mempty)
@@ -216,7 +214,7 @@ putType ltp = case GHC.unLoc ltp of
216214
(comma >> space)
217215
(fmap putType xs)
218216
putText ")"
219-
GHC.HsOpTy _ lhs op rhs -> do
217+
GHC.HsOpTy _ _ lhs op rhs -> do
220218
putType lhs
221219
space
222220
putRdrName op

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

+5-5
Original file line numberDiff line numberDiff line change
@@ -330,7 +330,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
330330
-- Put argument to constructor first:
331331
case con_g_args of
332332
GHC.PrefixConGADT _ -> sep (comma >> space) $ fmap putRdrName con_names
333-
GHC.RecConGADT _ -> error . mconcat $
333+
GHC.RecConGADT _ _ -> error . mconcat $
334334
[ "Language.Haskell.Stylish.Step.Data.putConstructor: "
335335
, "encountered a GADT with record constructors, not supported yet"
336336
]
@@ -352,7 +352,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
352352
GHC.PrefixConGADT scaledTys -> forM_ scaledTys $ \scaledTy -> do
353353
putType $ GHC.hsScaledThing scaledTy
354354
space >> putText "->" >> space
355-
GHC.RecConGADT _ -> error . mconcat $
355+
GHC.RecConGADT _ _ -> error . mconcat $
356356
[ "Language.Haskell.Stylish.Step.Data.putConstructor: "
357357
, "encountered a GADT with record constructors, not supported yet"
358358
]
@@ -371,7 +371,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
371371
GHC.PrefixCon _tyargs args -> do
372372
putRdrName con_name
373373
unless (null args) space
374-
sep space (fmap putOutputable args)
374+
sep space (fmap (putOutputable . GHC.hsScaledThing) args)
375375
GHC.RecCon largs | _ : _ <- GHC.unLoc largs -> do
376376
putRdrName con_name
377377
skipToBrace
@@ -442,7 +442,7 @@ putNewtypeConstructor cfg lcons = case GHC.unLoc lcons of
442442
putRdrName con_name >> case con_args of
443443
GHC.PrefixCon _ args -> do
444444
unless (null args) space
445-
sep space (fmap putOutputable args)
445+
sep space (fmap (putOutputable . GHC.hsScaledThing) args)
446446
GHC.RecCon largs | [firstArg] <- GHC.unLoc largs -> do
447447
space
448448
putText "{"
@@ -515,7 +515,7 @@ putType' cfg lty = case GHC.unLoc lty of
515515
space
516516
putType' cfg tp
517517
GHC.HsQualTy GHC.NoExtField ctx tp -> do
518-
forM_ ctx $ putContext cfg
518+
putContext cfg ctx
519519
putType' cfg tp
520520
_ -> putType lty
521521

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

+7-5
Original file line numberDiff line numberDiff line change
@@ -41,12 +41,13 @@ import qualified Data.Text as T
4141
import qualified GHC.Data.FastString as GHC
4242
import qualified GHC.Hs as GHC
4343
import qualified GHC.Types.Name.Reader as GHC
44+
import qualified GHC.Types.PkgQual as GHC
4445
import qualified GHC.Types.SourceText as GHC
4546
import qualified GHC.Types.SrcLoc as GHC
4647
import qualified GHC.Unit.Module.Name as GHC
4748
import qualified GHC.Unit.Types as GHC
48-
import Text.Regex.TDFA (Regex)
4949
import qualified Text.Regex.TDFA as Regex
50+
import Text.Regex.TDFA (Regex)
5051
import Text.Regex.TDFA.ReadRegex (parseRegex)
5152

5253
--------------------------------------------------------------------------------
@@ -358,8 +359,9 @@ printQualified Options{..} padNames stats ldecl = do
358359

359360
let module_ = do
360361
moduleNamePosition <- length <$> getCurrentLine
361-
forM_ (GHC.ideclPkgQual decl) $ \pkg ->
362-
putText (stringLiteral pkg) >> space
362+
case GHC.ideclPkgQual decl of
363+
GHC.NoRawPkgQual -> pure ()
364+
GHC.RawPkgQual pkg -> putText (stringLiteral pkg) >> space
363365
putText (importModuleName decl)
364366

365367
-- Only print spaces if something follows.
@@ -584,8 +586,8 @@ importStats i =
584586
importModuleNameLength :: GHC.ImportDecl GHC.GhcPs -> Int
585587
importModuleNameLength imp =
586588
(case GHC.ideclPkgQual imp of
587-
Nothing -> 0
588-
Just sl -> 1 + length (stringLiteral sl)) +
589+
GHC.NoRawPkgQual -> 0
590+
GHC.RawPkgQual sl -> 1 + length (stringLiteral sl)) +
589591
(length $ importModuleName imp)
590592

591593

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

+2-4
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,6 @@ printModuleHeader :: Maybe Int -> Config -> Lines -> Module -> Lines
6969
printModuleHeader maxCols conf ls lmodul =
7070
let modul = GHC.unLoc lmodul
7171
name = GHC.unLoc <$> GHC.hsmodName modul
72-
haddocks = GHC.hsmodHaddockModHeader modul
7372

7473
startLine = fromMaybe 1 $ moduleLine <|>
7574
(fmap GHC.srcSpanStartLine . GHC.srcSpanToRealSrcSpan $
@@ -108,7 +107,7 @@ printModuleHeader maxCols conf ls lmodul =
108107
printedModuleHeader = runPrinter_
109108
(PrinterConfig maxCols)
110109
(printHeader
111-
conf name exportGroups haddocks moduleComment whereComment)
110+
conf name exportGroups moduleComment whereComment)
112111

113112
changes = Editor.changeLines
114113
(Editor.Block startLine endLine)
@@ -122,11 +121,10 @@ printHeader
122121
:: Config
123122
-> Maybe GHC.ModuleName
124123
-> Maybe [CommentGroup (GHC.LIE GHC.GhcPs)]
125-
-> Maybe GHC.LHsDocString
126124
-> Maybe GHC.LEpaComment -- Comment attached to 'module'
127125
-> Maybe GHC.LEpaComment -- Comment attached to 'where'
128126
-> P ()
129-
printHeader conf mbName mbExps _ mbModuleComment mbWhereComment = do
127+
printHeader conf mbName mbExps mbModuleComment mbWhereComment = do
130128
forM_ mbName $ \name -> do
131129
putText "module"
132130
space

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

+6-6
Original file line numberDiff line numberDiff line change
@@ -15,13 +15,13 @@ import Data.Foldable (toList)
1515
import Data.List (foldl', foldl1', sortOn)
1616
import Data.Maybe (fromMaybe)
1717
import qualified GHC.Hs as Hs
18-
import qualified GHC.Parser.Annotation as GHC
19-
import qualified GHC.Types.SrcLoc as GHC
18+
import qualified GHC.Parser.Annotation as GHC
19+
import qualified GHC.Types.SrcLoc as GHC
2020

2121

2222
--------------------------------------------------------------------------------
2323
import Language.Haskell.Stylish.Align
24-
import qualified Language.Haskell.Stylish.Editor as Editor
24+
import qualified Language.Haskell.Stylish.Editor as Editor
2525
import Language.Haskell.Stylish.Module
2626
import Language.Haskell.Stylish.Step
2727
import Language.Haskell.Stylish.Util
@@ -88,7 +88,7 @@ fieldDeclToAlignable
8888
:: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan)
8989
fieldDeclToAlignable (GHC.L matchLoc (Hs.ConDeclField _ names ty _)) = do
9090
matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc
91-
leftPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLoc $ last names
91+
leftPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA $ last names
9292
tyPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA ty
9393
Just $ Alignable
9494
{ aContainer = matchPos
@@ -162,9 +162,9 @@ multiWayIfToAlignable _conf _ = []
162162

163163
--------------------------------------------------------------------------------
164164
grhsToAlignable
165-
:: GHC.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
165+
:: GHC.GenLocated (GHC.SrcSpanAnn' a) (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
166166
-> Maybe (Alignable GHC.RealSrcSpan)
167-
grhsToAlignable (GHC.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do
167+
grhsToAlignable (GHC.L (GHC.SrcSpanAnn _ grhsloc) (Hs.GRHS _ guards@(_ : _) body)) = do
168168
let guardsLocs = map GHC.getLocA guards
169169
bodyLoc = GHC.getLocA $ body
170170
left = foldl1' GHC.combineSrcSpans guardsLocs

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,7 @@ squash l r
3737
--------------------------------------------------------------------------------
3838
squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Editor.Edits
3939
squashFieldDecl (GHC.ConDeclField ext names@(_ : _) type' _)
40-
| Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLoc $ last names
40+
| Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last names
4141
, Just sep <- fieldDeclSeparator ext
4242
, Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA type' =
4343
squash left sep <> squash sep right

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ module Language.Haskell.Stylish.Step.TrailingWhitespace
55

66

77
--------------------------------------------------------------------------------
8-
import Data.Char (isSpace)
8+
import Data.Char (isSpace)
99

1010

1111
--------------------------------------------------------------------------------

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

+4-6
Original file line numberDiff line numberDiff line change
@@ -19,17 +19,15 @@ import Language.Haskell.Stylish.Util (everything)
1919

2020
--------------------------------------------------------------------------------
2121
hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits
22-
hsTyReplacements (GHC.HsFunTy xann arr _ _)
23-
| GHC.HsUnrestrictedArrow GHC.NormalSyntax <- arr
24-
, GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann =
25-
Editor.replaceRealSrcSpan loc "→"
26-
hsTyReplacements (GHC.HsQualTy _ (Just ctx) _)
22+
hsTyReplacements (GHC.HsFunTy _ arr _ _)
23+
| GHC.HsUnrestrictedArrow (GHC.L (GHC.TokenLoc epaLoc) GHC.HsNormalTok) <- arr=
24+
Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan epaLoc) "→"
25+
hsTyReplacements (GHC.HsQualTy _ ctx _)
2726
| Just arrow <- GHC.ac_darrow . GHC.anns . GHC.ann $ GHC.getLoc ctx
2827
, (GHC.NormalSyntax, GHC.EpaSpan loc) <- arrow =
2928
Editor.replaceRealSrcSpan loc "⇒"
3029
hsTyReplacements _ = mempty
3130

32-
3331
--------------------------------------------------------------------------------
3432
hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits
3533
hsSigReplacements (GHC.TypeSig ann _ _)

0 commit comments

Comments
 (0)