git.iko.soy/elk
on eb236ca help sign in
elk/compiler/src/Json/Decode/Error.hs
266 lines 6.8 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
15import qualified Json.Decode.Internals as Json
16import qualified Json.Encode as E
17import Reporting.Doc ((<+>), (<>))
18import qualified Reporting.Doc as D
19import qualified Reporting.Error.Syntax as Syntax
20import qualified Reporting.Render.Code as Code
21import qualified Reporting.Report as Report
25-- ERROR
28data Error e
29 = BadJson Syntax.Error
30 | BadContent (Json.Error e)
34-- TO DOC
37toDoc :: String -> Code.Source -> (e -> [D.Doc]) -> Error e -> D.Doc
38toDoc rootName source userErrorToDocs err =
39 case err of
40 BadJson syntaxError ->
41 case Syntax.toReport source syntaxError of
42 Report.Report _ _ _ doc ->
43 doc
45 BadContent jsonError ->
46 case flatten jsonError of
47 [] ->
48 D.reflow
49 "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\
50 \ and share it at <https://github.com/elm/compiler/issues> so I can\
51 \ provide a helpful hint here!"
53 [flatError] ->
54 flatErrorToDoc rootName [] userErrorToDocs flatError
56 flatErrors ->
57 let
58 toNumberedDoc index flatErr =
59 D.dullcyan ("(" <> D.fromInt index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr
60 in
61 D.stack $
62 [ D.reflow $
63 "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
64 ]
65 ++ zipWith toNumberedDoc [1..] flatErrors
69-- FLAT ERROR TO DOC
72flatErrorToDoc :: String -> [D.Doc] -> (e -> [D.Doc]) -> FlatError e -> D.Doc
73flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
74 case theories of
75 [] ->
76 let
77 explanation =
78 case theory of
79 Failure userError ->
80 userErrorToDocs userError
82 Expecting tipe ->
83 ["I","was","expecting"] ++ anExpectedThing tipe
84 in
85 case accesses of
86 [] ->
87 D.fillSep (starter ++ explanation)
89 _ ->
90 D.stack
91 [ D.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
92 , D.fillSep explanation
93 ]
95 _:_ ->
96 let
97 introduction =
98 case accesses of
99 [] ->
100 ["I","am","having","trouble","with","the"]
101 ++ actualThing json
102 ++ ["here","because:"]
104 _ ->
105 ["I","am","having","trouble","with","the"]
106 ++ actualThing json
107 ++ ["at",accessToDoc rootName accesses,"because:"]
108 in
109 D.stack
110 [ D.fillSep (starter ++ introduction)
111 , D.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
112 , D.reflow "I accept any of these things."
113 ]
116accessToDoc :: String -> [String] -> D.Doc
117accessToDoc rootName accesses =
118 D.dullyellow (D.fromString (rootName ++ concat accesses))
121actualThing :: E.Value -> [D.Doc]
122actualThing json =
123 case json of
124 E.Array _ -> [D.red "array"]
125 E.Object _ -> [D.red "object"]
126 E.String _ -> [D.red "string"]
127 E.Boolean b -> [D.red (if b then "true" else "false"),"value"]
128 E.Integer n -> ["number",D.red (D.fromInt n)]
129 E.Number _ -> [D.red "number"]
130 E.Null -> [D.red "null","value"]
133anExpectedThing :: Json.Type -> [D.Doc]
134anExpectedThing tipe =
135 case tipe of
136 Json.TObject -> ["an", D.green "OBJECT" <> "."]
137 Json.TArray -> ["an", D.green "ARRAY" <> "."]
138 Json.TString -> ["a", D.green "STRING" <> "."]
139 Json.TBool -> ["a", D.green "BOOLEAN" <> "."]
140 Json.TInt -> ["an", D.green "INT" <> "."]
141 Json.TObjectWith field -> ["an",D.green "OBJECT","with","a",D.green ("\"" <> D.fromString (Text.unpack field) <> "\""),"field."]
142 Json.TArrayWith i len ->
143 ["a",D.green "longer",D.green "ARRAY" <> "."
144 ,"I","need","index",D.fromInt i <> ",","but","this","array"
145 ,"only","has",D.fromInt len,"elements."
146 ]
149toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
150toBullet intro userErrorToDocs theory =
151 D.indent 4 $ D.fillSep $ (++) intro $
152 case theory of
153 Failure userError ->
154 userErrorToDocs userError
156 Expecting tipe ->
157 ["I","was","expecting"] ++ anExpectedThing tipe
161-- TO FLAT ERRORS
164data FlatError e =
165 FlatError [String] E.Value (Theory e) [Theory e]
168data Theory e
169 = Failure e
170 | Expecting Json.Type
173flatten :: Json.Error e -> [FlatError e]
174flatten jsonError =
175 let
176 depth (FlatError accesses _ _ _) =
177 length accesses
178 in
179 List.sortOn depth $ flattenTree (toErrorTree jsonError)
182flattenTree :: ErrorTree e -> [FlatError e]
183flattenTree (ErrorTree theories subTrees) =
184 let
185 addAccess access (FlatError accesses json t ts) =
186 FlatError (access:accesses) json t ts
188 toFlats (name, tree) =
189 map (addAccess name) (flattenTree tree)
191 subErrors =
192 concatMap toFlats (Map.toList subTrees)
193 in
194 case theories of
195 [] ->
196 subErrors
198 (json, theory) : rest ->
199 FlatError [] json theory (map snd rest) : subErrors
203-- TO ERROR TREE
206data ErrorTree e =
207 ErrorTree
208 { _theories :: [(E.Value, Theory e)]
209 , _subErrors :: Map.Map String (ErrorTree e)
210 }
213toErrorTree :: Json.Error e -> ErrorTree e
214toErrorTree jsonError =
215 add jsonError empty
218empty :: ErrorTree e
219empty =
220 ErrorTree [] Map.empty
223add :: Json.Error e -> ErrorTree e -> ErrorTree e
224add jsonError tree@(ErrorTree theories subErrors) =
225 case jsonError of
226 Json.Field field subErr ->
227 ErrorTree theories (addName (fieldToName field) subErr subErrors)
229 Json.Index index subErr ->
230 ErrorTree theories (addName (indexToName index) subErr subErrors)
232 Json.OneOf errors ->
233 foldr add tree errors
235 Json.Expecting json tipe ->
236 ErrorTree ((json, Expecting tipe) : theories) subErrors
238 Json.Failure json err ->
239 ErrorTree ((json, Failure err) : theories) subErrors
242addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)
243addName name err subErrors =
244 let
245 subAdd maybeCrush =
246 Just (add err (maybe empty id maybeCrush))
247 in
248 Map.alter subAdd name subErrors
251fieldToName :: Text.Text -> String
252fieldToName field =
253 case Text.unpack field of
254 [] ->
255 "['']"
257 string@(char : rest) ->
258 if Char.isAlpha char && all Char.isAlphaNum rest then
259 '.' : string
260 else
261 "['" ++ string ++ "']"
264indexToName :: Int -> String
265indexToName index =
266 "[" ++ show index ++ "]"