git.iko.soy/elk
on 9b0c310 help sign in
elk/src/Docs.hs
275 lines 7.8 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")
220errorMessage :: String -> String
221errorMessage name =
222 "Unable to deal with annotations on " ++ name ++ " at this time.\n" ++
223 "Please report your use case to <https://github.com/elm-lang/elm-compiler/issues>"
226-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS
228filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value]
229filterValues (Var.Listing exports open) values =
230 case open of
231 True -> values
232 False ->
233 let names =
234 Set.fromList (Var.getValues exports)
235 in
236 filter (\value -> Set.member (Docs.valueName value) names) values
239filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias]
240filterAliases (Var.Listing exports open) aliases =
241 case open of
242 True -> aliases
243 False ->
244 let names =
245 Set.fromList (Var.getAliases exports)
246 in
247 filter (\value -> Set.member (Docs.aliasName value) names) aliases
250filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union]
251filterUnions (Var.Listing exports open) unions =
252 case open of
253 True -> unions
254 False ->
255 Maybe.mapMaybe (filterUnion exportedUnions) unions
256 where
257 exportedUnions =
258 Map.fromList (Var.getUnions exports)
261filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union
262filterUnion exportedUnions union =
263 case Map.lookup (Docs.unionName union) exportedUnions of
264 Nothing ->
265 Nothing
267 Just (Var.Listing tags unionOpen)
268 | unionOpen ->
269 Just union
270 | otherwise ->
271 let publicTags =
272 filter (\(tag, _) -> tag `elem` tags) (Docs.unionCases union)
273 in
274 Just (union { Docs.unionCases = publicTags })