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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
--------------------------------------------------------------------------------
module Language.Haskell.Stylish.Step.LanguagePragmas
( Style (..)
, step
-- * Utilities
, addLanguagePragma
) where
--------------------------------------------------------------------------------
import qualified Data.Set as S
import qualified Language.Haskell.Exts as H
--------------------------------------------------------------------------------
import Language.Haskell.Stylish.Block
import Language.Haskell.Stylish.Editor
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Util
--------------------------------------------------------------------------------
data Style
= Vertical
| Compact
| CompactLine
deriving (Eq, Show)
--------------------------------------------------------------------------------
pragmas :: H.Module l -> [(l, [String])]
pragmas (H.Module _ _ ps _ _) =
[(l, map nameToString names) | H.LanguagePragma l names <- ps]
pragmas _ = []
--------------------------------------------------------------------------------
-- | The start of the first block
firstLocation :: [(Block a, [String])] -> Int
firstLocation = minimum . map (blockStart . fst)
--------------------------------------------------------------------------------
verticalPragmas :: String -> Int -> Bool -> [String] -> Lines
verticalPragmas lg longest align pragmas' =
[ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}"
| pragma <- pragmas'
]
where
pad
| align = padRight longest
| otherwise = id
--------------------------------------------------------------------------------
compactPragmas :: String -> Maybe Int -> [String] -> Lines
compactPragmas lg columns pragmas' = wrapMaybe columns ("{-# " ++ lg) 13 $
map (++ ",") (init pragmas') ++ [last pragmas' ++ " #-}"]
--------------------------------------------------------------------------------
compactLinePragmas :: String -> Maybe Int -> Bool -> [String] -> Lines
compactLinePragmas _ _ _ [] = []
compactLinePragmas lg columns align pragmas' = map (wrapLanguage . pad) prags
where
wrapLanguage ps = "{-# " ++ lg ++ ps ++ " #-}"
maxWidth = fmap (\c -> c - 16) columns
longest = maximum $ map length prags
pad
| align = padRight longest
| otherwise = id
prags = map truncateComma $ wrapMaybe maxWidth "" 1 $
map (++ ",") (init pragmas') ++ [last pragmas']
--------------------------------------------------------------------------------
truncateComma :: String -> String
truncateComma "" = ""
truncateComma xs
| last xs == ',' = init xs
| otherwise = xs
--------------------------------------------------------------------------------
prettyPragmas :: String -> Maybe Int -> Int -> Bool -> Style -> [String] -> Lines
prettyPragmas lp _ longest align Vertical = verticalPragmas lp longest align
prettyPragmas lp cols _ _ Compact = compactPragmas lp cols
prettyPragmas lp cols _ align CompactLine = compactLinePragmas lp cols align
--------------------------------------------------------------------------------
-- | Filter redundant (and duplicate) pragmas out of the groups. As a side
-- effect, we also sort the pragmas in their group...
filterRedundant :: (String -> Bool)
-> [(l, [String])]
-> [(l, [String])]
filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])
where
filterRedundant' (l, xs) (known, zs)
| S.null xs' = (known', zs)
| otherwise = (known', (l, S.toAscList xs') : zs)
where
fxs = filter (not . isRedundant') xs
xs' = S.fromList fxs `S.difference` known
known' = xs' `S.union` known
--------------------------------------------------------------------------------
step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step
step = ((((makeStep "LanguagePragmas" .) .) .) .) . step'
--------------------------------------------------------------------------------
step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
step' columns style align removeRedundant lngPrefix ls (module', _)
| null pragmas' = ls
| otherwise = applyChanges changes ls
where
isRedundant'
| removeRedundant = isRedundant module'
| otherwise = const False
pragmas' = pragmas $ fmap linesFromSrcSpan module'
longest = maximum $ map length $ snd =<< pragmas'
groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas']
changes =
[ change b (const $ prettyPragmas lngPrefix columns longest align style pg)
| (b, pg) <- filterRedundant isRedundant' groups
]
--------------------------------------------------------------------------------
-- | Add a LANGUAGE pragma to a module if it is not present already.
addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String]
addLanguagePragma lg prag modu
| prag `elem` present = []
| otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]]
where
pragmas' = pragmas (fmap linesFromSrcSpan modu)
present = concatMap snd pragmas'
line = if null pragmas' then 1 else firstLocation pragmas'
--------------------------------------------------------------------------------
-- | Check if a language pragma is redundant. We can't do this for all pragmas,
-- but we do a best effort.
isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool
isRedundant m "ViewPatterns" = isRedundantViewPatterns m
isRedundant m "BangPatterns" = isRedundantBangPatterns m
isRedundant _ _ = False
--------------------------------------------------------------------------------
-- | Check if the ViewPatterns language pragma is redundant.
isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool
isRedundantViewPatterns m = null
[() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]]
--------------------------------------------------------------------------------
-- | Check if the BangPatterns language pragma is redundant.
isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool
isRedundantBangPatterns m = null
[() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]]
|
