@@ -10,215 +10,221 @@ import System.IO
1010
1111import Control.Applicative ((<$>))
1212import Control.Arrow (second)
13−import Data.Aeson
14−import Data.Aeson.Encode.Pretty
15−import Data.Aeson.Types (Pair)
16−import qualified Data.List as List
13+import qualified Data.Aeson.Encode.Pretty as Json
1714import qualified Data.Map as Map
18−import qualified Data.ByteString.Lazy as BS
19−import qualified Data.Text as Text
15+import qualified Data.ByteString.Lazy.Char8 as BS
2016
21−import qualified AST.Helpers as Help
22−import qualified AST.Type as T
23−import qualified AST.Declaration as D
24−import qualified AST.Expression.Source as Src
17+import qualified AST.Type as Type
18+import qualified AST.Declaration as Decl
19+import qualified AST.Expression.Source as Source
2520import qualified AST.Variable as Var
2621
27−import Text.Parsec hiding (newline,spaces)
28−import Parse.Declaration (typeDecl,infixDecl)
29−import Parse.Expression (typeAnnotation)
30−import Parse.Helpers
31−import qualified Parse.Module as Module
22+import Text.Parsec hiding (newline, spaces)
23+import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
24+import qualified Parse.Expression as Parse (typeAnnotation)
25+import qualified Parse.Helpers as Parse
26+import qualified Parse.Module as Parse (header)
27+import qualified Elm.Compiler.Module as Module
28+import qualified Elm.Docs as Docs
29+
30+
31+-- FLAGS
3232
3333data Flags = Flags
34− { files :: [FilePath] }
34+ { input :: FilePath
35+ , output :: Maybe FilePath
36+ }
3537 deriving (Data,Typeable,Show,Eq)
3638
39+
3740defaultFlags :: Flags
3841defaultFlags = Flags
39− { files = def &= args &= typ "FILES"
42+ { input = def &= args &= typ "FILE"
43+
44+ , output = Nothing &= typFile
45+ &= help "file name for generated JSON documentation"
46+
4047 } &= help "Generate documentation for Elm"
41− &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
48+ &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
4249
43−main :: IO ()
44−main = do
45− flags <- cmdArgs defaultFlags
46− mapM_ parseFile (files flags)
4750
48−config :: Config
49−config = Config { confIndent = 2, confCompare = keyOrder keys }
51+-- GENERATE DOCUMENTATION
52+
53+main :: IO ()
54+main =
55+ do flags <- cmdArgs defaultFlags
56+ source <- readFile (input flags)
57+ case Parse.iParse documentation source of
58+ Right docs ->
59+ let json = Json.encodePretty' config docs in
60+ case output flags of
61+ Nothing -> BS.putStrLn json
62+ Just docPath ->
63+ do createDirectoryIfMissing True (dropFileName docPath)
64+ BS.writeFile docPath json
65+
66+ Left err ->
67+ do hPutStrLn stderr (show err)
68+ exitFailure
69+
70+
71+config :: Json.Config
72+config =
73+ Json.Config
74+ { Json.confIndent = 2
75+ , Json.confCompare = Json.keyOrder keys
76+ }
5077 where
51− keys = ["tag","name","document","comment","raw","aliases","datatypes"
52− ,"values","typeVariables","type","constructors"]
53−
54−parseFile :: FilePath -> IO ()
55−parseFile path = do
56− source <- readFile path
57− case iParse docs source of
58− Right json -> do
59− putStrLn $ "Documenting " ++ path
60− let docPath = "docs" </> replaceExtension path ".json"
61− createDirectoryIfMissing True (dropFileName docPath)
62− BS.writeFile docPath (encodePretty' config json)
63− Left err -> do
64− hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
65− exitFailure
66−
67−docs :: IParser Value
68−docs = do
69− (name, _exports, structure) <- moduleDocs
70− things <- document
71− return $ documentToJson name structure things
72−
73−docComment :: IParser String
74−docComment = do
75− try (string "{-|")
76− contents <- closeComment
77− let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
78− return $ dropWhile (==' ') (reverse reversed)
79−
80−moduleDocs :: IParser (String, Var.Listing Var.Value, String)
81−moduleDocs = do
82− optional freshLine
83− (names,exports) <- Module.header
84− manyTill (string " " <|> newline <?> "more whitespace")
85− (lookAhead (string "{-|") <?> "module documentation comment")
86− structure <- docComment
87− return (List.intercalate "." names, exports, structure)
88−
89−document :: IParser [(String, D.SourceDecl, String)]
90−document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
91−
92−docThing :: IParser (String, D.SourceDecl, String)
93−docThing = uncommentable <|> commented <|> uncommented ""
94− where
95− uncommentable = do
96− ifx <- infixDecl
97− return ("", ifx, "")
98−
99− commented = do
100− comment <- docComment
101− freshLine
102− uncommented comment
103−
104− uncommented comment = do
105− (src,def) <- withSource $ choice [ typeDecl, D.Definition <$> typeAnnotation ]
106− return (comment, def, src)
107−
108−
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
78+ keys =
79+ [ "tag", "name", "comment", "aliases", "types"
80+ , "values", "func", "args", "type", "cases"
11781 ]
82+
83+
84+-- PARSE DOCUMENTATION
85+
86+documentation :: Parse.IParser Docs.Documentation
87+documentation =
88+ do optional Parse.freshLine
89+ (names, _exports) <- Parse.header
90+
91+ manyTill (string " " <|> Parse.newline <?> "more whitespace")
92+ (lookAhead (string "{-|") <?> "module documentation comment")
93+
94+ overview <- docComment
95+
96+ decls <- allDeclarations
97+
98+ let (aliases, unions, values) = categorizeDeclarations decls
99+
100+ return (Docs.Documentation (Module.Name names) overview aliases unions values)
101+
102+
103+docComment :: Parse.IParser String
104+docComment =
105+ do try (string "{-|")
106+ contents <- Parse.closeComment
107+
108+ let reversed =
109+ dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
110+
111+ return $ dropWhile (==' ') (reverse reversed)
112+
113+
114+allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
115+allDeclarations =
116+ Parse.onFreshLines (:) [] declaration
117+
118+
119+declaration :: Parse.IParser (String, Decl.SourceDecl)
120+declaration =
121+ uncommentable <|> commented <|> uncommented ""
122+ where
123+ uncommentable =
124+ (,) "" <$> Parse.infixDecl
125+
126+ commented =
127+ do comment <- docComment
128+ Parse.freshLine
129+ uncommented comment
130+
131+ uncommented comment =
132+ (,) comment
133+ <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
134+
135+
136+-- CATEGORIZE DECLARATIONS
137+
138+data CategoryInfo = CategoryInfo
139+ { aliases :: [Docs.Alias]
140+ , unions :: [Docs.Union]
141+ , values :: Map.Map String Docs.Value
142+ , infixes :: Map.Map String (String, Int)
143+ }
144+
145+
146+emptyInfo :: CategoryInfo
147+emptyInfo =
148+ CategoryInfo [] [] Map.empty Map.empty
149+
150+
151+categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
152+categorizeDeclarations decls =
153+ (aliases, unions, Map.elems values)
118154 where
119− (values, aliases, adts) =
120− collect Map.empty Map.empty Map.empty Map.empty things
121−
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)
131−collect infixes types aliases adts things =
132− case things of
133− [] -> (Map.union customOps nonCustomOps, aliases, adts)
134− where
135− nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
136− addDefaultInfix name pairs
137− | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
138− | otherwise = pairs
139−
140− customOps = Map.intersectionWith addInfix infixes types
141− addInfix (assoc,prec) pairs =
142− [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
143−
144− (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
155+ (CategoryInfo aliases unions rawValues infixes) =
156+ foldr collectInfo emptyInfo decls
157+
158+ values =
159+ Map.union
160+ (Map.intersectionWith addInfixInfo rawValues infixes)
161+ rawValues
162+
163+
164+addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
165+addInfixInfo value infixInfo =
166+ value { Docs.valueAssocPrec = Just infixInfo }
167+
168+
169+collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
170+collectInfo (comment, decl) info =
171+ case decl of
172+ Decl.Definition def ->
173+ case def of
174+ Source.Definition _ _ -> error errorMessage
175+ Source.TypeAnnotation name tipe ->
176+ let value = Docs.Value name comment (toDocType tipe) Nothing
177+ in
178+ info { values = Map.insert name value (values info) }
179+
180+ Decl.Datatype name args cases ->
181+ let cases' = map (second (map toDocType)) cases
182+ union = Docs.Union name comment args cases'
183+ in
184+ info { unions = union : unions info }
185+
186+ Decl.TypeAlias name args tipe ->
187+ let alias = Docs.Alias name comment args (toDocType tipe)
151188 in
152− case decl of
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−
161− D.Datatype name vars 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− ]
166− in collect infixes types aliases (insert name fields adts) rest
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−
179−instance Var.ToString var => ToJSON (T.Type var) where
180− toJSON tipe =
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
221−ctorToJson tipe (ctor, tipes) =
222− object [ "name" .= ctor
223− , "type" .= foldr T.Lambda tipe tipes
224− ]
189+ info { aliases = alias : aliases info }
190+
191+ Decl.Fixity assoc prec name ->
192+ let infixInfo = (Decl.assocToString assoc, prec)
193+ in
194+ info { infixes = Map.insert name infixInfo (infixes info) }
195+
196+ Decl.Port _ ->
197+ error errorMessage
198+
199+
200+errorMessage :: String
201+errorMessage =
202+ "there appears to be a bug in this tool.\n" ++
203+ "Please report it to <https://github.com/elm-lang/Elm/issues>"
204+
205+
206+-- AST TYPE TO DOC TYPE
207+
208+toDocType :: Type.Type Var.Raw -> Docs.Type
209+toDocType astType =
210+ case astType of
211+ Type.Lambda t1 t2 ->
212+ Docs.Lambda (toDocType t1) (toDocType t2)
213+
214+ Type.Var x ->
215+ Docs.Var x
216+
217+ Type.Type (Var.Raw name) ->
218+ Docs.Type name
219+
220+ Type.App t ts ->
221+ Docs.App (toDocType t) (map toDocType ts)
222+
223+ Type.Record fields ext ->
224+ Docs.Record (map (second toDocType) fields) (fmap toDocType ext)
225+
226+ Type.Aliased _ t ->
227+ toDocType t
228+
229+
230+