Skip to content

Commit be4814e

Browse files
jaspervdjjaspervdj
authored
Port to GHC 9.2 AST
1 parent ba710aa commit be4814e

34 files changed

+2320
-2666
lines changed

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

+11-11
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Align
88

99
--------------------------------------------------------------------------------
1010
import Data.List (nub)
11-
import qualified SrcLoc as S
11+
import qualified GHC.Types.SrcLoc as GHC
1212

1313

1414
--------------------------------------------------------------------------------
@@ -55,9 +55,9 @@ data Alignable a = Alignable
5555
-- | Create changes that perform the alignment.
5656

5757
align
58-
:: Maybe Int -- ^ Max columns
59-
-> [Alignable S.RealSrcSpan] -- ^ Alignables
60-
-> [Change String] -- ^ Changes performing the alignment
58+
:: Maybe Int -- ^ Max columns
59+
-> [Alignable GHC.RealSrcSpan] -- ^ Alignables
60+
-> [Change String] -- ^ Changes performing the alignment
6161
align _ [] = []
6262
align maxColumns alignment
6363
-- Do not make an changes if we would go past the maximum number of columns
@@ -70,29 +70,29 @@ align maxColumns alignment
7070
Just c -> i > c
7171

7272
-- The longest thing in the left column
73-
longestLeft = maximum $ map (S.srcSpanEndCol . aLeft) alignment
73+
longestLeft = maximum $ map (GHC.srcSpanEndCol . aLeft) alignment
7474

