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