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
|
--------------------------------------------------------------------------------
module Language.Haskell.Stylish.Step.LanguagePragmas
( Style (..)
, step
-- * Utilities
, addLanguagePragma
) where
--------------------------------------------------------------------------------
import Data.List (nub, sort)
import qualified Language.Haskell.Exts.Annotated 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
| Line
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] -> Lines
verticalPragmas pragmas' =
[ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}"
| pragma <- pragmas'
]
where
longest = maximum $ map length pragmas'
--------------------------------------------------------------------------------
compactPragmas :: Int -> [String] -> Lines
compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $
map (++ ",") (init pragmas') ++ [last pragmas', "#-}"]
--------------------------------------------------------------------------------
linePragmas :: Int -> [String] -> Lines
linePragmas _ [] = []
linePragmas columns (p:pragmas') =
let (ls, curr, _) = foldl step ([], p, length p) pragmas'
ps = ls ++ [curr]
longest = maximum $ map length ps
in map (wrapLANGUAGE . padRight longest) ps
where
maxWidth = columns - 17
step (ls, curr, width) str
| width' > maxWidth = (ls ++ [curr], str, len)
| otherwise = (ls, curr ++ ", " ++ str, width')
where
len = length str
width' = width + 2 + len
wrapLANGUAGE ps = "{-# LANGUAGE " ++ ps ++ " #-}"
--------------------------------------------------------------------------------
prettyPragmas :: Int -> Style -> [String] -> Lines
prettyPragmas _ Vertical = verticalPragmas
prettyPragmas columns Compact = compactPragmas columns
prettyPragmas columns Line = linePragmas columns
--------------------------------------------------------------------------------
step :: Int -> Style -> Bool -> Step
step columns style = makeStep "LanguagePragmas" . step' columns style
--------------------------------------------------------------------------------
step' :: Int -> Style -> Bool -> Lines -> Module -> Lines
step' columns style removeRedundant ls (module', _)
| null pragmas' = ls
| otherwise = applyChanges changes ls
where
filterRedundant
| removeRedundant = filter (not . isRedundant module')
| otherwise = id
pragmas' = pragmas $ fmap linesFromSrcSpan module'
uniques = filterRedundant $ nub $ sort $ snd =<< pragmas'
loc = firstLocation pragmas'
deletes = map (delete . fst) pragmas'
changes = insert loc (prettyPragmas columns style uniques) : deletes
--------------------------------------------------------------------------------
-- | Add a LANGUAGE pragma to a module if it is not present already.
addLanguagePragma :: String -> H.Module H.SrcSpanInfo -> [Change String]
addLanguagePragma prag modu
| prag `elem` present = []
| otherwise = [insert line ["{-# LANGUAGE " ++ 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]]
|
