@@ -0,0 +1,270 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Reporting.Error.Json
5+ ( Error(..)
6+ , toDoc
7+ )
8+ where
9+
10+
11+import Prelude hiding (userError)
12+import qualified Data.Char as Char
13+import qualified Data.List as List
14+import qualified Data.Map as Map
15+import qualified Data.Text as Text
16+import Text.PrettyPrint.ANSI.Leijen ((<+>), (<>))
17+import qualified Text.PrettyPrint.ANSI.Leijen as P
18+
19+import qualified Json.Decode.Internals as Json
20+import qualified Json.Encode as E
21+import qualified Reporting.Error.Syntax as Syntax
22+import qualified Reporting.Helpers as H
23+import qualified Reporting.Region as R
24+import qualified Reporting.Render.Code as Code
25+import qualified Reporting.Report as Report
26+
27+
28+
29+-- ERROR
30+
31+
32+data Error e
33+ = BadJson Syntax.Error
34+ | BadContent (Json.Error e)
35+
36+
37+
38+-- TO DOC
39+
40+
41+toDoc :: FilePath -> String -> Code.Source -> (e -> [H.Doc]) -> Error e -> H.Doc
42+toDoc path rootName source userErrorToDocs err =
43+ Report.toDoc path $
44+ case err of
45+ BadJson syntaxError ->
46+ Syntax.toReport source syntaxError
47+
48+ BadContent jsonError ->
49+ Report.Report "BAD JSON" R.zero [] $
50+ case flatten jsonError of
51+ [] ->
52+ H.reflow
53+ "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\
54+ \ and share it at <https://github.com/elm-lang/elm-compiler/issues> so I can\
55+ \ provide a helpful hint here!"
56+
57+ [flatError] ->
58+ flatErrorToDoc rootName [] userErrorToDocs flatError
59+
60+ flatErrors ->
61+ let
62+ toNumberedDoc index flatErr =
63+ P.dullcyan ("(" <> P.int index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr
64+ in
65+ H.stack $
66+ [ H.reflow $
67+ "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
68+ ]
69+ ++ zipWith toNumberedDoc [1..] flatErrors
70+
71+
72+
73+-- FLAT ERROR TO DOC
74+
75+
76+flatErrorToDoc :: String -> [H.Doc] -> (e -> [H.Doc]) -> FlatError e -> H.Doc
77+flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
78+ case theories of
79+ [] ->
80+ let
81+ explanation =
82+ case theory of
83+ Failure userError ->
84+ userErrorToDocs userError
85+
86+ Expecting tipe ->
87+ ["I","was","expecting"] ++ anExpectedThing tipe
88+ in
89+ case accesses of
90+ [] ->
91+ H.fillSep (starter ++ explanation)
92+
93+ _ ->
94+ H.stack
95+ [ H.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
96+ , H.fillSep explanation
97+ ]
98+
99+ _:_ ->
100+ let
101+ introduction =
102+ case accesses of
103+ [] ->
104+ ["I","am","having","trouble","with","the"]
105+ ++ actualThing json
106+ ++ ["here","because:"]
107+
108+ _ ->
109+ ["I","am","having","trouble","with","the"]
110+ ++ actualThing json
111+ ++ ["at",accessToDoc rootName accesses,"because:"]
112+ in
113+ H.stack
114+ [ H.fillSep (starter ++ introduction)
115+ , H.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
116+ , H.reflow "I accept any of these things."
117+ ]
118+
119+
120+accessToDoc :: String -> [String] -> H.Doc
121+accessToDoc rootName accesses =
122+ P.dullyellow (P.text (rootName ++ concat accesses))
123+
124+
125+actualThing :: E.Value -> [H.Doc]
126+actualThing json =
127+ case json of
128+ E.Array _ -> [H.red "array"]
129+ E.Object _ -> [H.red "object"]
130+ E.String _ -> [H.red "string"]
131+ E.Boolean b -> [H.red (if b then "true" else "false"),"value"]
132+ E.Integer n -> ["number",H.red (H.text (show n))]
133+ E.Number _ -> [H.red "number"]
134+ E.Null -> [H.red "null","value"]
135+
136+
137+anExpectedThing :: Json.Type -> [H.Doc]
138+anExpectedThing tipe =
139+ case tipe of
140+ Json.TObject -> ["an", P.green "OBJECT" <> "."]
141+ Json.TArray -> ["an", P.green "ARRAY" <> "."]
142+ Json.TString -> ["a", P.green "STRING" <> "."]
143+ Json.TBool -> ["a", P.green "BOOLEAN" <> "."]
144+ Json.TInt -> ["an", P.green "INT" <> "."]
145+ Json.TObjectWith field -> ["an",P.green "OBJECT","with","a",P.green ("\"" <> P.text (Text.unpack field) <> "\""),"field."]
146+ Json.TArrayWith i len ->
147+ ["a",H.green "longer",P.green "ARRAY" <> "."
148+ ,"I","need","index",P.text (show i) <> ",","but","this","array"
149+ ,"only","has",P.text (show len),"elements."
150+ ]
151+
152+
153+toBullet :: [H.Doc] -> (e -> [H.Doc]) -> Theory e -> H.Doc
154+toBullet intro userErrorToDocs theory =
155+ H.indent 4 $ H.fillSep $ (++) intro $
156+ case theory of
157+ Failure userError ->
158+ userErrorToDocs userError
159+
160+ Expecting tipe ->
161+ ["I","was","expecting"] ++ anExpectedThing tipe
162+
163+
164+
165+-- TO FLAT ERRORS
166+
167+
168+data FlatError e =
169+ FlatError [String] E.Value (Theory e) [Theory e]
170+
171+
172+data Theory e
173+ = Failure e
174+ | Expecting Json.Type
175+
176+
177+flatten :: Json.Error e -> [FlatError e]
178+flatten jsonError =
179+ let
180+ depth (FlatError accesses _ _ _) =
181+ length accesses
182+ in
183+ List.sortOn depth $ flattenTree (toErrorTree jsonError)
184+
185+
186+flattenTree :: ErrorTree e -> [FlatError e]
187+flattenTree (ErrorTree theories subTrees) =
188+ let
189+ addAccess access (FlatError accesses json t ts) =
190+ FlatError (access:accesses) json t ts
191+
192+ toFlats (name, tree) =
193+ map (addAccess name) (flattenTree tree)
194+
195+ subErrors =
196+ concatMap toFlats (Map.toList subTrees)
197+ in
198+ case theories of
199+ [] ->
200+ subErrors
201+
202+ (json, theory) : rest ->
203+ FlatError [] json theory (map snd rest) : subErrors
204+
205+
206+
207+-- TO ERROR TREE
208+
209+
210+data ErrorTree e =
211+ ErrorTree
212+ { _theories :: [(E.Value, Theory e)]
213+ , _subErrors :: Map.Map String (ErrorTree e)
214+ }
215+
216+
217+toErrorTree :: Json.Error e -> ErrorTree e
218+toErrorTree jsonError =
219+ add jsonError empty
220+
221+
222+empty :: ErrorTree e
223+empty =
224+ ErrorTree [] Map.empty
225+
226+
227+add :: Json.Error e -> ErrorTree e -> ErrorTree e
228+add jsonError tree@(ErrorTree theories subErrors) =
229+ case jsonError of
230+ Json.Field field subErr ->
231+ ErrorTree theories (addName (fieldToName field) subErr subErrors)
232+
233+ Json.Index index subErr ->
234+ ErrorTree theories (addName (indexToName index) subErr subErrors)
235+
236+ Json.OneOf errors ->
237+ foldr add tree errors
238+
239+ Json.Expecting json tipe ->
240+ ErrorTree ((json, Expecting tipe) : theories) subErrors
241+
242+ Json.Failure json err ->
243+ ErrorTree ((json, Failure err) : theories) subErrors
244+
245+
246+addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)
247+addName name err subErrors =
248+ let
249+ subAdd maybeCrush =
250+ Just (add err (maybe empty id maybeCrush))
251+ in
252+ Map.alter subAdd name subErrors
253+
254+
255+fieldToName :: Text.Text -> String
256+fieldToName field =
257+ case Text.unpack field of
258+ [] ->
259+ "['']"
260+
261+ string@(char : rest) ->
262+ if Char.isAlpha char && all Char.isAlphaNum rest then
263+ '.' : string
264+ else
265+ "['" ++ string ++ "']"
266+
267+
268+indexToName :: Int -> String
269+indexToName index =
270+ "[" ++ show index ++ "]"