git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Json/Decode/Error.hs
265 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.TArrayPair len ->
143 ["an",D.green "ARRAY","with",D.green "TWO","entries."
144 ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
145 ]
148toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
149toBullet intro userErrorToDocs theory =
150 D.indent 4 $ D.fillSep $ (++) intro $
151 case theory of
152 Failure userError ->
153 userErrorToDocs userError
155 Expecting tipe ->
156 ["I","was","expecting"] ++ anExpectedThing tipe
160-- TO FLAT ERRORS
163data FlatError e =
164 FlatError [String] E.Value (Theory e) [Theory e]
167data Theory e
168 = Failure e
169 | Expecting Json.Type
172flatten :: Json.Error e -> [FlatError e]
173flatten jsonError =
174 let
175 depth (FlatError accesses _ _ _) =
176 length accesses
177 in
178 List.sortOn depth $ flattenTree (toErrorTree jsonError)
181flattenTree :: ErrorTree e -> [FlatError e]
182flattenTree (ErrorTree theories subTrees) =
183 let
184 addAccess access (FlatError accesses json t ts) =
185 FlatError (access:accesses) json t ts
187 toFlats (name, tree) =
188 map (addAccess name) (flattenTree tree)
190 subErrors =
191 concatMap toFlats (Map.toList subTrees)
192 in
193 case theories of
194 [] ->
195 subErrors
197 (json, theory) : rest ->
198 FlatError [] json theory (map snd rest) : subErrors
202-- TO ERROR TREE
205data ErrorTree e =
206 ErrorTree
207 { _theories :: [(E.Value, Theory e)]
208 , _subErrors :: Map.Map String (ErrorTree e)
209 }
212toErrorTree :: Json.Error e -> ErrorTree e
213toErrorTree jsonError =
214 add jsonError empty
217empty :: ErrorTree e
218empty =
219 ErrorTree [] Map.empty
222add :: Json.Error e -> ErrorTree e -> ErrorTree e
223add jsonError tree@(ErrorTree theories subErrors) =
224 case jsonError of
225 Json.Field field subErr ->
226 ErrorTree theories (addName (fieldToName field) subErr subErrors)
228 Json.Index index subErr ->
229 ErrorTree theories (addName (indexToName index) subErr subErrors)
231 Json.OneOf errors ->
232 foldr add tree errors
234 Json.Expecting json tipe ->
235 ErrorTree ((json, Expecting tipe) : theories) subErrors
237 Json.Failure json err ->
238 ErrorTree ((json, Failure err) : theories) subErrors
241addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)
242addName name err subErrors =
243 let
244 subAdd maybeCrush =
245 Just (add err (maybe empty id maybeCrush))
246 in
247 Map.alter subAdd name subErrors
250fieldToName :: Text.Text -> String
251fieldToName field =
252 case Text.unpack field of
253 [] ->
254 "['']"
256 string@(char : rest) ->
257 if Char.isAlpha char && all Char.isAlphaNum rest then
258 '.' : string
259 else
260 "['" ++ string ++ "']"
263indexToName :: Int -> String
264indexToName index =
265 "[" ++ show index ++ "]"