git.iko.soy/elk
on master help sign in
Rewrite JSON encode/decode for Elm.Docs and for public types
b996670Evan Czaplicki
src/Elm/Compiler/Type.hs+52−81
compare with master
unifiedsplit
@@ -3,14 +3,13 @@
3module Elm.Compiler.Type
3module Elm.Compiler.Type
4 ( Type(..), toString
4 ( Type(..), toString
5 , Program(..)
5 , Program(..)
6+ , encode
7+ , decoder
8+ , encodeProgram
6 )
9 )
7 where
10 where
8
11
9import Control.Arrow ((***))
12import Control.Arrow ((***))
10−import Data.Aeson ((.:), (.=))
11−import qualified Data.Aeson as Json
12−import qualified Data.Aeson.Types as Json
13−import qualified Data.ByteString.Lazy.Char8 as BS
14import qualified Data.Text as Text
13import qualified Data.Text as Text
15import Data.Text (Text)
14import Data.Text (Text)
16import Text.PrettyPrint as P
15import Text.PrettyPrint as P
@@ -21,9 +20,15 @@ import qualified AST.Variable as Var
21import qualified Parse.Helpers as Parse
20import qualified Parse.Helpers as Parse
22import qualified Parse.Type as Type
21import qualified Parse.Type as Type
23import qualified Reporting.Annotation as A
22import qualified Reporting.Annotation as A
23+import qualified Json.Decode as Decode
24+import qualified Json.Encode as Encode
25+import Json.Encode ((==>))
24
26
25
27
26
28
29+-- TYPES
30+
31+
27data Type
32data Type
28 = Lambda Type Type
33 = Lambda Type Type
29 | Var Text
34 | Var Text
@@ -153,106 +158,72 @@ flattenRecord tipe =
153-- JSON for TYPE
158-- JSON for TYPE
154
159
155
160
156−instance Json.ToJSON Type where
161+encode :: Type -> Encode.Value
157− toJSON tipe =
162+encode tipe =
158− Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
163+ Encode.text (Text.unwords (Text.words (Text.pack (toString tipe))))
159−
160−
161−instance Json.FromJSON Type where
162− parseJSON value =
163− let
164− failure _ =
165− fail $
166− "Trying to decode a type string, but could not handle this value:\n"
167− ++ BS.unpack (Json.encode value)
168− in
169− case value of
170− Json.String txt ->
171− case Parse.run Type.expression (Text.replace "'" "_" txt) of
172− Left err ->
173− failure err
174−
175− Right (tipe, _, _) ->
176− return (fromRawType tipe)
177−
178− Json.Object obj ->
179− fromObject obj
180−
181− _ ->
182− failure ()
183−
184−
185−fromObject :: Json.Object -> Json.Parser Type
186−fromObject obj =
187− do tag <- obj .: "tag"
188− case (tag :: String) of
189− "lambda" ->
190− Lambda <$> obj .: "in" <*> obj .: "out"
191
164
192− "var" ->
193− Var <$> obj .: "name"
194
165
195− "type" ->
166+decoder :: Decode.Decoder Type
196− Type <$> obj .: "name"
167+decoder =
168+ do txt <- Decode.text
169+ case Parse.run Type.expression txt of
170+ Left _ ->
171+ Decode.fail "a type, like (String -> Int)"
197
172
198− "app" ->
173+ Right (tipe, _, _) ->
199− App <$> obj .: "func" <*> obj .: "args"
174+ Decode.succeed (fromRawType tipe)
200−
201− "record" ->
202− Record <$> obj .: "fields" <*> obj .: "extension"
203−
204− _ ->
205− fail $ "Error when decoding type with tag: " ++ tag
206
175
207
176
208fromRawType :: Type.Raw -> Type
177fromRawType :: Type.Raw -> Type
209fromRawType (A.A _ astType) =
178fromRawType (A.A _ astType) =
210− case astType of
179+ case astType of
211− Type.RLambda t1 t2 ->
180+ Type.RLambda t1 t2 ->
212− Lambda (fromRawType t1) (fromRawType t2)
181+ Lambda (fromRawType t1) (fromRawType t2)
213
182
214− Type.RVar x ->
183+ Type.RVar x ->
215− Var x
184+ Var x
216
185
217− Type.RType var ->
186+ Type.RType var ->
218− Type (Var.rawToText var)
187+ Type (Var.rawToText var)
219
188
220− Type.RApp t ts ->
189+ Type.RApp t ts ->
221− App (fromRawType t) (map fromRawType ts)
190+ App (fromRawType t) (map fromRawType ts)
222
191
223− Type.RRecord fields ext ->
192+ Type.RRecord fields ext ->
224− Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
193+ Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
225
194
226
195
227
196
228-- JSON for PROGRAM
197-- JSON for PROGRAM
229
198
230
199
231−instance Json.ToJSON Program where
200+encodeProgram :: Program -> Encode.Value
232− toJSON (Program msg aliases unions) =
201+encodeProgram (Program msg aliases unions) =
233− Json.object
202+ Encode.object
234− [ "message" .= msg
203+ [ "message" ==> encode msg
235− , "aliases" .= Json.object (map toAliasField aliases)
204+ , "aliases" ==> Encode.object (map toAliasField aliases)
236− , "unions" .= Json.object (map toUnionField unions)
205+ , "unions" ==> Encode.object (map toUnionField unions)
237− ]
206+ ]
238
207
239
208
240−toAliasField :: ( Text, [Text], Type ) -> Json.Pair
209+toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
241toAliasField ( name, args, tipe ) =
210toAliasField ( name, args, tipe ) =
211+ Text.unpack name ==>
242− name .= Json.object
212+ Encode.object
243− [ "args" .= args
213+ [ "args" ==> Encode.list Encode.text args
244− , "type" .= tipe
214+ , "type" ==> encode tipe
245− ]
215+ ]
246
216
247
217
248−toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> Json.Pair
218+toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
249toUnionField ( name, args, constructors ) =
219toUnionField ( name, args, constructors ) =
220+ Text.unpack name ==>
250− name .= Json.object
221+ Encode.object
251− [ "args" .= args
222+ [ "args" ==> Encode.list Encode.text args
252− , "tags" .= Json.object (map toCtorObject constructors)
223+ , "tags" ==> Encode.object (map toCtorObject constructors)
253− ]
224+ ]
254
225
255
226
256−toCtorObject :: (Text, [Type]) -> Json.Pair
227+toCtorObject :: (Text, [Type]) -> ( String, Encode.Value )
257toCtorObject (name, args) =
228toCtorObject (name, args) =
258− name .= args
229+ Text.unpack name ==> Encode.list encode args
src/Elm/Docs.hs+133−167
@@ -1,14 +1,17 @@
1+{-# OPTIONS_GHC -Wall #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Docs where
3+module Elm.Docs
3−
4+ ( Documentation(..)
4−import Control.Applicative ((<|>))
5+ , Alias(..)
5−import Control.Monad
6+ , Union(..)
6−import Data.Aeson ((.:), (.:?), (.=))
7+ , Value(..)
7−import qualified Data.Aeson as Json
8+ , fromCheckedDocs
8−import qualified Data.Aeson.Encode.Pretty as Json
9+ , decoder
9−import qualified Data.ByteString.Lazy.Char8 as BS
10+ , encode
11+ )
12+ where
13+
10import qualified Data.Map as Map
14import qualified Data.Map as Map
11−import qualified Data.Text as Text
12import Data.Text (Text)
15import Data.Text (Text)
13
16
14import qualified Docs.AST as Docs
17import qualified Docs.AST as Docs
@@ -16,6 +19,9 @@ import qualified Elm.Compiler.Module as Module
16import qualified Elm.Compiler.Type as Type
19import qualified Elm.Compiler.Type as Type
17import qualified Elm.Compiler.Version as Version
20import qualified Elm.Compiler.Version as Version
18import qualified Elm.Package as Pkg
21import qualified Elm.Package as Pkg
22+import qualified Json.Decode as Decode
23+import qualified Json.Encode as Encode
24+import Json.Encode ((==>))
19
25
20
26
21
27
@@ -24,45 +30,42 @@ import qualified Elm.Package as Pkg
24
30
25data Documentation =
31data Documentation =
26 Documentation
32 Documentation
27− { moduleName :: Module.Raw
33+ { _name :: Module.Raw
28− , comment :: Text
34+ , _comment :: Text
29− , aliases :: [Alias]
35+ , _aliases :: [Alias]
30− , types :: [Union]
36+ , _types :: [Union]
31− , values :: [Value]
37+ , _values :: [Value]
32− , version :: Version
38+ , _version :: Maybe Pkg.Version
33 }
39 }
34
40
35
41
36data Alias =
42data Alias =
37 Alias
43 Alias
38− { aliasName :: Text
44+ { _a_name :: Text
39− , aliasComment :: Text
45+ , _a_comment :: Text
40− , aliasArgs :: [Text]
46+ , _a_args :: [Text]
41− , aliasType :: Type.Type
47+ , _a_type :: Type.Type
42 }
48 }
43
49
44
50
45data Union =
51data Union =
46 Union
52 Union
47− { unionName :: Text
53+ { _u_name :: Text
48− , unionComment :: Text
54+ , _u_comment :: Text
49− , unionArgs :: [Text]
55+ , _u_args :: [Text]
50− , unionCases :: [(Text, [Type.Type])]
56+ , _u_cases :: [(Text, [Type.Type])]
51 }
57 }
52
58
53
59
54data Value =
60data Value =
55 Value
61 Value
56− { valueName :: Text
62+ { _v_name :: Text
57− , valueComment :: Text
63+ , _v_comment :: Text
58− , valueType :: Type.Type
64+ , _v_type :: Type.Type
59− , valueFix :: Maybe (Text,Int)
65+ , _v_fix :: Maybe (Text,Int)
60 }
66 }
61
67
62
68
63−data Version = NonCanonicalTypes | Version Text
64−
65−
66
69
67-- FROM CHECKED DOCS
70-- FROM CHECKED DOCS
68
71
@@ -70,14 +73,14 @@ data Version = NonCanonicalTypes | Version Text
70fromCheckedDocs :: Module.Raw -> Docs.Checked -> Documentation
73fromCheckedDocs :: Module.Raw -> Docs.Checked -> Documentation
71fromCheckedDocs name (Docs.Checked comment values aliases unions) =
74fromCheckedDocs name (Docs.Checked comment values aliases unions) =
72 let
75 let
73− toValue (name, Docs.Value comment tipe fix) =
76+ toValue (vName, Docs.Value vComment tipe fix) =
74− Value name comment tipe fix
77+ Value vName vComment tipe fix
75
78
76− toAlias (name, Docs.Alias comment args tipe) =
79+ toAlias (aName, Docs.Alias aComment args tipe) =
77− Alias name comment args tipe
80+ Alias aName aComment args tipe
78
81
79− toUnion (name, Docs.Union comment args cases) =
82+ toUnion (uName, Docs.Union uComment args cases) =
80− Union name comment args cases
83+ Union uName uComment args cases
81 in
84 in
82 Documentation
85 Documentation
83 name
86 name
@@ -85,168 +88,131 @@ fromCheckedDocs name (Docs.Checked comment values aliases unions) =
85 (map toAlias (Map.toList aliases))
88 (map toAlias (Map.toList aliases))
86 (map toUnion (Map.toList unions))
89 (map toUnion (Map.toList unions))
87 (map toValue (Map.toList values))
90 (map toValue (Map.toList values))
88− (Version (Text.pack (Pkg.versionToString Version.version)))
91+ (Just Version.version)
89−
90−
91−
92−-- PRETTY JSON
93−
94−
95−prettyJson :: (Json.ToJSON a) => a -> BS.ByteString
96−prettyJson value =
97− Json.encodePretty' config value
98−
99−
100−config :: Json.Config
101−config =
102− Json.Config
103− { Json.confIndent = Json.Tab
104− , Json.confCompare = Json.keyOrder keys
105− , Json.confNumFormat = Json.Generic
106− }
107− where
108− keys =
109− [ "tag", "name", "comment", "aliases", "types"
110− , "values", "func", "args", "type", "cases"
111− ]
112−
113
92
114
93
115−-- JSON for DOCUMENTATION
116
94
95+-- JSON
117
96
118−instance Json.ToJSON Documentation where
119− toJSON (Documentation name comment aliases types values version) =
120− Json.object
121− [ "name" .= Module.RawForJson name
122− , "comment" .= comment
123− , "aliases" .= aliases
124− , "types" .= types
125− , "values" .= values
126− , "generated-with-elm-version" .= version
127− ]
128
97
98+encode :: Documentation -> Encode.Value
99+encode (Documentation name comment aliases types values elmVersion) =
100+ Encode.object $
101+ [ "name" ==> Module.encode name
102+ , "comment" ==> Encode.text comment
103+ , "aliases" ==> Encode.list encodeAlias aliases
104+ , "types" ==> Encode.list encodeUnion types
105+ , "values" ==> Encode.list encodeValue values
106+ ]
107+ ++
108+ case elmVersion of
109+ Nothing ->
110+ []
129
111
130−instance Json.FromJSON Documentation where
112+ Just version ->
131− parseJSON (Json.Object obj) =
132− Documentation
133− <$> fmap Module.fromJson (obj .: "name")
134− <*> obj .: "comment"
135− <*> obj .: "aliases"
136− <*> obj .: "types"
137− <*> obj .: "values"
138− <*> ((obj .: "generated-with-elm-version") <|> return NonCanonicalTypes)
113+ [ "generated-with-elm-version" ==> Pkg.encodeVersion version
114+ ]
139
115
140− parseJSON value =
141− fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)
142
116
117+decoder :: Decode.Decoder Documentation
118+decoder =
119+ Documentation
120+ <$> Decode.field "name" Module.decoder
121+ <*> Decode.field "comment" Decode.text
122+ <*> Decode.field "aliases" (Decode.list aliasDecoder)
123+ <*> Decode.field "types" (Decode.list unionDecoder)
124+ <*> Decode.field "values" (Decode.list valueDecoder)
125+ <*> Decode.maybe (Decode.field "generated-with-elm-version" Pkg.versionDecoder)
143
126
144
127
145
128
146−-- JSON for VERSION
129+-- JSON for ALIAS
147−
148−
149−instance Json.ToJSON Version where
150− toJSON version =
151− case version of
152− NonCanonicalTypes ->
153− Json.String "old"
154−
155− Version vsn ->
156− Json.String vsn
157
130
158
131
159−instance Json.FromJSON Version where
132+encodeAlias :: Alias -> Encode.Value
160− parseJSON (Json.String text) =
133+encodeAlias (Alias name comment args tipe) =
161− case text of
134+ Encode.object
162− "old" -> return NonCanonicalTypes
135+ [ "name" ==> Encode.text name
163− vrsn -> return (Version vrsn)
136+ , "comment" ==> Encode.text comment
137+ , "args" ==> Encode.list Encode.text args
138+ , "type" ==> Type.encode tipe
139+ ]
164
140
165− parseJSON value =
166− fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)
167
141
142+aliasDecoder :: Decode.Decoder Alias
143+aliasDecoder =
144+ Alias
145+ <$> Decode.field "name" Decode.text
146+ <*> Decode.field "comment" Decode.text
147+ <*> Decode.field "args" (Decode.list Decode.text)
148+ <*> Decode.field "type" Type.decoder
168
149
169
150
170−-- JSON for ALIAS
171
151
152+-- JSON for UNION
172
153
173−instance Json.ToJSON Alias where
174− toJSON (Alias name comment args tipe) =
175− Json.object
176− [ "name" .= name
177− , "comment" .= comment
178− , "args" .= args
179− , "type" .= tipe
180− ]
181
154
182−instance Json.FromJSON Alias where
155+encodeUnion :: Union -> Encode.Value
183− parseJSON (Json.Object obj) =
156+encodeUnion (Union name comment args cases) =
184− Alias
157+ Encode.object
185− <$> obj .: "name"
158+ [ "name" ==> Encode.text name
186− <*> obj .: "comment"
159+ , "comment" ==> Encode.text comment
187− <*> obj .: "args"
160+ , "args" ==> Encode.list Encode.text args
188− <*> obj .: "type"
161+ , "cases" ==> Encode.list encodeCase cases
162+ ]
189
163
190− parseJSON value =
191− fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)
192
164
165+unionDecoder :: Decode.Decoder Union
166+unionDecoder =
167+ Union
168+ <$> Decode.field "name" Decode.text
169+ <*> Decode.field "comment" Decode.text
170+ <*> Decode.field "args" (Decode.list Decode.text)
171+ <*> Decode.field "cases" (Decode.list caseDecoder)
193
172
194
173
195−-- JSON for UNION
174+encodeCase :: ( Text, [Type.Type] ) -> Encode.Value
175+encodeCase ( tag, args ) =
176+ Encode.list id [ Encode.text tag, Encode.list Type.encode args ]
196
177
197
178
198−instance Json.ToJSON Union where
179+caseDecoder :: Decode.Decoder ( Text, [Type.Type] )
199− toJSON (Union name comment args cases) =
180+caseDecoder =
200− Json.object
181+ (,)
201− [ "name" .= name
182+ <$> Decode.index 0 Decode.text
202− , "comment" .= comment
183+ <*> Decode.index 1 (Decode.list Type.decoder)
203− , "args" .= args
204− , "cases" .= cases
205− ]
206
184
207−instance Json.FromJSON Union where
208− parseJSON (Json.Object obj) =
209− Union
210− <$> obj .: "name"
211− <*> obj .: "comment"
212− <*> obj .: "args"
213− <*> obj .: "cases"
214
185
215− parseJSON value =
216− fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)
217
186
187+-- JSON for VALUE
218
188
219
189
220−-- JSON for VALUE
190+encodeValue :: Value -> Encode.Value
191+encodeValue (Value name comment tipe assocPrec) =
192+ Encode.object $
193+ [ "name" ==> Encode.text name
194+ , "comment" ==> Encode.text comment
195+ , "type" ==> Type.encode tipe
196+ ]
197+ ++
198+ case assocPrec of
199+ Nothing ->
200+ []
221
201
202+ Just (assoc, prec) ->
203+ [ "associativity" ==> Encode.text assoc
204+ , "precedence" ==> Encode.int prec
205+ ]
222
206
223−instance Json.ToJSON Value where
224− toJSON (Value name comment tipe assocPrec) =
225− Json.object (fields ++ possibleFields)
226− where
227− fields =
228− [ "name" .= name
229− , "comment" .= comment
230− , "type" .= tipe
231− ]
232−
233− possibleFields =
234− case assocPrec of
235− Nothing -> []
236− Just (assoc, prec) ->
237− [ "associativity" .= assoc
238− , "precedence" .= prec
239− ]
240−
241−
242−instance Json.FromJSON Value where
243− parseJSON (Json.Object obj) =
244− Value
245− <$> obj .: "name"
246− <*> obj .: "comment"
247− <*> obj .: "type"
248− <*> (liftM2 (,) <$> obj .:? "associativity" <*> obj .:? "precedence")
249−
250− parseJSON value =
251− fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)
252
207
208+valueDecoder :: Decode.Decoder Value
209+valueDecoder =
210+ Value
211+ <$> Decode.field "name" Decode.text
212+ <*> Decode.field "comment" Decode.text
213+ <*> Decode.field "type" Type.decoder
214+ <*> Decode.maybe (
215+ (,)
216+ <$> Decode.field "associativity" Decode.text
217+ <*> Decode.field "precedence" Decode.int
218+ )