git.iko.soy/elk
on 501c607 help sign in
elk/src/Docs.hs
273 lines 7.7 kB history raw
1{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
2module Main where
4import System.Console.CmdArgs
5import System.Directory
6import System.FilePath
7import System.Exit
8import System.IO
10import Control.Applicative ((<$>))
11import Control.Arrow (second)
12import Control.Monad (when)
13import qualified Data.Aeson.Encode.Pretty as Json
14import qualified Data.ByteString.Lazy.Char8 as BS
15import qualified Data.Map as Map
16import qualified Data.Maybe as Maybe
17import qualified Data.Set as Set
19import qualified AST.Declaration as Decl
20import qualified AST.Expression.Source as Source
21import qualified AST.Variable as Var
23import Text.Parsec hiding (newline, spaces)
24import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
25import qualified Parse.Expression as Parse (typeAnnotation)
26import qualified Parse.Helpers as Parse
27import qualified Parse.Module as Parse (header)
28import qualified Elm.Compiler.Module as Module
29import qualified Elm.Compiler.Type.Extract as Type
30import qualified Elm.Docs as Docs
33-- FLAGS
35data Flags = Flags
36 { input :: FilePath
37 , output :: Maybe FilePath
38 }
39 deriving (Data,Typeable,Show,Eq)
42defaultFlags :: Flags
43defaultFlags = Flags
44 { input = def &= args &= typ "FILE"
46 , output = Nothing &= typFile
47 &= help "file name for generated JSON documentation"
49 } &= help "Generate documentation for Elm"
50 &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
53-- GENERATE DOCUMENTATION
55main :: IO ()
56main =
57 do flags <- cmdArgs defaultFlags
58 let inputFileName = input flags
60 exists <- doesFileExist inputFileName
61 when (not exists) $
62 do hPutStrLn stderr $
63 if null inputFileName
64 then "Error: you must provide a file to document!"
65 else "Error: could not find a file named '" ++ inputFileName ++ "'"
66 exitFailure
68 source <- readFile inputFileName
69 case Parse.iParse documentation source of
70 Right docs ->
71 let json = Json.encodePretty' config docs in
72 case output flags of
73 Nothing -> BS.putStrLn json
74 Just docPath ->
75 do createDirectoryIfMissing True (dropFileName docPath)
76 BS.writeFile docPath json
78 Left err ->
79 do hPutStrLn stderr (show err)
80 exitFailure
83config :: Json.Config
84config =
85 Json.Config
86 { Json.confIndent = 2
87 , Json.confCompare = Json.keyOrder keys
88 }
89 where
90 keys =
91 [ "tag", "name", "comment", "aliases", "types"
92 , "values", "func", "args", "type", "cases"
93 ]
96-- PARSE DOCUMENTATION
98documentation :: Parse.IParser Docs.Documentation
99documentation =
100 do optional Parse.freshLine
101 (names, exports) <- Parse.header
103 manyTill (string " " <|> Parse.newline <?> "more whitespace")
104 (lookAhead (string "{-|") <?> "module documentation comment")
106 overview <- docComment
108 decls <- allDeclarations
110 let (aliases, unions, values) = categorizeDeclarations decls
112 return $
113 Docs.Documentation
114 (Module.Name names)
115 overview
116 (filterAliases exports aliases)
117 (filterUnions exports unions)
118 (filterValues exports values)
121docComment :: Parse.IParser String
122docComment =
123 do try (string "{-|")
124 contents <- Parse.closeComment
126 let reversed =
127 dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
129 return $ dropWhile (==' ') (reverse reversed)
132allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
133allDeclarations =
134 Parse.onFreshLines (:) [] declaration
137declaration :: Parse.IParser (String, Decl.SourceDecl)
138declaration =
139 uncommentable <|> commented <|> uncommented ""
140 where
141 uncommentable =
142 (,) "" <$> Parse.infixDecl
144 commented =
145 do comment <- docComment
146 Parse.freshLine
147 uncommented comment
149 uncommented comment =
150 (,) comment
151 <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
154-- CATEGORIZE DECLARATIONS
156data CategoryInfo = CategoryInfo
157 { aliases :: [Docs.Alias]
158 , unions :: [Docs.Union]
159 , values :: Map.Map String Docs.Value
160 , infixes :: Map.Map String (String, Int)
161 }
164emptyInfo :: CategoryInfo
165emptyInfo =
166 CategoryInfo [] [] Map.empty Map.empty
169categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
170categorizeDeclarations decls =
171 (aliases, unions, Map.elems values)
172 where
173 (CategoryInfo aliases unions rawValues infixes) =
174 foldr collectInfo emptyInfo decls
176 values =
177 Map.union
178 (Map.intersectionWith addInfixInfo rawValues infixes)
179 rawValues
182addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
183addInfixInfo value infixInfo =
184 value { Docs.valueAssocPrec = Just infixInfo }
187collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
188collectInfo (comment, decl) info =
189 case decl of
190 Decl.Definition def ->
191 case def of
192 Source.Definition _ _ -> error errorMessage
193 Source.TypeAnnotation name tipe ->
194 let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing
195 in
196 info { values = Map.insert name value (values info) }
198 Decl.Datatype name args cases ->
199 let cases' = map (second (map Type.fromInternalType)) cases
200 union = Docs.Union name comment args cases'
201 in
202 info { unions = union : unions info }
204 Decl.TypeAlias name args tipe ->
205 let alias = Docs.Alias name comment args (Type.fromInternalType tipe)
206 in
207 info { aliases = alias : aliases info }
209 Decl.Fixity assoc prec name ->
210 let infixInfo = (Decl.assocToString assoc, prec)
211 in
212 info { infixes = Map.insert name infixInfo (infixes info) }
214 Decl.Wire _ ->
215 error errorMessage
218errorMessage :: String
219errorMessage =
220 "there appears to be a bug in this tool.\n" ++
221 "Please report it to <https://github.com/elm-lang/Elm/issues>"
224-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS
226filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value]
227filterValues (Var.Listing exports open) values =
228 case open of
229 True -> values
230 False ->
231 let names =
232 Set.fromList (Var.getValues exports)
233 in
234 filter (\value -> Set.member (Docs.valueName value) names) values
237filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias]
238filterAliases (Var.Listing exports open) aliases =
239 case open of
240 True -> aliases
241 False ->
242 let names =
243 Set.fromList (Var.getAliases exports)
244 in
245 filter (\value -> Set.member (Docs.aliasName value) names) aliases
248filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union]
249filterUnions (Var.Listing exports open) unions =
250 case open of
251 True -> unions
252 False ->
253 Maybe.mapMaybe (filterUnion exportedUnions) unions
254 where
255 exportedUnions =
256 Map.fromList (Var.getUnions exports)
259filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union
260filterUnion exportedUnions union =
261 case Map.lookup (Docs.unionName union) exportedUnions of
262 Nothing ->
263 Nothing
265 Just (Var.Listing tags unionOpen)
266 | unionOpen ->
267 Just union
268 | otherwise ->
269 let publicTags =
270 filter (\(tag, _) -> tag `elem` tags) (Docs.unionCases union)
271 in
272 Just (union { Docs.unionCases = publicTags })