7575
-- The longest thing in the right column
7676
longestRight = maximum
77-
[ S.srcSpanEndCol (aRight a) - S.srcSpanStartCol (aRight a)
77+
[ GHC.srcSpanEndCol (aRight a) - GHC.srcSpanStartCol (aRight a)
7878
+ aRightLead a
7979
| a <- alignment
8080
]
8181

82-
align' a = changeLine (S.srcSpanStartLine $ aContainer a) $ \str ->
83-
let column = S.srcSpanEndCol $ aLeft a
82+
align' a = changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str ->
83+
let column = GHC.srcSpanEndCol $ aLeft a
8484
(pre, post) = splitAt column str
8585
in [padRight longestLeft (trimRight pre) ++ trimLeft post]
8686

8787
--------------------------------------------------------------------------------
8888
-- | Checks that all the alignables appear on a single line, and that they do
8989
-- not overlap.
9090

91-
fixable :: [Alignable S.RealSrcSpan] -> Bool
91+
fixable :: [Alignable GHC.RealSrcSpan] -> Bool
9292
fixable [] = False
9393
fixable [_] = False
9494
fixable fields = all singleLine containers && nonOverlapping containers
9595
where
9696
containers = map aContainer fields
97-
singleLine s = S.srcSpanStartLine s == S.srcSpanEndLine s
98-
nonOverlapping ss = length ss == length (nub $ map S.srcSpanStartLine ss)
97+
singleLine s = GHC.srcSpanStartLine s == GHC.srcSpanEndLine s
98+
nonOverlapping ss = length ss == length (nub $ map GHC.srcSpanStartLine ss)

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

+16-4
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
module Language.Haskell.Stylish.Block
33
( Block (..)
44
, LineBlock
5+
, realSrcSpanToLineBlock
56
, SpanBlock
67
, blockLength
78
, moveBlock
@@ -14,16 +15,21 @@ module Language.Haskell.Stylish.Block
1415

1516

1617
--------------------------------------------------------------------------------
17-
import qualified Data.IntSet as IS
18+
import qualified Data.IntSet as IS
19+
import qualified GHC.Types.SrcLoc as GHC
1820

1921

2022
--------------------------------------------------------------------------------
2123
-- | Indicates a line span
2224
data Block a = Block
2325
{ blockStart :: Int
2426
, blockEnd :: Int
25-
}
26-
deriving (Eq, Ord, Show)
27+
} deriving (Eq, Ord, Show)
28+
29+
30+
--------------------------------------------------------------------------------
31+
instance Semigroup (Block a) where
32+
(<>) = merge
2733

2834

2935
--------------------------------------------------------------------------------
@@ -34,10 +40,16 @@ type LineBlock = Block String
3440
type SpanBlock = Block Char
3541

3642

43+
--------------------------------------------------------------------------------
44+
realSrcSpanToLineBlock :: GHC.RealSrcSpan -> Block String
45+
realSrcSpanToLineBlock s = Block (GHC.srcSpanStartLine s) (GHC.srcSpanEndLine s)
46+
47+
3748
--------------------------------------------------------------------------------
3849
blockLength :: Block a -> Int
3950
blockLength (Block start end) = end - start + 1
4051

52+
4153
--------------------------------------------------------------------------------
4254
moveBlock :: Int -> Block a -> Block a
4355
moveBlock offset (Block start end) = Block (start + offset) (end + offset)
@@ -47,7 +59,7 @@ moveBlock offset (Block start end) = Block (start + offset) (end + offset)
4759
adjacent :: Block a -> Block a -> Bool
4860
adjacent b1 b2 = follows b1 b2 || follows b2 b1
4961
where
50-
follows (Block _ e1) (Block s2 _) = e1 + 1 == s2
62+
follows (Block _ e1) (Block s2 _) = e1 == s2 || e1 + 1 == s2
5163

5264

5365
--------------------------------------------------------------------------------

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

+145
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,145 @@
1+
--------------------------------------------------------------------------------
2+
-- | Utilities for assocgating comments with things in a list.
3+
{-# LANGUAGE RecordWildCards #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
module Language.Haskell.Stylish.Comments
6+
( CommentGroup (..)
7+
, commentGroups
8+
, commentGroupHasComments
9+
, commentGroupSort
10+
) where
11+
12+
13+
--------------------------------------------------------------------------------
14+
import Data.Function (on)
15+
import Data.List (sortBy, sortOn)
16+
import Data.Maybe (isNothing, maybeToList)
17+
import qualified GHC.Hs as GHC
18+
import qualified GHC.Types.SrcLoc as GHC
19+
import qualified GHC.Utils.Outputable as GHC
20+
21+
22+
--------------------------------------------------------------------------------
23+
import Language.Haskell.Stylish.Block
24+
import Language.Haskell.Stylish.GHC
25+
26+
27+
--------------------------------------------------------------------------------
28+
data CommentGroup a = CommentGroup
29+
{ cgBlock :: LineBlock
30+
, cgPrior :: [GHC.LEpaComment]
31+
, cgItems :: [(a, Maybe GHC.LEpaComment)]
32+
, cgFollowing :: [GHC.LEpaComment]
33+
}
34+
35+
36+
--------------------------------------------------------------------------------
37+
instance GHC.Outputable a => Show (CommentGroup a) where
38+
show CommentGroup {..} = "(CommentGroup (" ++
39+
show cgBlock ++ ") (" ++
40+
showOutputable cgPrior ++ ") (" ++
41+
showOutputable cgItems ++ ") (" ++
42+
showOutputable cgFollowing ++ "))"
43+
44+
45+
--------------------------------------------------------------------------------
46+
commentGroups
47+
:: forall a.
48+
(a -> Maybe GHC.RealSrcSpan)
49+
-> [a]
50+
-> [GHC.LEpaComment]
51+
-> [CommentGroup a]
52+
commentGroups getSpan allItems allComments =
53+
work Nothing (sortOn fst allItemsWithLines) (sortOn fst commentsWithLines)
54+
where
55+
allItemsWithLines :: [(LineBlock, a)]
56+
allItemsWithLines = do
57+
item <- allItems
58+
s <- maybeToList $ getSpan item
59+
pure (realSrcSpanToLineBlock s, item)
60+
61+
commentsWithLines :: [(LineBlock, GHC.LEpaComment)]
62+
commentsWithLines = do
63+
comment <- allComments
64+
let s = GHC.anchor $ GHC.getLoc comment
65+
pure (realSrcSpanToLineBlock s, comment)
66+
67+
work
68+
:: Maybe (CommentGroup a)
69+
-> [(LineBlock, a)]
70+
-> [(LineBlock, GHC.LEpaComment)]
71+
-> [CommentGroup a]
72+
work mbCurrent items comments = case takeNext items comments of
73+
Nothing -> maybeToList mbCurrent
74+
Just (b, next, items', comments') ->
75+
let (flush, current) = case mbCurrent of
76+
Just c | adjacent (cgBlock c) b
77+
, nextThingItem next
78+
, following@(_ : _) <- cgFollowing c ->
79+
([c {cgFollowing = []}], CommentGroup b following [] [])
80+
Just c | adjacent (cgBlock c) b ->
81+
([], c {cgBlock = cgBlock c <> b})
82+
_ -> (maybeToList mbCurrent, CommentGroup b [] [] [])
83+
current' = case next of
84+
NextItem i -> current {cgItems = cgItems current <> [(i, Nothing)]}
85+
NextComment c
86+
| null (cgItems current) -> current {cgPrior = cgPrior current <> [c]}
87+
| otherwise -> current {cgFollowing = cgFollowing current <> [c]}
88+
NextItemWithComment i c ->
89+
current {cgItems = cgItems current <> [(i, Just c)]} in
90+
flush ++ work (Just current') items' comments'
91+
92+
93+
94+
--------------------------------------------------------------------------------
95+
takeNext
96+
:: [(LineBlock, a)]
97+
-> [(LineBlock, GHC.LEpaComment)]
98+
-> Maybe (LineBlock, NextThing a, [(LineBlock, a)], [(LineBlock, GHC.LEpaComment)])
99+
takeNext [] [] = Nothing
100+
takeNext [] ((cb, c) : comments) =
101+
Just (cb, NextComment c, [], comments)
102+
takeNext ((ib, i) : items) [] =
103+
Just (ib, NextItem i, items, [])
104+
takeNext ((ib, i) : items) ((cb, c) : comments)
105+
| blockStart ib == blockStart cb =
106+
Just (ib <> cb, NextItemWithComment i c, items, comments)
107+
| blockStart ib < blockStart cb =
108+
Just (ib, NextItem i, items, (cb, c) : comments)
109+
| otherwise =
110+
Just (cb, NextComment c, (ib, i) : items, comments)
111+
112+
113+
--------------------------------------------------------------------------------
114+
data NextThing a
115+
= NextComment GHC.LEpaComment
116+
| NextItem a
117+
| NextItemWithComment a GHC.LEpaComment
118+
119+
120+
--------------------------------------------------------------------------------
121+
instance GHC.Outputable a => Show (NextThing a) where
122+
show (NextComment c) = "NextComment " ++ showOutputable c
123+
show (NextItem i) = "NextItem " ++ showOutputable i
124+
show (NextItemWithComment i c) =
125+
"NextItemWithComment " ++ showOutputable i ++ " " ++ showOutputable c
126+
127+
128+
--------------------------------------------------------------------------------
129+
nextThingItem :: NextThing a -> Bool
130+
nextThingItem (NextComment _) = False
131+
nextThingItem (NextItem _) = True
132+
nextThingItem (NextItemWithComment _ _) = True
133+
134+
135+
--------------------------------------------------------------------------------
136+
commentGroupHasComments :: CommentGroup a -> Bool
137+
commentGroupHasComments CommentGroup {..} = not $
138+
null cgPrior && all (isNothing . snd) cgItems && null cgFollowing
139+
140+
141+
--------------------------------------------------------------------------------
142+
commentGroupSort :: (a -> a -> Ordering) -> CommentGroup a -> CommentGroup a
143+
commentGroupSort cmp cg = cg
144+
{ cgItems = sortBy (cmp `on` fst) (cgItems cg)
145+
}

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

+8-11
Original file line numberDiff line numberDiff line change
@@ -260,17 +260,14 @@ parseRecords c o = Data.step
260260
maybe Data.NoMaxColumns Data.MaxColumns (configColumns c)
261261

262262
parseIndent :: A.Value -> A.Parser Data.Indent
263-
parseIndent = A.withText "Indent" $ \t ->
264-
if t == "same_line"
265-
then return Data.SameLine
266-
else
267-
if "indent " `T.isPrefixOf` t
268-
then
269-
case readMaybe (T.unpack $ T.drop 7 t) of
270-
Just n -> return $ Data.Indent n
271-
Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
272-
else fail $ "can't parse indent setting: " <> T.unpack t
273-
263+
parseIndent = \case
264+
A.String "same_line" -> return Data.SameLine
265+
A.String t | "indent " `T.isPrefixOf` t ->
266+
case readMaybe (T.unpack $ T.drop 7 t) of
267+
Just n -> return $ Data.Indent n
268+
Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
269+
A.String t -> fail $ "can't parse indent setting: " <> T.unpack t
270+
_ -> fail "Expected string for indent value"
274271

275272
--------------------------------------------------------------------------------
276273
parseSquash :: Config -> A.Object -> A.Parser Step

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

-1
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ import Data.Maybe (maybeToList)
1111
import qualified Distribution.PackageDescription as Cabal
1212
import qualified Distribution.PackageDescription.Parsec as Cabal
1313
import qualified Distribution.Simple.Utils as Cabal
14-
import qualified Distribution.Types.CondTree as Cabal
1514
import qualified Distribution.Verbosity as Cabal
1615
import qualified Language.Haskell.Extension as Language
1716
import Language.Haskell.Stylish.Verbose

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

+3-1
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,9 @@
99
-- when this is evaluated, we take into account that 4th line will become the
1010
-- 3rd line before it needs changing.
1111
module Language.Haskell.Stylish.Editor
12-
( Change
12+
( module Language.Haskell.Stylish.Block
13+
14+
, Change
1315
, applyChanges
1416

1517
, change

0 commit comments

Comments
 (0)