@@ -1,14 +1,17 @@
1+{-# OPTIONS_GHC -Wall #-}
12{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Docs where
3−
4−import Control.Applicative ((<|>))
5−import Control.Monad
6−import Data.Aeson ((.:), (.:?), (.=))
7−import qualified Data.Aeson as Json
8−import qualified Data.Aeson.Encode.Pretty as Json
9−import qualified Data.ByteString.Lazy.Char8 as BS
3+module Elm.Docs
4+ ( Documentation(..)
5+ , Alias(..)
6+ , Union(..)
7+ , Value(..)
8+ , fromCheckedDocs
9+ , decoder
10+ , encode
11+ )
12+ where
13+
1014import qualified Data.Map as Map
11−import qualified Data.Text as Text
1215import Data.Text (Text)
1316
1417import qualified Docs.AST as Docs
@@ -16,6 +19,9 @@ import qualified Elm.Compiler.Module as Module
1619import qualified Elm.Compiler.Type as Type
1720import qualified Elm.Compiler.Version as Version
1821import qualified Elm.Package as Pkg
22+import qualified Json.Decode as Decode
23+import qualified Json.Encode as Encode
24+import Json.Encode ((==>))
1925
2026
2127
@@ -24,45 +30,42 @@ import qualified Elm.Package as Pkg
2430
2531data Documentation =
2632 Documentation
27− { moduleName :: Module.Raw
28− , comment :: Text
29− , aliases :: [Alias]
30− , types :: [Union]
31− , values :: [Value]
32− , version :: Version
33+ { _name :: Module.Raw
34+ , _comment :: Text
35+ , _aliases :: [Alias]
36+ , _types :: [Union]
37+ , _values :: [Value]
38+ , _version :: Maybe Pkg.Version
3339 }
3440
3541
3642data Alias =
3743 Alias
38− { aliasName :: Text
39− , aliasComment :: Text
40− , aliasArgs :: [Text]
41− , aliasType :: Type.Type
44+ { _a_name :: Text
45+ , _a_comment :: Text
46+ , _a_args :: [Text]
47+ , _a_type :: Type.Type
4248 }
4349
4450
4551data Union =
4652 Union
47− { unionName :: Text
48− , unionComment :: Text
49− , unionArgs :: [Text]
50− , unionCases :: [(Text, [Type.Type])]
53+ { _u_name :: Text
54+ , _u_comment :: Text
55+ , _u_args :: [Text]
56+ , _u_cases :: [(Text, [Type.Type])]
5157 }
5258
5359
5460data Value =
5561 Value
56− { valueName :: Text
57− , valueComment :: Text
58− , valueType :: Type.Type
59− , valueFix :: Maybe (Text,Int)
62+ { _v_name :: Text
63+ , _v_comment :: Text
64+ , _v_type :: Type.Type
65+ , _v_fix :: Maybe (Text,Int)
6066 }
6167
6268
63−data Version = NonCanonicalTypes | Version Text
64−
65−
6669
6770-- FROM CHECKED DOCS
6871
@@ -70,14 +73,14 @@ data Version = NonCanonicalTypes | Version Text
7073fromCheckedDocs :: Module.Raw -> Docs.Checked -> Documentation
7174fromCheckedDocs name (Docs.Checked comment values aliases unions) =
7275 let
73− toValue (name, Docs.Value comment tipe fix) =
74− Value name comment tipe fix
76+ toValue (vName, Docs.Value vComment tipe fix) =
77+ Value vName vComment tipe fix
7578
76− toAlias (name, Docs.Alias comment args tipe) =
77− Alias name comment args tipe
79+ toAlias (aName, Docs.Alias aComment args tipe) =
80+ Alias aName aComment args tipe
7881
79− toUnion (name, Docs.Union comment args cases) =
80− Union name comment args cases
82+ toUnion (uName, Docs.Union uComment args cases) =
83+ Union uName uComment args cases
8184 in
8285 Documentation
8386 name
@@ -85,168 +88,131 @@ fromCheckedDocs name (Docs.Checked comment values aliases unions) =
8588 (map toAlias (Map.toList aliases))
8689 (map toUnion (Map.toList unions))
8790 (map toValue (Map.toList values))
88− (Version (Text.pack (Pkg.versionToString 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−
91+ (Just Version.version)
11392
11493
115−-- JSON for DOCUMENTATION
11694
95+-- JSON
11796
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− ]
12897
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+ []
129111
130−instance Json.FromJSON Documentation where
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)
112+ Just version ->
113+ [ "generated-with-elm-version" ==> Pkg.encodeVersion version
114+ ]
139115
140− parseJSON value =
141− fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)
142116
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)
143126
144127
145128
146−-- JSON for VERSION
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
129+-- JSON for ALIAS
157130
158131
159−instance Json.FromJSON Version where
160− parseJSON (Json.String text) =
161− case text of
162− "old" -> return NonCanonicalTypes
163− vrsn -> return (Version vrsn)
132+encodeAlias :: Alias -> Encode.Value
133+encodeAlias (Alias name comment args tipe) =
134+ Encode.object
135+ [ "name" ==> Encode.text name
136+ , "comment" ==> Encode.text comment
137+ , "args" ==> Encode.list Encode.text args
138+ , "type" ==> Type.encode tipe
139+ ]
164140
165− parseJSON value =
166− fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)
167141
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
168149
169150
170−-- JSON for ALIAS
171151
152+-- JSON for UNION
172153
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− ]
181154
182−instance Json.FromJSON Alias where
183− parseJSON (Json.Object obj) =
184− Alias
185− <$> obj .: "name"
186− <*> obj .: "comment"
187− <*> obj .: "args"
188− <*> obj .: "type"
155+encodeUnion :: Union -> Encode.Value
156+encodeUnion (Union name comment args cases) =
157+ Encode.object
158+ [ "name" ==> Encode.text name
159+ , "comment" ==> Encode.text comment
160+ , "args" ==> Encode.list Encode.text args
161+ , "cases" ==> Encode.list encodeCase cases
162+ ]
189163
190− parseJSON value =
191− fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)
192164
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)
193172
194173
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 ]
196177
197178
198−instance Json.ToJSON Union where
199− toJSON (Union name comment args cases) =
200− Json.object
201− [ "name" .= name
202− , "comment" .= comment
203− , "args" .= args
204− , "cases" .= cases
205− ]
179+caseDecoder :: Decode.Decoder ( Text, [Type.Type] )
180+caseDecoder =
181+ (,)
182+ <$> Decode.index 0 Decode.text
183+ <*> Decode.index 1 (Decode.list Type.decoder)
206184
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"
214185
215− parseJSON value =
216− fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)
217186
187+-- JSON for VALUE
218188
219189
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+ []
221201
202+ Just (assoc, prec) ->
203+ [ "associativity" ==> Encode.text assoc
204+ , "precedence" ==> Encode.int prec
205+ ]
222206
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)
252207
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+ )