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