Skip to content

Commit c4bcd1d

Browse files
GuillaumedeVolpianoGuillaumedeVolpiano
committed
GHC-9.12 support
1 parent 834bb29 commit c4bcd1d

File tree

13 files changed

+81
-74
lines changed

13 files changed

+81
-74
lines changed

‎.github/workflows/ci.yml

+1-1
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ jobs:
99
strategy:
1010
matrix:
1111
os: [ubuntu-latest, macOS-latest]
12-
ghc: ["9.6", "9.8", "9.10"]
12+
ghc: ["9.10", "9.12"]
1313

1414
steps:
1515
- uses: actions/checkout@v4

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@ commentGroups getSpan allItems allComments =
6161
commentsWithLines :: [(LineBlock, GHC.LEpaComment)]
6262
commentsWithLines = do
6363
comment <- allComments
64-
let s = GHC.anchor $ GHC.getLoc comment
64+
let s = GHC.epaLocationRealSrcSpan $ GHC.getLoc comment
6565
pure (realSrcSpanToLineBlock s, comment)
6666

6767
work

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,6 @@ deepAnnComments :: (Data a, Typeable a) => a -> [GHC.LEpaComment]
8686
deepAnnComments = everything (++) (mkQ [] priorAndFollowing)
8787

8888
priorAndFollowing :: GHC.EpAnnComments -> [GHC.LEpaComment]
89-
priorAndFollowing = sortOn (GHC.anchor . GHC.getLoc) . \case
89+
priorAndFollowing = sortOn (GHC.epaLocationRealSrcSpan . GHC.getLoc) . \case
9090
GHC.EpaComments {..} -> priorComments
9191
GHC.EpaCommentsBalanced {..} -> priorComments ++ followingComments

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,7 @@ moduleLanguagePragmas =
141141
prag comment = case GHC.ac_tok (GHC.unLoc comment) of
142142
GHC.EpaBlockComment str
143143
| lang : p1 : ps <- tokenize str, map toLower lang == "language" ->
144-
pure (GHC.anchor (GHC.getLoc comment), p1 :| ps)
144+
pure (GHC.epaLocationRealSrcSpan (GHC.getLoc comment), p1 :| ps)
145145
_ -> Nothing
146146

147147
tokenize = words .

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

