git.iko.soy/elk
on master help sign in
Implement conversion from Doc to JSON

This should make it easier to show error messages in a pretty way in browsers because we can skip the ANSI stuff.

commit31e51c18073be14334134697642d7476864e96bc authorEvan Czaplicki <evancz@users.noreply.github.com> dateSat 7 Apr 2018, 19:55 (9 years ago) parent91e7d6b
3 files changed+465−250
compare with master
unifiedsplit
compiler/src/Reporting/Doc.hs+379 compiler/src/Reporting/Helpers.hs−250 compiler/src/Reporting/Suggest.hs+86
compiler/src/Reporting/Doc.hsnew file+379
@@ -0,0 +1,379 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Doc
4+ ( P.Doc
5+ , (P.<+>), (<>)
6+ , P.cat, P.empty, P.fillSep, P.hang, P.hcat, P.hsep, P.indent, P.sep, P.vcat
7+ , P.black, P.blue, P.green, P.magenta, P.dullyellow, P.red, P.dullred
8+
9+ , fromString, fromText, fromName
10+ , toAnsi, toString, toLine
11+ , encode
12+
13+ , stack, reflow, commaSep
14+ , toSimpleNote, toSimpleHint, toFancyHint
15+ , link, fancyLink, reflowLink, makeLink
16+ , args, moreArgs, ordinalize
17+ , cycle
18+ )
19+ where
20+
21+
22+import Prelude hiding (cycle)
23+import qualified Data.List as List
24+import Data.Monoid ((<>))
25+import qualified Data.Text as Text
26+import qualified Data.Text.Lazy as TL
27+import qualified Data.Text.Lazy.Builder as TB
28+import qualified Elm.Name as N
29+import qualified System.Console.ANSI.Types as Ansi
30+import System.IO (Handle)
31+import qualified Text.PrettyPrint.ANSI.Leijen as P
32+
33+import qualified Elm.Compiler.Version as Compiler
34+import qualified Elm.Package as Pkg
35+import qualified Json.Encode as E
36+
37+
38+
39+-- FROM
40+
41+
42+fromString :: String -> P.Doc
43+fromString =
44+ P.text
45+
46+
47+fromText :: Text.Text -> P.Doc
48+fromText txt =
49+ P.text (Text.unpack txt)
50+
51+
52+fromName :: N.Name -> P.Doc
53+fromName name =
54+ P.text (N.toString name)
55+
56+
57+
58+-- TO STRING
59+
60+
61+toAnsi :: Handle -> P.Doc -> IO ()
62+toAnsi handle doc =
63+ P.displayIO handle (P.renderPretty 1 80 doc)
64+
65+
66+toString :: P.Doc -> String
67+toString doc =
68+ P.displayS (P.renderPretty 1 80 doc) ""
69+
70+
71+toLine :: P.Doc -> String
72+toLine doc =
73+ P.displayS (P.renderPretty 1 (div maxBound 2) doc) ""
74+
75+
76+
77+-- FORMATTING
78+
79+
80+stack :: [P.Doc] -> P.Doc
81+stack docs =
82+ P.vcat (List.intersperse "" docs)
83+
84+
85+reflow :: String -> P.Doc
86+reflow paragraph =
87+ P.fillSep (map P.text (words paragraph))
88+
89+
90+commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc]
91+commaSep conjunction addStyle names =
92+ case names of
93+ [name] ->
94+ [ addStyle name ]
95+
96+ [name1,name2] ->
97+ [ addStyle name1, conjunction, addStyle name2 ]
98+
99+ _ ->
100+ map (\name -> addStyle name <> ",") (init names)
101+ ++
102+ [ conjunction
103+ , addStyle (last names)
104+ ]
105+
106+
107+
108+-- HINTS
109+
110+
111+toSimpleNote :: String -> P.Doc
112+toSimpleNote message =
113+ P.fillSep ((P.underline "Note" <> ":") : map P.text (words message))
114+
115+
116+toSimpleHint :: String -> P.Doc
117+toSimpleHint message =
118+ toFancyHint (map P.text (words message))
119+
120+
121+toFancyHint :: [P.Doc] -> P.Doc
122+toFancyHint chunks =
123+ P.fillSep (P.underline "Hint" <> ":" : chunks)
124+
125+
126+
127+-- LINKS
128+
129+
130+link :: P.Doc -> String -> String -> String -> P.Doc
131+link word before fileName after =
132+ P.fillSep $
133+ (P.underline word <> ":")
134+ : map P.text (words before)
135+ ++ P.text (makeLink fileName)
136+ : map P.text (words after)
137+
138+
139+fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc
140+fancyLink word before fileName after =
141+ P.fillSep $
142+ (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after
143+
144+
145+makeLink :: String -> String
146+makeLink fileName =
147+ "<https://elm-lang.org/hints/" <> Pkg.versionToString Compiler.version <> "/" <> fileName <> ">"
148+
149+
150+reflowLink :: String -> String -> String -> P.Doc
151+reflowLink before fileName after =
152+ P.fillSep $
153+ map P.text (words before)
154+ ++ P.text (makeLink fileName)
155+ : map P.text (words after)
156+
157+
158+
159+-- HELPERS
160+
161+
162+args :: Int -> String
163+args n =
164+ show n <> if n == 1 then " argument" else " arguments"
165+
166+
167+moreArgs :: Int -> String
168+moreArgs n =
169+ show n <> " more" <> if n == 1 then " argument" else " arguments"
170+
171+
172+ordinalize :: Int -> String
173+ordinalize number =
174+ let
175+ remainder10 =
176+ number `mod` 10
177+
178+ remainder100 =
179+ number `mod` 100
180+
181+ ending
182+ | remainder100 `elem` [11..13] = "th"
183+ | remainder10 == 1 = "st"
184+ | remainder10 == 2 = "nd"
185+ | remainder10 == 3 = "rd"
186+ | otherwise = "th"
187+ in
188+ show number <> ending
189+
190+
191+
192+cycle :: Int -> [N.Name] -> P.Doc
193+cycle indent names =
194+ let
195+ topLine = "┌─────┐"
196+ nameLine name = "│ " <> P.dullyellow (fromName name)
197+ midLine = "│ ↓"
198+ bottomLine = "└─────┘"
199+ in
200+ P.indent indent $ P.vcat $
201+ topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ]
202+
203+
204+
205+-- JSON
206+
207+
208+encode :: P.Doc -> E.Value
209+encode doc =
210+ E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc))
211+
212+
213+data Style =
214+ Style
215+ { _bold :: Bool
216+ , _underline :: Bool
217+ , _color :: Maybe Color
218+ }
219+
220+
221+noStyle :: Style
222+noStyle =
223+ Style False False Nothing
224+
225+
226+data Color
227+ = D_Red
228+ | V_Red
229+ | D_Magenta
230+ | V_Magenta
231+ | D_Yellow
232+ | V_Yellow
233+ | D_Green
234+ | V_Green
235+ | D_Cyan
236+ | V_Cyan
237+ | D_Blue
238+ | V_Blue
239+ | D_Black
240+ | V_Black
241+ | D_White
242+ | V_White
243+
244+
245+toJsonHelp :: Style -> [TB.Builder] -> P.SimpleDoc -> [E.Value]
246+toJsonHelp style revChunks simpleDoc =
247+ case simpleDoc of
248+ P.SFail ->
249+ error $
250+ "according to the main implementation, @SFail@ can not\
251+ \ appear uncaught in a rendered @SimpleDoc@"
252+
253+ P.SEmpty ->
254+ [ encodeChunks style revChunks ]
255+
256+ P.SChar char rest ->
257+ toJsonHelp style (TB.singleton char : revChunks) rest
258+
259+ P.SText _ string rest ->
260+ toJsonHelp style (TB.fromString string : revChunks) rest
261+
262+ P.SLine indent rest ->
263+ toJsonHelp style (spaces indent : "\n" : revChunks) rest
264+
265+ P.SSGR sgrs rest ->
266+ encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
267+
268+
269+spaces :: Int -> TB.Builder
270+spaces n =
271+ TB.fromText (Text.replicate n " ")
272+
273+
274+sgrToStyle :: [Ansi.SGR] -> Style -> Style
275+sgrToStyle sgrs style@(Style bold underline color) =
276+ case sgrs of
277+ [] ->
278+ style
279+
280+ sgr : rest ->
281+ sgrToStyle rest $
282+ case sgr of
283+ Ansi.Reset -> noStyle
284+ Ansi.SetConsoleIntensity i -> Style (isBold i) underline color
285+ Ansi.SetItalicized _ -> style
286+ Ansi.SetUnderlining u -> Style bold (isUnderline u) color
287+ Ansi.SetBlinkSpeed _ -> style
288+ Ansi.SetVisible _ -> style
289+ Ansi.SetSwapForegroundBackground _ -> style
290+ Ansi.SetColor l i c -> Style bold underline (toColor l i c)
291+ Ansi.SetRGBColor _ _ -> style
292+
293+
294+isBold :: Ansi.ConsoleIntensity -> Bool
295+isBold intensity =
296+ case intensity of
297+ Ansi.BoldIntensity -> True
298+ Ansi.FaintIntensity -> False
299+ Ansi.NormalIntensity -> False
300+
301+
302+isUnderline :: Ansi.Underlining -> Bool
303+isUnderline underlining =
304+ case underlining of
305+ Ansi.SingleUnderline -> True
306+ Ansi.DoubleUnderline -> False
307+ Ansi.NoUnderline -> False
308+
309+
310+toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color
311+toColor layer intensity color =
312+ case layer of
313+ Ansi.Background ->
314+ Nothing
315+
316+ Ansi.Foreground ->
317+ let
318+ pick dull vivid =
319+ case intensity of
320+ Ansi.Dull -> dull
321+ Ansi.Vivid -> vivid
322+ in
323+ Just $
324+ case color of
325+ Ansi.Red -> pick D_Red V_Red
326+ Ansi.Magenta -> pick D_Magenta V_Magenta
327+ Ansi.Yellow -> pick D_Yellow V_Yellow
328+ Ansi.Green -> pick D_Green V_Green
329+ Ansi.Cyan -> pick D_Cyan V_Cyan
330+ Ansi.Blue -> pick D_Blue V_Blue
331+ Ansi.White -> pick D_White V_White
332+ Ansi.Black -> pick D_Black V_Black
333+
334+
335+encodeChunks :: Style -> [TB.Builder] -> E.Value
336+encodeChunks (Style bold underline color) revChunks =
337+ let
338+ text =
339+ case revChunks of
340+ [] ->
341+ Text.empty
342+
343+ c:cs ->
344+ TL.toStrict $ TB.toLazyText $
345+ List.foldl' (\builder chunk -> chunk <> builder) c cs
346+ in
347+ case color of
348+ Nothing | not bold && not underline ->
349+ E.text text
350+
351+ _ ->
352+ E.object
353+ [ ("bold", E.bool bold)
354+ , ("underline", E.bool underline)
355+ , ("color", maybe E.null encodeColor color)
356+ , ("string", E.text text)
357+ ]
358+
359+
360+encodeColor :: Color -> E.Value
361+encodeColor color =
362+ E.text $
363+ case color of
364+ D_Red -> "red"
365+ V_Red -> "RED"
366+ D_Magenta -> "magenta"
367+ V_Magenta -> "MAGENTA"
368+ D_Yellow -> "yellow"
369+ V_Yellow -> "YELLOW"
370+ D_Green -> "green"
371+ V_Green -> "GREEN"
372+ D_Cyan -> "cyan"
373+ V_Cyan -> "CYAN"
374+ D_Blue -> "blue"
375+ V_Blue -> "BLUE"
376+ D_Black -> "black"
377+ V_Black -> "BLACK"
378+ D_White -> "white"
379+ V_White -> "WHITE"
compiler/src/Reporting/Helpers.hsdeleted−250
@@ -1,250 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Helpers
4− ( textToDoc
5− , nameToDoc
6− , args, moreArgs
7− , toSimpleNote, toSimpleHint, toFancyHint
8− , link, fancyLink, reflowLink, makeLink
9− , stack, reflow
10− , commaSep, capitalize, ordinalize, drawCycle
11− , findPotentialTypos, findTypoPairs, vetTypos
12− , nearbyNames, distance
13− -- re-exports
14− , Doc, (<+>), (<>), black, blue, cat, dullyellow, fillSep, green, hang
15− , hardline, hcat, hsep, indent, magenta, parens, red, sep, text, underline, vcat
16− )
17− where
18−
19−
20−import Data.Function (on)
21−import qualified Data.Char as Char
22−import qualified Data.List as List
23−import qualified Data.Map as Map
24−import qualified Data.Maybe as Maybe
25−import qualified Data.Set as Set
26−import Data.Monoid ((<>))
27−import qualified Data.Text as Text
28−import Data.Text (Text)
29−import qualified Elm.Name as N
30−import qualified Text.EditDistance as Dist
31−import qualified Text.PrettyPrint.ANSI.Leijen as P
32−import Text.PrettyPrint.ANSI.Leijen hiding ((<>))
33−
34−import qualified Elm.Compiler.Version as Compiler
35−import qualified Elm.Package as Pkg
36−
37−
38−
39−-- DOC HELPERS
40−
41−
42−textToDoc :: Text -> Doc
43−textToDoc msg =
44− text (Text.unpack msg)
45−
46−
47−nameToDoc :: N.Name -> Doc
48−nameToDoc name =
49− text (N.toString name)
50−
51−
52−args :: Int -> String
53−args n =
54− show n <> if n == 1 then " argument" else " arguments"
55−
56−
57−moreArgs :: Int -> String
58−moreArgs n =
59− show n <> " more" <> if n == 1 then " argument" else " arguments"
60−
61−
62−
63−-- HINTS
64−
65−
66−toSimpleNote :: String -> Doc
67−toSimpleNote message =
68− fillSep ((underline "Note" <> ":") : map text (words message))
69−
70−
71−toSimpleHint :: String -> Doc
72−toSimpleHint message =
73− toFancyHint (map text (words message))
74−
75−
76−toFancyHint :: [Doc] -> Doc
77−toFancyHint chunks =
78− fillSep (underline (text "Hint") <> ":" : chunks)
79−
80−
81−link :: Doc -> String -> String -> String -> Doc
82−link word before fileName after =
83− fillSep $
84− (underline word <> ":")
85− : map text (words before)
86− ++ P.text (makeLink fileName)
87− : map text (words after)
88−
89−
90−fancyLink :: Doc -> [Doc] -> String -> [Doc] -> Doc
91−fancyLink word before fileName after =
92− fillSep $
93− (underline word <> ":") : before ++ P.text (makeLink fileName) : after
94−
95−
96−makeLink :: String -> String
97−makeLink fileName =
98− "<https://elm-lang.org/hints/" <> Pkg.versionToString Compiler.version <> "/" <> fileName <> ">"
99−
100−
101−reflowLink :: String -> String -> String -> Doc
102−reflowLink before fileName after =
103− fillSep $
104− map text (words before)
105− ++ P.text (makeLink fileName)
106− : map text (words after)
107−
108−
109−stack :: [Doc] -> Doc
110−stack chunks =
111− case chunks of
112− [] ->
113− error "function `stack` requires a non-empty list of docs"
114−
115− doc : docs ->
116− List.foldl' (\a b -> a <> hardline <> hardline <> b) doc docs
117−
118−
119−reflow :: String -> Doc
120−reflow paragraph =
121− fillSep (map text (words paragraph))
122−
123−
124−commaSep :: Doc -> (Doc -> Doc) -> [Doc] -> [Doc]
125−commaSep conjunction addStyle names =
126− case names of
127− [name] ->
128− [ addStyle name ]
129−
130− [name1,name2] ->
131− [ addStyle name1, conjunction, addStyle name2 ]
132−
133− _ ->
134− map (\name -> addStyle name <> ",") (init names)
135− ++
136− [ conjunction
137− , addStyle (last names)
138− ]
139−
140−
141−capitalize :: Text -> Text
142−capitalize txt =
143− case Text.uncons txt of
144− Nothing ->
145− txt
146−
147− Just (c, rest) ->
148− Text.cons (Char.toUpper c) rest
149−
150−
151−ordinalize :: Int -> String
152−ordinalize number =
153− let
154− remainder10 =
155− number `mod` 10
156−
157− remainder100 =
158− number `mod` 100
159−
160− ending
161− | remainder100 `elem` [11..13] = "th"
162− | remainder10 == 1 = "st"
163− | remainder10 == 2 = "nd"
164− | remainder10 == 3 = "rd"
165− | otherwise = "th"
166− in
167− show number <> ending
168−
169−
170−
171−drawCycle :: [N.Name] -> Doc
172−drawCycle names =
173− let
174− topLine = "┌─────┐"
175− nameLine name = "│ " <> dullyellow (nameToDoc name)
176− midLine = "│ ↓"
177− bottomLine = "└─────┘"
178− in
179− vcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
180−
181−
182−
183−-- FIND TYPOS
184−
185−
186−findPotentialTypos :: [String] -> String -> [String]
187−findPotentialTypos knownNames badName =
188− filter (\name -> distance badName name == 1) knownNames
189−
190−
191−findTypoPairs :: [String] -> [String] -> [(String, String)]
192−findTypoPairs leftOnly rightOnly =
193− let
194− veryNear leftName =
195− map ((,) leftName) (findPotentialTypos rightOnly leftName)
196− in
197− concatMap veryNear leftOnly
198−
199−
200−vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
201−vetTypos potentialTypos =
202− let
203− tallyNames (ln, rn) (lc, rc) =
204− ( Map.insertWith (+) ln 1 lc
205− , Map.insertWith (+) rn 1 rc
206− )
207−
208− (leftCounts, rightCounts) =
209− foldr tallyNames (Map.empty, Map.empty) potentialTypos
210−
211− acceptable :: Map.Map String Int -> Bool
212− acceptable counts =
213− not (Map.null counts)
214− &&
215− Map.foldr (\n unique -> n < 2 && unique) True counts
216− in
217− if acceptable leftCounts && acceptable rightCounts then
218− Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
219−
220− else
221− Nothing
222−
223−
224−
225−-- NEARBY NAMES
226−
227−
228−nearbyNames :: (a -> String) -> a -> [a] -> [a]
229−nearbyNames toString value possibleValues =
230− let
231− name =
232− toString value
233−
234− editDistance =
235− if length name < 3 then 1 else 2
236−
237− getDistance pValue =
238− let
239− dist = abs (distance name (toString pValue))
240− in
241− if dist <= editDistance then Just (dist, pValue) else Nothing
242− in
243− map snd $
244− List.sortBy (compare `on` fst) $
245− Maybe.mapMaybe getDistance possibleValues
246−
247−
248−distance :: String -> String -> Int
249−distance x y =
250− Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y
compiler/src/Reporting/Suggest.hsnew file+86
@@ -0,0 +1,86 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Suggest
4+ ( findPotentialTypos, findTypoPairs, vetTypos
5+ , nearbyNames, distance
6+ )
7+ where
8+
9+
10+import Data.Function (on)
11+import qualified Data.List as List
12+import qualified Data.Map as Map
13+import qualified Data.Maybe as Maybe
14+import qualified Data.Set as Set
15+import qualified Text.EditDistance as Dist
16+
17+
18+
19+-- FIND TYPOS
20+
21+
22+findPotentialTypos :: [String] -> String -> [String]
23+findPotentialTypos knownNames badName =
24+ filter (\name -> distance badName name == 1) knownNames
25+
26+
27+findTypoPairs :: [String] -> [String] -> [(String, String)]
28+findTypoPairs leftOnly rightOnly =
29+ let
30+ veryNear leftName =
31+ map ((,) leftName) (findPotentialTypos rightOnly leftName)
32+ in
33+ concatMap veryNear leftOnly
34+
35+
36+vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
37+vetTypos potentialTypos =
38+ let
39+ tallyNames (ln, rn) (lc, rc) =
40+ ( Map.insertWith (+) ln 1 lc
41+ , Map.insertWith (+) rn 1 rc
42+ )
43+
44+ (leftCounts, rightCounts) =
45+ foldr tallyNames (Map.empty, Map.empty) potentialTypos
46+
47+ acceptable :: Map.Map String Int -> Bool
48+ acceptable counts =
49+ not (Map.null counts)
50+ &&
51+ Map.foldr (\n unique -> n < 2 && unique) True counts
52+ in
53+ if acceptable leftCounts && acceptable rightCounts then
54+ Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
55+
56+ else
57+ Nothing
58+
59+
60+
61+-- NEARBY NAMES
62+
63+
64+nearbyNames :: (a -> String) -> a -> [a] -> [a]
65+nearbyNames toString value possibleValues =
66+ let
67+ name =
68+ toString value
69+
70+ editDistance =
71+ if length name < 3 then 1 else 2
72+
73+ getDistance pValue =
74+ let
75+ dist = abs (distance name (toString pValue))
76+ in
77+ if dist <= editDistance then Just (dist, pValue) else Nothing
78+ in
79+ map snd $
80+ List.sortBy (compare `on` fst) $
81+ Maybe.mapMaybe getDistance possibleValues
82+
83+
84+distance :: String -> String -> Int
85+distance x y =
86+ Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y