git.iko.soy/elk
on 19293da help sign in
elk/src/Docs.hs
278 lines 7.9 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 _ _ ->
193 error (errorMessage "unannotated definitions")
195 Source.TypeAnnotation name tipe ->
196 let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing
197 in
198 info { values = Map.insert name value (values info) }
200 Decl.Datatype name args cases ->
201 let cases' = map (second (map Type.fromInternalType)) cases
202 union = Docs.Union name comment args cases'
203 in
204 info { unions = union : unions info }
206 Decl.TypeAlias name args tipe ->
207 let alias = Docs.Alias name comment args (Type.fromInternalType tipe)
208 in
209 info { aliases = alias : aliases info }
211 Decl.Fixity assoc prec name ->
212 let infixInfo = (Decl.assocToString assoc, prec)
213 in
214 info { infixes = Map.insert name infixInfo (infixes info) }
216 Decl.Port _ _ ->
217 error (errorMessage "ports")
219 Decl.Perform _ _ ->
220 error (errorMessage "perform declarations")
223errorMessage :: String -> String
224errorMessage name =
225 "Unable to deal with annotations on " ++ name ++ " at this time.\n" ++
226 "Please report your use case to <https://github.com/elm-lang/elm-compiler/issues>"
229-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS
231filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value]
232filterValues (Var.Listing exports open) values =
233 case open of
234 True -> values
235 False ->
236 let names =
237 Set.fromList (Var.getValues exports)
238 in
239 filter (\value -> Set.member (Docs.valueName value) names) values
242filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias]
243filterAliases (Var.Listing exports open) aliases =
244 case open of
245 True -> aliases
246 False ->
247 let names =
248 Set.fromList (Var.getAliases exports)
249 in
250 filter (\value -> Set.member (Docs.aliasName value) names) aliases
253filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union]
254filterUnions (Var.Listing exports open) unions =
255 case open of
256 True -> unions
257 False ->
258 Maybe.mapMaybe (filterUnion exportedUnions) unions
259 where
260 exportedUnions =
261 Map.fromList (Var.getUnions exports)
264filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union
265filterUnion exportedUnions union =
266 case Map.lookup (Docs.unionName union) exportedUnions of
267 Nothing ->
268 Nothing
270 Just (Var.Listing tags unionOpen)
271 | unionOpen ->
272 Just union
273 | otherwise ->
274 let publicTags =
275 filter (\(tag, _) -> tag `elem` tags) (Docs.unionCases union)
276 in
277 Just (union { Docs.unionCases = publicTags })