@@ -12,6 +12,7 @@ import Control.Applicative ((<$>))
1212import Control.Arrow (second)
1313import Data.Aeson
1414import Data.Aeson.Encode.Pretty
15+import Data.Aeson.Types (Pair)
1516import qualified Data.List as List
1617import qualified Data.Map as Map
1718import qualified Data.ByteString.Lazy as BS
@@ -65,9 +66,9 @@ parseFile path = do
6566
6667docs :: IParser Value
6768docs = do
68− (name, exports, structure) <- moduleDocs
69+ (name, _exports, structure) <- moduleDocs
6970 things <- document
70− return $ documentToJson name exports structure things
71+ return $ documentToJson name structure things
7172
7273docComment :: IParser String
7374docComment = do
@@ -76,7 +77,7 @@ docComment = do
7677 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
7778 return $ dropWhile (==' ') (reverse reversed)
7879
79−--moduleDocs :: IParser (String, [String], String)
80+moduleDocs :: IParser (String, Var.Listing Var.Value, String)
8081moduleDocs = do
8182 optional freshLine
8283 (names,exports) <- moduleDef
@@ -85,10 +86,10 @@ moduleDocs = do
8586 structure <- docComment
8687 return (List.intercalate "." names, exports, structure)
8788
88−--document :: IParser [(String, D.SourceDecl, String)]
89+document :: IParser [(String, D.SourceDecl, String)]
8990document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
9091
91−--docThing :: IParser (String, D.SourceDecl, String)
92+docThing :: IParser (String, D.SourceDecl, String)
9293docThing = uncommentable <|> commented <|> uncommented ""
9394 where
9495 uncommentable = do
@@ -105,26 +106,28 @@ docThing = uncommentable <|> commented <|> uncommented ""
105106 return (comment, def, src)
106107
107108
108−documentToJson name exports structure things =
109− object $ [ "name" .= name
110− , "document" .= structure
111−-- , "values" .= toList values
112−-- , "aliases" .= toList aliases
113−-- , "datatypes" .= toList adts
114− ]
115−{--
109+documentToJson :: String -> String -> [(String, D.SourceDecl, String)] -> Value
110+documentToJson name structure things =
111+ object
112+ [ "name" .= name
113+ , "document" .= structure
114+ , "values" .= toList values
115+ , "aliases" .= toList aliases
116+ , "datatypes" .= toList adts
117+ ]
116118 where
117− (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things
119+ (values, aliases, adts) =
120+ collect Map.empty Map.empty Map.empty Map.empty things
118121
119− toList dict = map object . Map.elems $ filterPublics dict
120−
121− exportMap = Map.fromList (zip exports exports)
122− filterPublics dict =
123− case Map.null exportMap of
124− True -> dict
125− False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
126−--}
127−{--
122+ toList :: Map.Map String [Pair] -> [Value]
123+ toList dict =
124+ map object (Map.elems dict)
125+
126+type Pairs = Map.Map String [Pair]
127+
128+collect :: Map.Map String (D.Assoc, Int) -> Pairs -> Pairs -> Pairs
129+ -> [(String, D.SourceDecl, String)]
130+ -> (Pairs, Pairs, Pairs)
128131collect infixes types aliases adts things =
129132 case things of
130133 [] -> (Map.union customOps nonCustomOps, aliases, adts)
@@ -139,59 +142,83 @@ collect infixes types aliases adts things =
139142 [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
140143
141144 (comment, decl, source) : rest ->
145+ let insert name fields dict = Map.insert name (obj name fields) dict
146+ obj name fields =
147+ [ "name" .= name
148+ , "raw" .= source
149+ , "comment" .= comment
150+ ] ++ fields
151+ in
142152 case decl of
143− D.Fixity assoc prec name ->
144− collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
145− D.Definition (Src.TypeAnnotation name tipe) ->
146− collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
147− D.TypeAlias name vars tipe ->
148− let fields = ["typeVariables" .= vars, "type" .= tipe ]
149− in collect infixes types (insert name fields aliases) adts rest
153+ D.Definition def ->
154+ case def of
155+ Src.TypeAnnotation name tipe ->
156+ collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
157+
158+ Src.Definition _ _ ->
159+ collect infixes types aliases adts rest
160+
150161 D.Datatype name vars ctors ->
151− let tipe = T.App (T.Type name) (map T.Var vars)
152− fields = ["typeVariables" .= vars
153− , "constructors" .= map (ctorToJson tipe) ctors ]
162+ let tipe = T.App (T.Type (Var.Raw name)) (map T.Var vars)
163+ fields = [ "typeVariables" .= vars
164+ , "constructors" .= map (ctorToJson tipe) ctors
165+ ]
154166 in collect infixes types aliases (insert name fields adts) rest
155− where
156− insert name fields dict = Map.insert name (obj name fields) dict
157− obj name fields =
158− [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
159−--}
167+
168+ D.TypeAlias name vars tipe ->
169+ let fields = [ "typeVariables" .= vars, "type" .= tipe ]
170+ in collect infixes types (insert name fields aliases) adts rest
171+
172+ D.Port _ ->
173+ collect infixes types aliases adts rest
174+
175+ D.Fixity assoc prec name ->
176+ collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
177+
178+
160179instance Var.ToString var => ToJSON (T.Type var) where
161180 toJSON tipe =
162− object $
163− case tipe of
164− T.Lambda _ _ ->
165− let tipes = T.collectLambdas tipe in
166− [ "tag" .= ("function" :: Text.Text)
167− , "args" .= toJSON (init tipes)
168− , "result" .= toJSON (last tipes)
169− ]
170−
171− T.Var x ->
172− [ "tag" .= ("var" :: Text.Text)
173− , "name" .= toJSON x
174− ]
175−
176− T.Type name ->
177− [ "tag" .= ("adt" :: Text.Text)
178− , "name" .= toJSON (Var.toString name)
179− , "args" .= ([] :: [()])
180− ]
181−
182− T.App (T.Type name) ts ->
183− [ "tag" .= ("adt" :: Text.Text)
184− , "name" .= toJSON (Var.toString name)
185− , "args" .= map toJSON ts
186− ]
187−
188− T.Record fields ext ->
189− [ "tag" .= ("record" :: Text.Text)
190− , "fields" .= toJSON (map (toJSON . second toJSON) fields)
191− , "extension" .= toJSON ext
192− ]
193−
194−ctorToJson :: Var.ToString var => T.Type var -> (String, [T.Type var]) -> Value
181+ object (getFields tipe)
182+ where
183+ getFields tipe =
184+ case tipe of
185+ T.Lambda _ _ ->
186+ let tipes = T.collectLambdas tipe in
187+ [ "tag" .= ("function" :: Text.Text)
188+ , "args" .= toJSON (init tipes)
189+ , "result" .= toJSON (last tipes)
190+ ]
191+
192+ T.Var x ->
193+ [ "tag" .= ("var" :: Text.Text)
194+ , "name" .= toJSON x
195+ ]
196+
197+ T.Type name ->
198+ [ "tag" .= ("adt" :: Text.Text)
199+ , "name" .= toJSON (Var.toString name)
200+ , "args" .= ([] :: [()])
201+ ]
202+
203+ T.App (T.Type name) ts ->
204+ [ "tag" .= ("adt" :: Text.Text)
205+ , "name" .= toJSON (Var.toString name)
206+ , "args" .= map toJSON ts
207+ ]
208+
209+ T.App _ _ -> error "This is an unexpected error with elm-doc, please report it at <https://github.com/elm-lang/Elm/issues>"
210+
211+ T.Record fields ext ->
212+ [ "tag" .= ("record" :: Text.Text)
213+ , "fields" .= toJSON (map (toJSON . second toJSON) fields)
214+ , "extension" .= toJSON ext
215+ ]
216+
217+ T.Aliased _ t ->
218+ getFields t
219+
220+ctorToJson :: T.RawType -> (String, [T.RawType]) -> Value
195221ctorToJson tipe (ctor, tipes) =
196222 object [ "name" .= ctor
197− , "type" .= foldr T.Lambda tipe tipes ]
223+ , "type" .= foldr T.Lambda tipe tipes
224+ ]