git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Reporting/Doc.hs
437 lines 9.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Doc
4 ( P.Doc
5 , (P.<+>), (<>)
6 , P.align, P.cat, P.empty, P.fill, P.fillSep, P.hang
7 , P.hcat, P.hsep, P.indent, P.sep, P.vcat
8 , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow
9 , P.dullred, P.dullcyan, P.dullyellow
10 --
11 , fromChars
12 , fromName
13 , fromVersion
14 , fromPackage
15 , fromInt
16 --
17 , toAnsi
18 , toString
19 , toLine
20 --
21 , encode
22 --
23 , stack
24 , reflow
25 , commaSep
26 --
27 , toSimpleNote
28 , toFancyNote
29 , toSimpleHint
30 , toFancyHint
31 --
32 , link
33 , fancyLink
34 , reflowLink
35 , makeLink
36 , makeNakedLink
37 --
38 , args
39 , moreArgs
40 , ordinal
41 , intToOrdinal
42 , cycle
43 )
44 where
47import Prelude hiding (cycle)
48import qualified Data.List as List
49import Data.Monoid ((<>))
50import qualified Data.Name as Name
51import qualified System.Console.ANSI.Types as Ansi
52import qualified System.Info as Info
53import System.IO (Handle)
54import qualified Text.PrettyPrint.ANSI.Leijen as P
56import qualified Data.Index as Index
57import qualified Elm.Package as Pkg
58import qualified Elm.Version as V
59import qualified Json.Encode as E
60import qualified Json.String as Json
64-- FROM
67fromChars :: String -> P.Doc
68fromChars =
69 P.text
72fromName :: Name.Name -> P.Doc
73fromName name =
74 P.text (Name.toChars name)
77fromVersion :: V.Version -> P.Doc
78fromVersion vsn =
79 P.text (V.toChars vsn)
82fromPackage :: Pkg.Name -> P.Doc
83fromPackage pkg =
84 P.text (Pkg.toChars pkg)
87fromInt :: Int -> P.Doc
88fromInt n =
89 P.text (show n)
93-- TO STRING
96toAnsi :: Handle -> P.Doc -> IO ()
97toAnsi handle doc =
98 P.displayIO handle (P.renderPretty 1 80 doc)
101toString :: P.Doc -> String
102toString doc =
103 P.displayS (P.renderPretty 1 80 (P.plain doc)) ""
106toLine :: P.Doc -> String
107toLine doc =
108 P.displayS (P.renderPretty 1 (div maxBound 2) (P.plain doc)) ""
112-- FORMATTING
115stack :: [P.Doc] -> P.Doc
116stack docs =
117 P.vcat (List.intersperse "" docs)
120reflow :: String -> P.Doc
121reflow paragraph =
122 P.fillSep (map P.text (words paragraph))
125commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc]
126commaSep conjunction addStyle names =
127 case names of
128 [name] ->
129 [ addStyle name ]
131 [name1,name2] ->
132 [ addStyle name1, conjunction, addStyle name2 ]
134 _ ->
135 map (\name -> addStyle name <> ",") (init names)
136 ++
137 [ conjunction
138 , addStyle (last names)
139 ]
143-- NOTES
146toSimpleNote :: String -> P.Doc
147toSimpleNote message =
148 toFancyNote (map P.text (words message))
151toFancyNote :: [P.Doc] -> P.Doc
152toFancyNote chunks =
153 P.fillSep (P.underline "Note" <> ":" : chunks)
157-- HINTS
160toSimpleHint :: String -> P.Doc
161toSimpleHint message =
162 toFancyHint (map P.text (words message))
165toFancyHint :: [P.Doc] -> P.Doc
166toFancyHint chunks =
167 P.fillSep (P.underline "Hint" <> ":" : chunks)
171-- LINKS
174link :: String -> String -> String -> String -> P.Doc
175link word before fileName after =
176 P.fillSep $
177 (P.underline (P.text word) <> ":")
178 : map P.text (words before)
179 ++ P.text (makeLink fileName)
180 : map P.text (words after)
183fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
184fancyLink word before fileName after =
185 P.fillSep $
186 (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after
189makeLink :: [Char] -> [Char]
190makeLink fileName =
191 "<https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName <> ">"
194makeNakedLink :: [Char] -> [Char]
195makeNakedLink fileName =
196 "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName
199reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
200reflowLink before fileName after =
201 P.fillSep $
202 map P.text (words before)
203 ++ P.text (makeLink fileName)
204 : map P.text (words after)
208-- HELPERS
211args :: Int -> String
212args n =
213 show n <> if n == 1 then " argument" else " arguments"
216moreArgs :: Int -> String
217moreArgs n =
218 show n <> " more" <> if n == 1 then " argument" else " arguments"
221ordinal :: Index.ZeroBased -> String
222ordinal index =
223 intToOrdinal (Index.toHuman index)
226intToOrdinal :: Int -> String
227intToOrdinal number =
228 let
229 remainder10 =
230 number `mod` 10
232 remainder100 =
233 number `mod` 100
235 ending
236 | remainder100 `elem` [11..13] = "th"
237 | remainder10 == 1 = "st"
238 | remainder10 == 2 = "nd"
239 | remainder10 == 3 = "rd"
240 | otherwise = "th"
241 in
242 show number <> ending
246cycle :: Int -> Name.Name -> [Name.Name] -> P.Doc
247cycle indent name names =
248 let
249 toLn n = cycleLn <> P.dullyellow (fromName n)
250 in
251 P.indent indent $ P.vcat $
252 cycleTop : List.intersperse cycleMid (toLn name : map toLn names) ++ [ cycleEnd ]
255cycleTop, cycleLn, cycleMid, cycleEnd :: P.Doc
256cycleTop = if isWindows then "+-----+" else "┌─────┐"
257cycleLn = if isWindows then "| " else "│ "
258cycleMid = if isWindows then "| |" else "│ ↓"
259cycleEnd = if isWindows then "+-<---+" else "└─────┘"
262isWindows :: Bool
263isWindows =
264 Info.os == "mingw32"
268-- JSON
271encode :: P.Doc -> E.Value
272encode doc =
273 E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc))
276data Style =
277 Style
278 { _bold :: Bool
279 , _underline :: Bool
280 , _color :: Maybe Color
281 }
284noStyle :: Style
285noStyle =
286 Style False False Nothing
289data Color
290 = Red
291 | RED
292 | Magenta
293 | MAGENTA
294 | Yellow
295 | YELLOW
296 | Green
297 | GREEN
298 | Cyan
299 | CYAN
300 | Blue
301 | BLUE
302 | Black
303 | BLACK
304 | White
305 | WHITE
308toJsonHelp :: Style -> [a] -> P.SimpleDoc -> [E.Value]
309toJsonHelp style revChunks simpleDoc =
310 error "TODO generate json on errors" style revChunks simpleDoc sgrToStyle encodeColor
311{-
312 case simpleDoc of
313 P.SFail ->
314 error $
315 "according to the main implementation, @SFail@ can not\
316 \ appear uncaught in a rendered @SimpleDoc@"
318 P.SEmpty ->
319 [ encodeChunks style revChunks ]
321 P.SChar char rest ->
322 toJsonHelp style (TB.singleton char : revChunks) rest
324 P.SText _ string rest ->
325 toJsonHelp style (TB.fromString string : revChunks) rest
327 P.SLine indent rest ->
328 toJsonHelp style (spaces indent : "\n" : revChunks) rest
330 P.SSGR sgrs rest ->
331 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
334spaces :: Int -> TB.Builder
335spaces n =
336 TB.fromText (Text.replicate n " ")
337-}
339sgrToStyle :: [Ansi.SGR] -> Style -> Style
340sgrToStyle sgrs style@(Style bold underline color) =
341 case sgrs of
342 [] ->
343 style
345 sgr : rest ->
346 sgrToStyle rest $
347 case sgr of
348 Ansi.Reset -> noStyle
349 Ansi.SetConsoleIntensity i -> Style (isBold i) underline color
350 Ansi.SetItalicized _ -> style
351 Ansi.SetUnderlining u -> Style bold (isUnderline u) color
352 Ansi.SetBlinkSpeed _ -> style
353 Ansi.SetVisible _ -> style
354 Ansi.SetSwapForegroundBackground _ -> style
355 Ansi.SetColor l i c -> Style bold underline (toColor l i c)
356 Ansi.SetRGBColor _ _ -> style
359isBold :: Ansi.ConsoleIntensity -> Bool
360isBold intensity =
361 case intensity of
362 Ansi.BoldIntensity -> True
363 Ansi.FaintIntensity -> False
364 Ansi.NormalIntensity -> False
367isUnderline :: Ansi.Underlining -> Bool
368isUnderline underlining =
369 case underlining of
370 Ansi.SingleUnderline -> True
371 Ansi.DoubleUnderline -> False
372 Ansi.NoUnderline -> False
375toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color
376toColor layer intensity color =
377 case layer of
378 Ansi.Background ->
379 Nothing
381 Ansi.Foreground ->
382 let
383 pick dull vivid =
384 case intensity of
385 Ansi.Dull -> dull
386 Ansi.Vivid -> vivid
387 in
388 Just $
389 case color of
390 Ansi.Red -> pick Red RED
391 Ansi.Magenta -> pick Magenta MAGENTA
392 Ansi.Yellow -> pick Yellow YELLOW
393 Ansi.Green -> pick Green GREEN
394 Ansi.Cyan -> pick Cyan CYAN
395 Ansi.Blue -> pick Blue BLUE
396 Ansi.White -> pick White WHITE
397 Ansi.Black -> pick Black BLACK
399{-
400encodeChunks :: Style -> [TB.Builder] -> E.Value
401encodeChunks (Style bold underline color) revChunks =
402 let
403 !str = Utf8.concat (reverse revChunks)
404 in
405 case color of
406 Nothing | not bold && not underline ->
407 E.string str
409 _ ->
410 E.object
411 [ ("bold", E.bool bold)
412 , ("underline", E.bool underline)
413 , ("color", maybe E.null encodeColor color)
414 , ("string", E.string str)
415 ]
416-}
418encodeColor :: Color -> E.Value
419encodeColor color =
420 E.string $ Json.fromChars $
421 case color of
422 Red -> "red"
423 RED -> "RED"
424 Magenta -> "magenta"
425 MAGENTA -> "MAGENTA"
426 Yellow -> "yellow"
427 YELLOW -> "YELLOW"
428 Green -> "green"
429 GREEN -> "GREEN"
430 Cyan -> "cyan"
431 CYAN -> "CYAN"
432 Blue -> "blue"
433 BLUE -> "BLUE"
434 Black -> "black"
435 BLACK -> "BLACK"
436 White -> "white"
437 WHITE -> "WHITE"