git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Reporting/Doc.hs
398 lines 8.7 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
11 , fromString, fromText, fromName, fromInt
12 , toAnsi, toString, toLine
13 , encode
15 , stack, reflow, commaSep
16 , toSimpleNote, toSimpleHint, toFancyHint
17 , link, fancyLink, reflowLink, makeLink, makeNakedLink
18 , args, moreArgs
19 , ordinal, intToOrdinal
20 , cycle
21 )
22 where
25import Prelude hiding (cycle)
26import qualified Data.List as List
27import Data.Monoid ((<>))
28import qualified Data.Text as Text
29import qualified Data.Text.Lazy as TL
30import qualified Data.Text.Lazy.Builder as TB
31import qualified Elm.Name as N
32import qualified System.Console.ANSI.Types as Ansi
33import System.IO (Handle)
34import qualified Text.PrettyPrint.ANSI.Leijen as P
36import qualified Data.Index as Index
37import qualified Elm.Compiler.Version as Compiler
38import qualified Elm.Package as Pkg
39import qualified Json.Encode as E
43-- FROM
46fromString :: String -> P.Doc
47fromString =
48 P.text
51fromText :: Text.Text -> P.Doc
52fromText txt =
53 P.text (Text.unpack txt)
56fromName :: N.Name -> P.Doc
57fromName name =
58 P.text (N.toString name)
61fromInt :: Int -> P.Doc
62fromInt n =
63 P.text (show n)
67-- TO STRING
70toAnsi :: Handle -> P.Doc -> IO ()
71toAnsi handle doc =
72 P.displayIO handle (P.renderPretty 1 80 doc)
75toString :: P.Doc -> String
76toString doc =
77 P.displayS (P.renderPretty 1 80 (P.plain doc)) ""
80toLine :: P.Doc -> String
81toLine doc =
82 P.displayS (P.renderPretty 1 (div maxBound 2) (P.plain doc)) ""
86-- FORMATTING
89stack :: [P.Doc] -> P.Doc
90stack docs =
91 P.vcat (List.intersperse "" docs)
94reflow :: String -> P.Doc
95reflow paragraph =
96 P.fillSep (map P.text (words paragraph))
99commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc]
100commaSep conjunction addStyle names =
101 case names of
102 [name] ->
103 [ addStyle name ]
105 [name1,name2] ->
106 [ addStyle name1, conjunction, addStyle name2 ]
108 _ ->
109 map (\name -> addStyle name <> ",") (init names)
110 ++
111 [ conjunction
112 , addStyle (last names)
113 ]
117-- HINTS
120toSimpleNote :: String -> P.Doc
121toSimpleNote message =
122 P.fillSep ((P.underline "Note" <> ":") : map P.text (words message))
125toSimpleHint :: String -> P.Doc
126toSimpleHint message =
127 toFancyHint (map P.text (words message))
130toFancyHint :: [P.Doc] -> P.Doc
131toFancyHint chunks =
132 P.fillSep (P.underline "Hint" <> ":" : chunks)
136-- LINKS
139link :: P.Doc -> String -> String -> String -> P.Doc
140link word before fileName after =
141 P.fillSep $
142 (P.underline word <> ":")
143 : map P.text (words before)
144 ++ P.text (makeLink fileName)
145 : map P.text (words after)
148fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc
149fancyLink word before fileName after =
150 P.fillSep $
151 (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after
154makeLink :: String -> String
155makeLink fileName =
156 "<https://elm-lang.org/" <> Pkg.versionToString Compiler.version <> "/" <> fileName <> ">"
159makeNakedLink :: String -> String
160makeNakedLink fileName =
161 "https://elm-lang.org/" <> Pkg.versionToString Compiler.version <> "/" <> fileName
164reflowLink :: String -> String -> String -> P.Doc
165reflowLink before fileName after =
166 P.fillSep $
167 map P.text (words before)
168 ++ P.text (makeLink fileName)
169 : map P.text (words after)
173-- HELPERS
176args :: Int -> String
177args n =
178 show n <> if n == 1 then " argument" else " arguments"
181moreArgs :: Int -> String
182moreArgs n =
183 show n <> " more" <> if n == 1 then " argument" else " arguments"
186ordinal :: Index.ZeroBased -> String
187ordinal index =
188 intToOrdinal (Index.toHuman index)
191intToOrdinal :: Int -> String
192intToOrdinal number =
193 let
194 remainder10 =
195 number `mod` 10
197 remainder100 =
198 number `mod` 100
200 ending
201 | remainder100 `elem` [11..13] = "th"
202 | remainder10 == 1 = "st"
203 | remainder10 == 2 = "nd"
204 | remainder10 == 3 = "rd"
205 | otherwise = "th"
206 in
207 show number <> ending
211cycle :: Int -> [N.Name] -> P.Doc
212cycle indent names =
213 let
214 topLine = "┌─────┐"
215 nameLine name = "│ " <> P.dullyellow (fromName name)
216 midLine = "│ ↓"
217 bottomLine = "└─────┘"
218 in
219 P.indent indent $ P.vcat $
220 topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ]
224-- JSON
227encode :: P.Doc -> E.Value
228encode doc =
229 E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc))
232data Style =
233 Style
234 { _bold :: Bool
235 , _underline :: Bool
236 , _color :: Maybe Color
237 }
240noStyle :: Style
241noStyle =
242 Style False False Nothing
245data Color
246 = Red
247 | RED
248 | Magenta
249 | MAGENTA
250 | Yellow
251 | YELLOW
252 | Green
253 | GREEN
254 | Cyan
255 | CYAN
256 | Blue
257 | BLUE
258 | Black
259 | BLACK
260 | White
261 | WHITE
264toJsonHelp :: Style -> [TB.Builder] -> P.SimpleDoc -> [E.Value]
265toJsonHelp style revChunks simpleDoc =
266 case simpleDoc of
267 P.SFail ->
268 error $
269 "according to the main implementation, @SFail@ can not\
270 \ appear uncaught in a rendered @SimpleDoc@"
272 P.SEmpty ->
273 [ encodeChunks style revChunks ]
275 P.SChar char rest ->
276 toJsonHelp style (TB.singleton char : revChunks) rest
278 P.SText _ string rest ->
279 toJsonHelp style (TB.fromString string : revChunks) rest
281 P.SLine indent rest ->
282 toJsonHelp style (spaces indent : "\n" : revChunks) rest
284 P.SSGR sgrs rest ->
285 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
288spaces :: Int -> TB.Builder
289spaces n =
290 TB.fromText (Text.replicate n " ")
293sgrToStyle :: [Ansi.SGR] -> Style -> Style
294sgrToStyle sgrs style@(Style bold underline color) =
295 case sgrs of
296 [] ->
297 style
299 sgr : rest ->
300 sgrToStyle rest $
301 case sgr of
302 Ansi.Reset -> noStyle
303 Ansi.SetConsoleIntensity i -> Style (isBold i) underline color
304 Ansi.SetItalicized _ -> style
305 Ansi.SetUnderlining u -> Style bold (isUnderline u) color
306 Ansi.SetBlinkSpeed _ -> style
307 Ansi.SetVisible _ -> style
308 Ansi.SetSwapForegroundBackground _ -> style
309 Ansi.SetColor l i c -> Style bold underline (toColor l i c)
310 Ansi.SetRGBColor _ _ -> style
313isBold :: Ansi.ConsoleIntensity -> Bool
314isBold intensity =
315 case intensity of
316 Ansi.BoldIntensity -> True
317 Ansi.FaintIntensity -> False
318 Ansi.NormalIntensity -> False
321isUnderline :: Ansi.Underlining -> Bool
322isUnderline underlining =
323 case underlining of
324 Ansi.SingleUnderline -> True
325 Ansi.DoubleUnderline -> False
326 Ansi.NoUnderline -> False
329toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color
330toColor layer intensity color =
331 case layer of
332 Ansi.Background ->
333 Nothing
335 Ansi.Foreground ->
336 let
337 pick dull vivid =
338 case intensity of
339 Ansi.Dull -> dull
340 Ansi.Vivid -> vivid
341 in
342 Just $
343 case color of
344 Ansi.Red -> pick Red RED
345 Ansi.Magenta -> pick Magenta MAGENTA
346 Ansi.Yellow -> pick Yellow YELLOW
347 Ansi.Green -> pick Green GREEN
348 Ansi.Cyan -> pick Cyan CYAN
349 Ansi.Blue -> pick Blue BLUE
350 Ansi.White -> pick White WHITE
351 Ansi.Black -> pick Black BLACK
354encodeChunks :: Style -> [TB.Builder] -> E.Value
355encodeChunks (Style bold underline color) revChunks =
356 let
357 text =
358 case revChunks of
359 [] ->
360 Text.empty
362 c:cs ->
363 TL.toStrict $ TB.toLazyText $
364 List.foldl' (\builder chunk -> chunk <> builder) c cs
365 in
366 case color of
367 Nothing | not bold && not underline ->
368 E.text text
370 _ ->
371 E.object
372 [ ("bold", E.bool bold)
373 , ("underline", E.bool underline)
374 , ("color", maybe E.null encodeColor color)
375 , ("string", E.text text)
376 ]
379encodeColor :: Color -> E.Value
380encodeColor color =
381 E.text $
382 case color of
383 Red -> "red"
384 RED -> "RED"
385 Magenta -> "magenta"
386 MAGENTA -> "MAGENTA"
387 Yellow -> "yellow"
388 YELLOW -> "YELLOW"
389 Green -> "green"
390 GREEN -> "GREEN"
391 Cyan -> "cyan"
392 CYAN -> "CYAN"
393 Blue -> "blue"
394 BLUE -> "BLUE"
395 Black -> "black"
396 BLACK -> "BLACK"
397 White -> "white"
398 WHITE -> "WHITE"