+18-18
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
{-# LANGUAGE BlockArguments #-}
2-
{-# LANGUAGE DeriveGeneric #-}
2+
33
{-# LANGUAGE DerivingStrategies #-}
44
{-# LANGUAGE DoAndIfThenElse #-}
55
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
66
{-# LANGUAGE LambdaCase #-}
7-
{-# LANGUAGE RecordWildCards #-}
7+
88
module Language.Haskell.Stylish.Printer
99
( Printer(..)
1010
, PrinterConfig(..)
@@ -91,7 +91,7 @@ runPrinter cfg (Printer printer) =
9191
let
9292
(a, PrinterState parsedLines _ startedLine) = runReaderT printer cfg `runState` PrinterState [] 0 ""
9393
in
94-
(a, parsedLines <> if startedLine == [] then [] else [startedLine])
94+
(a, parsedLines <> ([startedLine | startedLine /= []]))
9595

9696
-- | Run printer to get printed lines only
9797
runPrinter_ :: PrinterConfig -> Printer a -> Lines
@@ -160,18 +160,18 @@ putRdrName rdrName = case GHC.unLoc rdrName of
160160

161161
nameAnnAdornment :: GHC.NameAnn -> (String, String)
162162
nameAnnAdornment = \case
163-
GHC.NameAnn {..} -> fromAdornment nann_adornment
164-
GHC.NameAnnCommas {..} -> fromAdornment nann_adornment
165-
GHC.NameAnnBars {..} -> fromAdornment nann_adornment
166-
GHC.NameAnnOnly {..} -> fromAdornment nann_adornment
163+
GHC.NameAnn {GHC.nann_adornment = na} -> fromAdornment na
164+
GHC.NameAnnCommas {GHC.nann_adornment = na} -> fromAdornment na
165+
GHC.NameAnnBars {GHC.nann_parensh = (o, c)} -> fromAdornment (GHC.NameParensHash o c)
166+
GHC.NameAnnOnly {GHC.nann_adornment = na} -> fromAdornment na
167167
GHC.NameAnnRArrow {} -> (mempty, mempty)
168168
GHC.NameAnnQuote {} -> ("'", mempty)
169169
GHC.NameAnnTrailing {} -> (mempty, mempty)
170170
where
171-
fromAdornment GHC.NameParens = ("(", ")")
172-
fromAdornment GHC.NameBackquotes = ("`", "`")
173-
fromAdornment GHC.NameParensHash = ("#(", "#)")
174-
fromAdornment GHC.NameSquare = ("[", "]")
171+
fromAdornment (GHC.NameParens _ _) = ("(", ")")
172+
fromAdornment (GHC.NameBackquotes _ _) = ("`", "`")
173+
fromAdornment (GHC.NameParensHash _ _) = ("(#", "#)")
174+
fromAdornment (GHC.NameSquare _ _) = ("[", "]")
175175

176176
-- | Print module name
177177
putModuleName :: GHC.ModuleName -> P ()
@@ -197,7 +197,7 @@ putType ltp = case GHC.unLoc ltp of
197197
(comma >> space)
198198
(fmap putType xs)
199199
putText "]"
200-
GHC.HsExplicitTupleTy _ xs -> do
200+
GHC.HsExplicitTupleTy _ _ xs -> do
201201
putText "'("
202202
sep
203203
(comma >> space)
@@ -230,23 +230,23 @@ putType ltp = case GHC.unLoc ltp of
230230
putOutputable ltp
231231
GHC.HsQualTy {} ->
232232
putOutputable ltp
233-
GHC.HsAppKindTy _ _ _ ->
233+
GHC.HsAppKindTy {} ->
234234
putOutputable ltp
235235
GHC.HsListTy _ _ ->
236236
putOutputable ltp
237237
GHC.HsSumTy _ _ ->
238238
putOutputable ltp
239-
GHC.HsIParamTy _ _ _ ->
239+
GHC.HsIParamTy {} ->
240240
putOutputable ltp
241-
GHC.HsKindSig _ _ _ ->
241+
GHC.HsKindSig {} ->
242242
putOutputable ltp
243243
GHC.HsStarTy _ _ ->
244244
putOutputable ltp
245245
GHC.HsSpliceTy _ _ ->
246246
putOutputable ltp
247-
GHC.HsDocTy _ _ _ ->
247+
GHC.HsDocTy {} ->
248248
putOutputable ltp
249-
GHC.HsBangTy _ _ _ ->
249+
GHC.HsBangTy {} ->
250250
putOutputable ltp
251251
GHC.HsRecTy _ _ ->
252252
putOutputable ltp
@@ -284,7 +284,7 @@ parenthesize action = putText "(" *> action <* putText ")"
284284
-- | Add separator between each element of the given printers
285285
sep :: P a -> [P a] -> P ()
286286
sep _ [] = pure ()
287-
sep s (first : rest) = first >> forM_ rest ((>>) s)
287+
sep s (first : rest) = first >> forM_ rest (s >>)
288288

289289
-- | Prefix a printer with another one
290290
prefix :: P a -> P b -> P b

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

+20-11
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,6 @@
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE DoAndIfThenElse #-}
44
{-# LANGUAGE FlexibleContexts #-}
5-
{-# LANGUAGE LambdaCase #-}
65
{-# LANGUAGE MultiWayIf #-}
76
{-# LANGUAGE NamedFieldPuns #-}
87
{-# LANGUAGE RecordWildCards #-}
@@ -93,19 +92,29 @@ step cfg = makeStep "Data" \ls m -> Editor.apply (changes m) ls
9392
changes :: Module -> Editor.Edits
9493
changes = foldMap (formatDataDecl cfg) . dataDecls
9594

96-
getComments :: GHC.AddEpAnn -> [GHC.LEpaComment]
97-
getComments (GHC.AddEpAnn _ epaLoc) = case epaLoc of
98-
GHC.EpaDelta _ comments -> comments
99-
GHC.EpaSpan _ -> []
95+
getComments :: GHC.SrcSpanAnnA -> [GHC.LEpaComment]
96+
getComments (GHC.EpAnn _ _ c)= GHC.priorComments c
97+
98+
-- ugly workaround to make sure we don't reprint a haddock
99+
-- comment before a data declaration after a data
100+
-- declaration…
101+
filterLoc :: GHC.RealSrcSpan -> [GHC.LEpaComment] -> [GHC.LEpaComment]
102+
filterLoc loc = filter afterStart
103+
where
104+
afterStart c = comLoc c >= GHC.srcSpanStartLine loc
105+
comLoc (GHC.L l _) = case l of
106+
GHC.EpaSpan (GHC.RealSrcSpan l' _) -> GHC.srcSpanStartLine l'
107+
GHC.EpaDelta (GHC.RealSrcSpan l' _) _ _ -> GHC.srcSpanStartLine l'
108+
_ -> undefined -- hopefully we don't get a UnhelpfulSpan passed to us
100109

101110
dataDecls :: Module -> [DataDecl]
102111
dataDecls m = do
103-
ldecl <- GHC.hsmodDecls $ GHC.unLoc m
104-
GHC.TyClD _ tycld <- pure $ GHC.unLoc ldecl
112+
ldecl <- GHC.hsmodDecls . GHC.unLoc $ m
113+
(GHC.TyClD _ tycld, annos) <- pure $ (\(GHC.L anno ty) -> (ty, anno)) ldecl
105114
loc <- maybeToList $ GHC.srcSpanToRealSrcSpan $ GHC.getLocA ldecl
106115
case tycld of
107116
GHC.DataDecl {..} -> pure $ MkDataDecl
108-
{ dataComments = foldMap getComments tcdDExt
117+
{ dataComments = filterLoc loc . getComments $ annos
109118
, dataLoc = loc
110119
, dataDeclName = tcdLName
111120
, dataTypeVars = tcdTyVars
@@ -150,7 +159,7 @@ putDataDecl cfg@Config {..} decl = do
150159

151160
onelineEnum =
152161
isEnum decl && not cBreakEnums &&
153-
all (not . commentGroupHasComments) constructorComments
162+
(not . any commentGroupHasComments) constructorComments
154163

155164
putText $ newOrData decl
156165
space
@@ -180,7 +189,7 @@ putDataDecl cfg@Config {..} decl = do
180189
| not . null $ GHC.dd_cons defn -> do
181190
forM_ (flagEnds constructorComments) $ \(CommentGroup {..}, firstGroup, lastGroup) -> do
182191
forM_ cgPrior $ \lc -> do
183-
putComment $ GHC.unLoc lc
192+
putComment . GHC.unLoc $ lc
184193
consIndent lineLengthAfterEq
185194

186195
forM_ (flagEnds cgItems) $ \((lcon, mbInlineComment), firstItem, lastItem) -> do
@@ -335,7 +344,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of
335344
GHC.ConDeclGADT {..} -> do
336345
-- Put argument to constructor first:
337346
case con_g_args of
338-
GHC.PrefixConGADT _ _ -> sep (comma >> space) $ fmap putRdrName $ toList con_names
347+
GHC.PrefixConGADT _ _ -> sep (comma >> space) (putRdrName <$> toList con_names)
339348
GHC.RecConGADT _ _ -> error . mconcat $
340349
[ "Language.Haskell.Stylish.Step.Data.putConstructor: "
341350
, "encountered a GADT with record constructors, not supported yet"

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

+1-1
Original file line numberDiff line numberDiff line change
@@ -638,7 +638,7 @@ prepareImportList =
638638
prepareInner :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs
639639
prepareInner = \case
640640
-- Simplify `A ()` to `A`.
641-
GHC.IEThingWith x n GHC.NoIEWildcard [] md -> GHC.IEThingAbs x n md
641+
GHC.IEThingWith x n GHC.NoIEWildcard [] md -> GHC.IEThingAbs (fst x) n md
642642
GHC.IEThingWith x n w ns md ->
643643
GHC.IEThingWith x n w (sortBy (compareWrappedName `on` GHC.unLoc) ns) md
644644
ie -> ie

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

+5-5
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ prettyPragmas lp _ _ _ VerticalCompact = verticalCompactPragmas lp
102102
filterRedundant :: (String -> Bool)
103103
-> [(l, NonEmpty String)]
104104
-> [(l, [String])]
105-
filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList)
105+
filterRedundant isRedundant' = snd . foldr (filterRedundant' . fmap toList) (S.empty, [])
106106
where
107107
filterRedundant' (l, xs) (known, zs)
108108
| S.null xs' = (known', zs)
@@ -188,8 +188,8 @@ isRedundantViewPatterns = null . queryModule getViewPat
188188
-- | Check if the BangPatterns language pragma is redundant.
189189
isRedundantBangPatterns :: Module -> Bool
190190
isRedundantBangPatterns modul =
191-
(null $ queryModule getBangPat modul) &&
192-
(null $ queryModule getMatchStrict modul)
191+
null (queryModule getBangPat modul) &&
192+
null (queryModule getMatchStrict modul)
193193
where
194194
getBangPat :: GHC.Pat GHC.GhcPs -> [()]
195195
getBangPat = \case
@@ -198,5 +198,5 @@ isRedundantBangPatterns modul =
198198

199199
getMatchStrict :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> [()]
200200
getMatchStrict (GHC.Match _ ctx _ _) = case ctx of
201-
GHC.FunRhs _ _ GHC.SrcStrict -> [()]
202-
_ -> []
201+
GHC.FunRhs _ _ GHC.SrcStrict _ -> [()]
202+
_ -> []

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

+8-9
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ import qualified Language.Haskell.Stylish.Step.Imports as Imports
3232
import Language.Haskell.Stylish.Util (flagEnds)
3333
import qualified GHC.Unit.Module.Warnings as GHC
3434

35-
3635
data Config = Config
3736
{ indent :: Int
3837
, sort :: Bool
@@ -81,18 +80,18 @@ printModuleHeader maxCols conf ls lmodul =
8180
loc <- GHC.getLocA <$> GHC.hsmodExports modul
8281
GHC.srcSpanEndLine <$> GHC.srcSpanToRealSrcSpan loc)
8382

84-
keywordLine kw = listToMaybe $ do
83+
keywordLine kw = do
8584
GHC.EpAnn {..} <- pure $ GHC.hsmodAnn $ GHC.hsmodExt modul
86-
GHC.AddEpAnn kw' (GHC.EpaSpan (GHC.RealSrcSpan s _)) <- GHC.am_main anns
87-
guard $ kw == kw'
88-
pure $ GHC.srcSpanEndLine s
85+
case kw anns of
86+
GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) -> Just . GHC.srcSpanEndLine $ s
87+
_ -> Nothing
8988

90-
moduleLine = keywordLine GHC.AnnModule
91-
whereLine = keywordLine GHC.AnnWhere
89+
moduleLine = keywordLine GHC.am_mod
90+
whereLine = keywordLine GHC.am_where
9291

9392
commentOnLine l = listToMaybe $ do
9493
comment <- epAnnComments $ GHC.hsmodAnn $ GHC.hsmodExt modul
95-
guard $ GHC.srcSpanStartLine (GHC.anchor $ GHC.getLoc comment) == l
94+
guard $ GHC.srcSpanStartLine (GHC.epaLocationRealSrcSpan $ GHC.getLoc comment) == l
9695
pure comment
9796

9897
moduleComment = moduleLine >>= commentOnLine
@@ -152,7 +151,7 @@ printHeader conf mbName mbDeprec mbExps mbModuleComment mbWhereComment = do
152151
attachModuleComment
153152
Single | [egroup] <- exports
154153
, not (commentGroupHasComments egroup)
155-
, [(export, _)] <- (cgItems egroup) -> do
154+
, [(export, _)] <- cgItems egroup -> do
156155
printSingleLineExportList conf [export]
157156
attachModuleComment
158157
Inline | [] <- exports -> do

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

+8-8
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
--------------------------------------------------------------------------------
2-
{-# LANGUAGE RecordWildCards #-}
2+
33
{-# LANGUAGE TypeFamilies #-}
44
module Language.Haskell.Stylish.Step.SimpleAlign
55
( Config (..)
@@ -12,7 +12,7 @@ module Language.Haskell.Stylish.Step.SimpleAlign
1212
--------------------------------------------------------------------------------
1313
import Data.Either (partitionEithers)
1414
import Data.Foldable (toList)
15-
import Data.List (foldl', foldl1', sortOn)
15+
import Data.List (foldl1', sortOn)
1616
import Data.Maybe (fromMaybe)
1717
import qualified GHC.Hs as Hs
1818
import qualified GHC.Parser.Annotation as GHC
@@ -68,7 +68,7 @@ records :: Module -> [Record]
6868
records modu = do
6969
let decls = map GHC.unLoc (Hs.hsmodDecls (GHC.unLoc modu))
7070
tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ]
71-
dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ]
71+
dataDecls = [ d | d@(Hs.DataDecl {}) <- tyClDecls ]
7272
dataDefns = map Hs.tcdDataDefn dataDecls
7373
d@Hs.ConDeclH98 {} <- GHC.unLoc <$> concatMap getConDecls dataDefns
7474
case Hs.con_args d of
@@ -112,7 +112,7 @@ matchGroupToAlignable conf mg = cases' ++ patterns'
112112
matchToAlignable
113113
:: GHC.LocatedA (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
114114
-> Maybe (Either (Alignable GHC.RealSrcSpan) (Alignable GHC.RealSrcSpan))
115-
matchToAlignable (GHC.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do
115+
matchToAlignable (GHC.L matchLoc m@(Hs.Match _ Hs.CaseAlt (GHC.L _ pats@(_ : _)) grhss)) = do
116116
let patsLocs = map GHC.getLocA pats
117117
pat = last patsLocs
118118
guards = getGuards m
@@ -128,7 +128,7 @@ matchToAlignable (GHC.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) =
128128
, aRight = rightPos
129129
, aRightLead = length "-> "
130130
}
131-
matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do
131+
matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _ _) (GHC.L _ pats@(_ : _)) grhss)) = do
132132
body <- unguardedRhsBody grhss
133133
let patsLocs = map GHC.getLocA pats
134134
nameLoc = GHC.getLocA name
@@ -143,7 +143,7 @@ matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) g
143143
, aRight = bodyPos
144144
, aRightLead = length "= "
145145
}
146-
matchToAlignable (GHC.L _ (Hs.Match _ _ _ _)) = Nothing
146+
matchToAlignable (GHC.L _ (Hs.Match {})) = Nothing
147147

148148

149149
--------------------------------------------------------------------------------
@@ -160,11 +160,11 @@ multiWayIfToAlignable _conf _ = []
160160

161161
--------------------------------------------------------------------------------
162162
grhsToAlignable
163-
:: GHC.GenLocated (GHC.EpAnnCO) (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
163+
:: GHC.GenLocated GHC.EpAnnCO (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))
164164
-> Maybe (Alignable GHC.RealSrcSpan)
165165
grhsToAlignable (GHC.L (GHC.EpAnn (GHC.EpaSpan grhsloc) _ _ ) (Hs.GRHS _ guards@(_ : _) body)) = do
166166
let guardsLocs = map GHC.getLocA guards
167-
bodyLoc = GHC.getLocA $ body
167+
bodyLoc = GHC.getLocA body
168168
left = foldl1' GHC.combineSrcSpans guardsLocs
169169
matchPos <- GHC.srcSpanToRealSrcSpan grhsloc
170170
leftPos <- GHC.srcSpanToRealSrcSpan left

0 commit comments

Comments
 (0)