never executed always true always false
1 {-# OPTIONS_GHC -Wall #-}
2 module Box
3 ( Line, identifier, keyword, punc, literal, row, space
4 , Box(SingleLine, MustBreak), blankLine, line, mustBreak, stack', stack1, andThen
5 , isLine, allSingles, lineLength
6 , indent, prefix, addSuffix
7 , render
8 ) where
9
10 import Elm.Utils ((|>))
11
12 import qualified Data.Text as T
13
14
15 {-
16 A line is ALWAYS just one line.
17
18 Space is self-explanatory,
19 Tab aligns to the nearest multiple of 4 spaces,
20 Text brings any string into the data structure,
21 Row joins more of these elements onto one line.
22 -}
23 data Line
24 = Text T.Text
25 | Row [Line]
26 | Space
27 | Tab
28
29
30 identifier :: String -> Line
31 identifier =
32 Text . T.pack
33
34
35 keyword :: String -> Line
36 keyword =
37 Text . T.pack
38
39
40 punc :: String -> Line
41 punc =
42 Text . T.pack
43
44
45 literal :: String -> Line
46 literal =
47 Text . T.pack
48
49
50 -- join more Line elements into one
51 row :: [Line] -> Line
52 row =
53 Row
54
55
56 space :: Line
57 space =
58 Space
59
60
61 {-
62 Box contains Lines (at least one - can't be empty).
63 Box either:
64 - can appear in the middle of a line
65 (Stack someLine [], thus can be joined without problems), or
66 - has to appear on its own
67 (Stack someLine moreLines OR MustBreak someLine).
68
69 MustBreak is only used for `--` comments.
70
71 Stack contains two or more lines.
72
73 Sometimes (see `prefix`) the first line of Stack
74 gets different treatment than the other lines.
75 -}
76 data Box
77 = SingleLine Line
78 | Stack Line Line [Line]
79 | MustBreak Line
80
81
82 blankLine :: Box
83 blankLine =
84 line $ literal ""
85
86
87 line :: Line -> Box
88 line l =
89 SingleLine l
90
91
92 mustBreak :: Line -> Box
93 mustBreak l =
94 MustBreak l
95
96
97 stack' :: Box -> Box -> Box
98 stack' b1 b2 =
99 let
100 (line1first, line1rest) = destructure b1
101 (line2first, line2rest) = destructure b2
102 in case line1rest ++ line2first:line2rest of
103 [] ->
104 error "the list will contain at least line2first"
105 first : rest ->
106 Stack line1first first rest
107
108
109 andThen :: [Box] -> Box -> Box
110 andThen rest first =
111 foldl stack' first rest
112
113
114 stack1 :: [Box] -> Box
115 stack1 children =
116 case children of
117 [] ->
118 error "stack1: empty structure"
119 [first] ->
120 first
121 boxes ->
122 foldr1 stack' boxes
123
124
125 mapLines :: (Line -> Line) -> Box -> Box
126 mapLines fn =
127 mapFirstLine fn fn
128
129
130 mapFirstLine :: (Line -> Line) -> (Line -> Line) -> Box -> Box
131 mapFirstLine firstFn restFn b =
132 case b of
133 SingleLine l1 ->
134 SingleLine (firstFn l1)
135 Stack l1 l2 ls ->
136 Stack (firstFn l1) (restFn l2) (map restFn ls)
137 MustBreak l1 ->
138 MustBreak (firstFn l1)
139
140
141 indent :: Box -> Box
142 indent =
143 mapLines (\l -> row [Tab, l])
144
145
146 isLine :: Box -> Either Box Line
147 isLine b =
148 case b of
149 SingleLine l ->
150 Right l
151 _ ->
152 Left b
153
154
155 destructure :: Box -> (Line, [Line])
156 destructure b =
157 case b of
158 SingleLine l1 ->
159 (l1, [])
160 Stack l1 l2 rest ->
161 (l1, l2 : rest)
162 MustBreak l1 ->
163 (l1, [])
164
165
166 allSingles :: [Box] -> Either [Box] [Line]
167 allSingles boxes =
168 case sequence $ map isLine boxes of
169 Right lines' ->
170 Right lines'
171 _ ->
172 Left boxes
173
174
175 {-
176 Add the prefix to the first line,
177 pad the other lines with spaces of the same length
178
179 EXAMPLE:
180 abcde
181 xyz
182 ----->
183 myPrefix abcde
184 xyz
185 -}
186 prefix :: Line -> Box -> Box
187 prefix pref =
188 let
189 prefixLength = lineLength 0 pref
190 paddingSpaces = replicate prefixLength space
191 padLineWithSpaces l = row [ row paddingSpaces, l ]
192 addPrefixToLine l = row [ pref, l ]
193 in
194 mapFirstLine addPrefixToLine padLineWithSpaces
195
196
197 addSuffix :: Line -> Box -> Box
198 addSuffix suffix b =
199 case destructure b of
200 (l,[]) ->
201 line $ row [ l, suffix ]
202 (l1,ls) ->
203 line l1
204 |> andThen (map line $ init ls)
205 |> andThen [ line $ row [ last ls, suffix ] ]
206
207
208 renderLine :: Int -> Line -> T.Text
209 renderLine startColumn line' =
210 case line' of
211 Text text ->
212 text
213 Space ->
214 T.singleton ' '
215 Tab ->
216 T.pack $ replicate (tabLength startColumn) ' '
217 Row lines' ->
218 renderRow startColumn lines'
219
220
221 render :: Box -> T.Text
222 render box' =
223 case box' of
224 SingleLine line' ->
225 T.snoc (T.stripEnd $ renderLine 0 line') '\n'
226 Stack l1 l2 rest ->
227 T.unlines $ map (T.stripEnd . renderLine 0) (l1 : l2 : rest)
228 MustBreak line' ->
229 T.snoc (T.stripEnd $ renderLine 0 line') '\n'
230
231
232 lineLength :: Int -> Line -> Int
233 lineLength startColumn line' =
234 startColumn +
235 case line' of
236 Text string -> T.length string
237 Space -> 1
238 Tab -> tabLength startColumn
239 Row lines' -> rowLength startColumn lines'
240
241
242 initRow :: Int -> (T.Text, Int)
243 initRow startColumn =
244 (T.empty, startColumn)
245
246
247 spacesInTab :: Int
248 spacesInTab =
249 4
250
251
252 spacesToNextTab :: Int -> Int
253 spacesToNextTab startColumn =
254 startColumn `mod` spacesInTab
255
256 tabLength :: Int -> Int
257 tabLength startColumn =
258 spacesInTab - (spacesToNextTab startColumn)
259
260 {-
261 What happens here is we take a row and start building its contents
262 along with the resulting length of the string. We need to have that
263 because of Tabs, which need to be passed the current column in arguments
264 in order to determine how many Spaces are they going to span.
265 (See `tabLength`.)
266
267 So for example if we have a Box [Space, Tab, Text "abc", Tab, Text "x"],
268 it goes like this:
269
270 string | column | todo
271 "" | 0 | [Space, Tab, Text "abc", Tab, Text "x"]
272 " " | 1 | [Tab, Text "abc", Tab, Text "x"]
273 " " | 4 | [Text "abc", Tab, Text "x"]
274 " abc" | 7 | [Tab, Text "x"]
275 " abc " | 8 | [Text "x"]
276 " abc x" | 9 | []
277
278 Thus we get the result string with correctly rendered Tabs.
279
280 The (T.Text, Int) type here means the (string, column) from the table above.
281
282 Then we just need to do one final modification to get from endColumn to resultLength,
283 which is what we are after in the function `rowLength`.
284 -}
285 renderRow' :: Int -> [Line] -> (T.Text, Int)
286 renderRow' startColumn lines' =
287 (result, resultLength)
288 where
289 (result, endColumn) = foldl addLine (initRow startColumn) lines'
290 resultLength = endColumn - startColumn
291
292 {-
293 A step function for renderRow'.
294
295 addLine (" ",1) Tab == (" ",4)
296 -}
297 addLine :: (T.Text, Int) -> Line -> (T.Text, Int)
298 addLine (string, startColumn') line' =
299 (newString, newStartColumn)
300 where
301 newString = T.append string $ renderLine startColumn' line'
302 newStartColumn = lineLength startColumn' line'
303
304 -- Extract the final string from renderRow'
305 renderRow :: Int -> [Line] -> T.Text
306 renderRow startColumn lines' =
307 fst $ renderRow' startColumn lines'
308
309 -- Extract the final length from renderRow'
310 rowLength :: Int -> [Line] -> Int
311 rowLength startColumn lines' =
312 snd $ renderRow' startColumn lines'