@@ -2,12 +2,13 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Reporting.Error.Json
44 ( toReport
5+ , FailureToReport(..)
56 )
67 where
78
89
9−import qualified Data.Char as Char
10−import qualified Data.Map as Map
10+import qualified Data.ByteString as BS
11+import qualified Data.ByteString.UTF8 as BS_UTF8
1112
1213import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..))
1314import qualified Reporting.Annotation as A
@@ -20,11 +21,11 @@ import qualified Reporting.Render.Code as Code
2021-- TO REPORT
2122
2223
23−toReport :: FilePath -> Error x -> Help.Report
24−toReport path err =
24+toReport :: FilePath -> FailureToReport x -> Error x -> Help.Report
25+toReport path ftr err =
2526 case err of
2627 DecodeProblem bytes problem ->
27− problemToReport (Code.toSource bytes) problem
28+ problemToReport path ftr (Code.toSource bytes) CRoot problem
2829
2930 ParseProblem bytes parseError ->
3031 parseErrorToReport path (Code.toSource bytes) parseError
@@ -215,230 +216,106 @@ objectNote =
215216-- PROBLEM TO REPORT
216217
217218
218−problemToReport :: Code.Source -> Problem x -> Help.Report
219−problemToReport source problem =
220− error "TODO problemToReport" source problem
221−
222−{-
223− BadContent jsonError ->
224− case flatten jsonError of
225− [] ->
226− D.reflow
227− "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\
228− \ and share it at <https://github.com/elm/compiler/issues> so I can\
229− \ provide a helpful hint here!"
230−
231− [flatError] ->
232− flatErrorToDoc rootName [] userErrorToDocs flatError
233−
234− flatErrors ->
235− let
236− toNumberedDoc index flatErr =
237− D.dullcyan ("(" <> D.fromInt index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr
238− in
239− D.stack $
240− [ D.reflow $
241− "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
242− ]
243− ++ zipWith toNumberedDoc [1..] flatErrors
244−
245−
246−
247−-- FLAT ERROR TO DOC
248−
219+data Context
220+ = CRoot
221+ | CField BS.ByteString Context
222+ | CIndex Int Context
249223
250−flatErrorToDoc :: String -> [D.Doc] -> (e -> [D.Doc]) -> FlatError e -> D.Doc
251−flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
252− case theories of
253− [] ->
254− let
255− explanation =
256− case theory of
257− Failure userError ->
258− userErrorToDocs userError
259224
260− Expecting tipe ->
261− ["I","was","expecting"] ++ anExpectedThing tipe
262− in
263− case accesses of
264− [] ->
265− D.fillSep (starter ++ explanation)
225+problemToReport :: FilePath -> FailureToReport x -> Code.Source -> Context -> Problem x -> Help.Report
226+problemToReport path ftr source context problem =
227+ case problem of
228+ Field field prob ->
229+ problemToReport path ftr source (CField field context) prob
266230
267− _ ->
268− D.stack
269− [ D.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
270− , D.fillSep explanation
271− ]
231+ Index index prob ->
232+ problemToReport path ftr source (CIndex index context) prob
272233
273− _:_ ->
234+ OneOf p ps ->
235+ -- NOTE: only displays the deepest problem. This works well for the kind
236+ -- of JSON used by Elm, but probably would not work well in general.
274237 let
275− introduction =
276− case accesses of
277− [] ->
278− ["I","am","having","trouble","with","the"]
279− ++ actualThing json
280− ++ ["here","because:"]
281−
282− _ ->
283− ["I","am","having","trouble","with","the"]
284− ++ actualThing json
285− ++ ["at",accessToDoc rootName accesses,"because:"]
238+ (NE.List prob _) = NE.sortBy (negate . getMaxDepth) (NE.List p ps)
286239 in
287− D.stack
288− [ D.fillSep (starter ++ introduction)
289− , D.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
290− , D.reflow "I accept any of these things."
291− ]
292−
240+ problemToReport path ftr source context prob
293241
294−accessToDoc :: String -> [String] -> D.Doc
295−accessToDoc rootName accesses =
296− D.dullyellow (D.fromString (rootName ++ concat accesses))
242+ Failure region x ->
243+ _failureToReport ftr path source context region x
297244
245+ Expecting region expectation ->
246+ expectationToReport path source context region expectation
298247
299−actualThing :: E.Value -> [D.Doc]
300−actualThing json =
301− case json of
302− E.Array _ -> [D.red "array"]
303− E.Object _ -> [D.red "object"]
304− E.String _ -> [D.red "string"]
305− E.Boolean b -> [D.red (if b then "true" else "false"),"value"]
306− E.Integer n -> ["number",D.red (D.fromInt n)]
307− E.Number _ -> [D.red "number"]
308− E.Null -> [D.red "null","value"]
309248
249+getMaxDepth :: Problem x -> Int
250+getMaxDepth problem =
251+ case problem of
252+ Field _ prob -> 1 + getMaxDepth prob
253+ Index _ prob -> 1 + getMaxDepth prob
254+ OneOf p ps -> maximum (getMaxDepth p : map getMaxDepth ps)
255+ Failure _ _ -> 0
256+ Expecting _ _ -> 0
310257
311−anExpectedThing :: Json.Type -> [D.Doc]
312−anExpectedThing tipe =
313− case tipe of
314− Json.TObject -> ["an", D.green "OBJECT" <> "."]
315− Json.TArray -> ["an", D.green "ARRAY" <> "."]
316− Json.TString -> ["a", D.green "STRING" <> "."]
317− Json.TBool -> ["a", D.green "BOOLEAN" <> "."]
318− Json.TInt -> ["an", D.green "INT" <> "."]
319− Json.TObjectWith field -> ["an",D.green "OBJECT","with","a",D.green ("\"" <> D.fromString (Text.unpack field) <> "\""),"field."]
320− Json.TArrayPair len ->
321− ["an",D.green "ARRAY","with",D.green "TWO","entries."
322− ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
323− ]
324258
259+newtype FailureToReport x =
260+ FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report }
325261
326−toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
327−toBullet intro userErrorToDocs theory =
328− D.indent 4 $ D.fillSep $ (++) intro $
329− case theory of
330− Failure userError ->
331− userErrorToDocs userError
332262
333− Expecting tipe ->
334− ["I","was","expecting"] ++ anExpectedThing tipe
335−
336−
337−
338−-- TO FLAT ERRORS
339−
340−
341−data FlatError e =
342− FlatError [String] E.Value (Theory e) [Theory e]
343−
344−
345−data Theory e
346− = Failure e
347− | Expecting Json.Type
348−
349−
350−flatten :: Json.Error e -> [FlatError e]
351−flatten jsonError =
263+expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Help.Report
264+expectationToReport path source context (A.Region start end) expectation =
352265 let
353− depth (FlatError accesses _ _ _) =
354− length accesses
355− in
356− List.sortOn depth $ flattenTree (toErrorTree jsonError)
266+ (A.Position sr _) = start
267+ (A.Position er _) = end
357268
269+ region =
270+ if sr == er then region else A.Region start start
358271
359−flattenTree :: ErrorTree e -> [FlatError e]
360−flattenTree (ErrorTree theories subTrees) =
361− let
362− addAccess access (FlatError accesses json t ts) =
363− FlatError (access:accesses) json t ts
272+ introduction =
273+ case context of
274+ CRoot ->
275+ "I ran into some trouble here:"
364276
365− toFlats (name, tree) =
366− map (addAccess name) (flattenTree tree)
277+ CField field _ ->
278+ "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"
367279
368− subErrors =
369− concatMap toFlats (Map.toList subTrees)
370− in
371− case theories of
372− [] ->
373− subErrors
374−
375− (json, theory) : rest ->
376− FlatError [] json theory (map snd rest) : subErrors
377−
378−
379−
380−-- TO ERROR TREE
381−
382−
383−data ErrorTree e =
384− ErrorTree
385− { _theories :: [(E.Value, Theory e)]
386− , _subErrors :: Map.Map String (ErrorTree e)
387− }
388−
389−
390−toErrorTree :: Json.Error e -> ErrorTree e
391−toErrorTree jsonError =
392− add jsonError empty
393−
394−
395−empty :: ErrorTree e
396−empty =
397− ErrorTree [] Map.empty
280+ CIndex index (CField field _) ->
281+ "When looking at the \"" ++ BS_UTF8.toString field ++ "\" field, I ran into trouble with the "
282+ ++ D.intToOrdinal index ++ " entry:"
398283
284+ CIndex index _ ->
285+ "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:"
399286
400−add :: Json.Error e -> ErrorTree e -> ErrorTree e
401−add jsonError tree@(ErrorTree theories subErrors) =
402− case jsonError of
403− Json.Field field subErr ->
404− ErrorTree theories (addName (fieldToName field) subErr subErrors)
405−
406− Json.Index index subErr ->
407− ErrorTree theories (addName (indexToName index) subErr subErrors)
408−
409− Json.OneOf errors ->
410− foldr add tree errors
411−
412− Json.Expecting json tipe ->
413− ErrorTree ((json, Expecting tipe) : theories) subErrors
414−
415− Json.Failure json err ->
416− ErrorTree ((json, Failure err) : theories) subErrors
417−
418−
419−addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)
420−addName name err subErrors =
421− let
422− subAdd maybeCrush =
423− Just (add err (maybe empty id maybeCrush))
287+ toSnippet title aThing =
288+ Help.jsonReport title (Just path) $
289+ Code.toSnippet source region Nothing
290+ ( D.reflow introduction
291+ , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing
292+ )
424293 in
425− Map.alter subAdd name subErrors
294+ case expectation of
295+ TObject ->
296+ toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."]
426297
298+ TArray ->
299+ toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."]
427300
428−fieldToName :: [Char] -> String
429−fieldToName field =
430− case field of
431− [] ->
432− "['']"
301+ TString ->
302+ toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."]
433303
434− string@(char : rest) ->
435− if Char.isAlpha char && all Char.isAlphaNum rest then
436− '.' : string
437− else
438− "['" ++ string ++ "']"
304+ TBool ->
305+ toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."]
439306
307+ TInt ->
308+ toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."]
440309
441−indexToName :: Int -> String
442−indexToName index =
443− "[" ++ show index ++ "]"
444−-}
310+ TObjectWith field ->
311+ toSnippet "MISSING FIELD"
312+ ["an",D.green "OBJECT","with","a"
313+ ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"")
314+ ,"field."
315+ ]
316+
317+ TArrayPair len ->
318+ toSnippet "EXPECTING PAIR"
319+ ["an",D.green "ARRAY","with",D.green "TWO","entries."
320+ ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
321+ ]