git.iko.soy/elk
on 267f708 help sign in
elk/src/Elm/Docs.hs
250 lines 5.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Docs where
4import Control.Applicative ((<|>))
5import Control.Monad
6import Data.Aeson ((.:), (.:?), (.=))
7import qualified Data.Aeson as Json
8import qualified Data.Aeson.Encode.Pretty as Json
9import qualified Data.ByteString.Lazy.Char8 as BS
10import qualified Data.Map as Map
11import qualified Data.Text as Text
13import qualified Docs.AST as Docs
14import qualified Elm.Compiler.Module as Module
15import qualified Elm.Compiler.Type as Type
16import qualified Elm.Compiler.Version as Version
17import qualified Elm.Package as Pkg
18import qualified Reporting.Annotation as A
22-- DATA STRUCTURES
25data Documentation = Documentation
26 { moduleName :: Module.Raw
27 , comment :: String
28 , aliases :: [Alias]
29 , types :: [Union]
30 , values :: [Value]
31 , version :: Version
32 }
35data Alias = Alias
36 { aliasName :: String
37 , aliasComment :: String
38 , aliasArgs :: [String]
39 , aliasType :: Type.Type
40 }
43data Union = Union
44 { unionName :: String
45 , unionComment :: String
46 , unionArgs :: [String]
47 , unionCases :: [(String, [Type.Type])]
48 }
51data Value = Value
52 { valueName :: String
53 , valueComment :: String
54 , valueType :: Type.Type
55 , valueFix :: Maybe (String,Int)
56 }
59data Version = NonCanonicalTypes | Version String
63-- FROM CHECKED DOCS
66fromCheckedDocs :: Module.Raw -> Docs.Checked -> Documentation
67fromCheckedDocs name (Docs.Docs comment aliases unions values) =
68 let
69 unwrap cmnt =
70 maybe "" id cmnt
72 toAlias (name, (A.A _ (Docs.Alias cmnt args tipe))) =
73 Alias name (unwrap cmnt) args tipe
75 toUnion (name, (A.A _ (Docs.Union cmnt args cases))) =
76 Union name (unwrap cmnt) args cases
78 toValue (name, (A.A _ (Docs.Value cmnt tipe fix))) =
79 Value name (unwrap cmnt) tipe fix
80 in
81 Documentation
82 name
83 comment
84 (map toAlias (Map.toList aliases))
85 (map toUnion (Map.toList unions))
86 (map toValue (Map.toList values))
87 (Version $ (Pkg.versionToString Version.version))
91-- PRETTY JSON
94prettyJson :: (Json.ToJSON a) => a -> BS.ByteString
95prettyJson value =
96 Json.encodePretty' config value
99config :: Json.Config
100config =
101 Json.Config
102 { Json.confIndent = 2
103 , Json.confCompare = Json.keyOrder keys
104 }
105 where
106 keys =
107 [ "tag", "name", "comment", "aliases", "types"
108 , "values", "func", "args", "type", "cases"
109 ]
113-- JSON for DOCUMENTATION
116instance Json.ToJSON Documentation where
117 toJSON (Documentation name comment aliases types values version) =
118 Json.object
119 [ "name" .= Module.RawForJson name
120 , "comment" .= comment
121 , "aliases" .= aliases
122 , "types" .= types
123 , "values" .= values
124 , "generated-with-elm-version" .= version
125 ]
128instance Json.FromJSON Documentation where
129 parseJSON (Json.Object obj) =
130 Documentation
131 <$> fmap Module.fromJson (obj .: "name")
132 <*> obj .: "comment"
133 <*> obj .: "aliases"
134 <*> obj .: "types"
135 <*> obj .: "values"
136 <*> ((obj .: "generated-with-elm-version") <|> return NonCanonicalTypes)
138 parseJSON value =
139 fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)
144-- JSON for VERSION
147instance Json.ToJSON Version where
148 toJSON version =
149 case version of
150 NonCanonicalTypes ->
151 Json.String "old"
153 Version vsn ->
154 Json.String (Text.pack vsn)
157instance Json.FromJSON Version where
158 parseJSON (Json.String text) =
159 case Text.unpack text of
160 "old" -> return NonCanonicalTypes
161 vrsn -> return (Version vrsn)
163 parseJSON value =
164 fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)
168-- JSON for ALIAS
171instance Json.ToJSON Alias where
172 toJSON (Alias name comment args tipe) =
173 Json.object
174 [ "name" .= name
175 , "comment" .= comment
176 , "args" .= args
177 , "type" .= tipe
178 ]
180instance Json.FromJSON Alias where
181 parseJSON (Json.Object obj) =
182 Alias
183 <$> obj .: "name"
184 <*> obj .: "comment"
185 <*> obj .: "args"
186 <*> obj .: "type"
188 parseJSON value =
189 fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)
193-- JSON for UNION
196instance Json.ToJSON Union where
197 toJSON (Union name comment args cases) =
198 Json.object
199 [ "name" .= name
200 , "comment" .= comment
201 , "args" .= args
202 , "cases" .= cases
203 ]
205instance Json.FromJSON Union where
206 parseJSON (Json.Object obj) =
207 Union
208 <$> obj .: "name"
209 <*> obj .: "comment"
210 <*> obj .: "args"
211 <*> obj .: "cases"
213 parseJSON value =
214 fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)
218-- JSON for VALUE
221instance Json.ToJSON Value where
222 toJSON (Value name comment tipe assocPrec) =
223 Json.object (fields ++ possibleFields)
224 where
225 fields =
226 [ "name" .= name
227 , "comment" .= comment
228 , "type" .= tipe
229 ]
231 possibleFields =
232 case assocPrec of
233 Nothing -> []
234 Just (assoc, prec) ->
235 [ "associativity" .= assoc
236 , "precedence" .= prec
237 ]
240instance Json.FromJSON Value where
241 parseJSON (Json.Object obj) =
242 Value
243 <$> obj .: "name"
244 <*> obj .: "comment"
245 <*> obj .: "type"
246 <*> (liftM2 (,) <$> obj .:? "associativity" <*> obj .:? "precedence")
248 parseJSON value =
249 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)