git.iko.soy/elk
on 2ec798e help sign in
elk/src/Docs.hs
262 lines 7.3 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 qualified Data.Aeson.Encode.Pretty as Json
13import qualified Data.ByteString.Lazy.Char8 as BS
14import qualified Data.Map as Map
15import qualified Data.Maybe as Maybe
16import qualified Data.Set as Set
18import qualified AST.Declaration as Decl
19import qualified AST.Expression.Source as Source
20import qualified AST.Variable as Var
22import Text.Parsec hiding (newline, spaces)
23import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
24import qualified Parse.Expression as Parse (typeAnnotation)
25import qualified Parse.Helpers as Parse
26import qualified Parse.Module as Parse (header)
27import qualified Elm.Compiler.Module as Module
28import qualified Elm.Compiler.Type.Extract as Type
29import qualified Elm.Docs as Docs
32-- FLAGS
34data Flags = Flags
35 { input :: FilePath
36 , output :: Maybe FilePath
37 }
38 deriving (Data,Typeable,Show,Eq)
41defaultFlags :: Flags
42defaultFlags = Flags
43 { input = def &= args &= typ "FILE"
45 , output = Nothing &= typFile
46 &= help "file name for generated JSON documentation"
48 } &= help "Generate documentation for Elm"
49 &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
52-- GENERATE DOCUMENTATION
54main :: IO ()
55main =
56 do flags <- cmdArgs defaultFlags
57 source <- readFile (input flags)
58 case Parse.iParse documentation source of
59 Right docs ->
60 let json = Json.encodePretty' config docs in
61 case output flags of
62 Nothing -> BS.putStrLn json
63 Just docPath ->
64 do createDirectoryIfMissing True (dropFileName docPath)
65 BS.writeFile docPath json
67 Left err ->
68 do hPutStrLn stderr (show err)
69 exitFailure
72config :: Json.Config
73config =
74 Json.Config
75 { Json.confIndent = 2
76 , Json.confCompare = Json.keyOrder keys
77 }
78 where
79 keys =
80 [ "tag", "name", "comment", "aliases", "types"
81 , "values", "func", "args", "type", "cases"
82 ]
85-- PARSE DOCUMENTATION
87documentation :: Parse.IParser Docs.Documentation
88documentation =
89 do optional Parse.freshLine
90 (names, exports) <- Parse.header
92 manyTill (string " " <|> Parse.newline <?> "more whitespace")
93 (lookAhead (string "{-|") <?> "module documentation comment")
95 overview <- docComment
97 decls <- allDeclarations
99 let (aliases, unions, values) = categorizeDeclarations decls
101 return $
102 Docs.Documentation
103 (Module.Name names)
104 overview
105 (filterAliases exports aliases)
106 (filterUnions exports unions)
107 (filterValues exports values)
110docComment :: Parse.IParser String
111docComment =
112 do try (string "{-|")
113 contents <- Parse.closeComment
115 let reversed =
116 dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
118 return $ dropWhile (==' ') (reverse reversed)
121allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
122allDeclarations =
123 Parse.onFreshLines (:) [] declaration
126declaration :: Parse.IParser (String, Decl.SourceDecl)
127declaration =
128 uncommentable <|> commented <|> uncommented ""
129 where
130 uncommentable =
131 (,) "" <$> Parse.infixDecl
133 commented =
134 do comment <- docComment
135 Parse.freshLine
136 uncommented comment
138 uncommented comment =
139 (,) comment
140 <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
143-- CATEGORIZE DECLARATIONS
145data CategoryInfo = CategoryInfo
146 { aliases :: [Docs.Alias]
147 , unions :: [Docs.Union]
148 , values :: Map.Map String Docs.Value
149 , infixes :: Map.Map String (String, Int)
150 }
153emptyInfo :: CategoryInfo
154emptyInfo =
155 CategoryInfo [] [] Map.empty Map.empty
158categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
159categorizeDeclarations decls =
160 (aliases, unions, Map.elems values)
161 where
162 (CategoryInfo aliases unions rawValues infixes) =
163 foldr collectInfo emptyInfo decls
165 values =
166 Map.union
167 (Map.intersectionWith addInfixInfo rawValues infixes)
168 rawValues
171addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
172addInfixInfo value infixInfo =
173 value { Docs.valueAssocPrec = Just infixInfo }
176collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
177collectInfo (comment, decl) info =
178 case decl of
179 Decl.Definition def ->
180 case def of
181 Source.Definition _ _ -> error errorMessage
182 Source.TypeAnnotation name tipe ->
183 let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing
184 in
185 info { values = Map.insert name value (values info) }
187 Decl.Datatype name args cases ->
188 let cases' = map (second (map Type.fromInternalType)) cases
189 union = Docs.Union name comment args cases'
190 in
191 info { unions = union : unions info }
193 Decl.TypeAlias name args tipe ->
194 let alias = Docs.Alias name comment args (Type.fromInternalType tipe)
195 in
196 info { aliases = alias : aliases info }
198 Decl.Fixity assoc prec name ->
199 let infixInfo = (Decl.assocToString assoc, prec)
200 in
201 info { infixes = Map.insert name infixInfo (infixes info) }
203 Decl.Port _ ->
204 error errorMessage
207errorMessage :: String
208errorMessage =
209 "there appears to be a bug in this tool.\n" ++
210 "Please report it to <https://github.com/elm-lang/Elm/issues>"
213-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS
215filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value]
216filterValues (Var.Listing exports open) values =
217 case open of
218 True -> values
219 False ->
220 let names =
221 Set.fromList (Var.getValues exports)
222 in
223 filter (\value -> Set.member (Docs.valueName value) names) values
226filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias]
227filterAliases (Var.Listing exports open) aliases =
228 case open of
229 True -> aliases
230 False ->
231 let names =
232 Set.fromList (Var.getAliases exports)
233 in
234 filter (\value -> Set.member (Docs.aliasName value) names) aliases
237filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union]
238filterUnions (Var.Listing exports open) unions =
239 case open of
240 True -> unions
241 False ->
242 Maybe.mapMaybe (filterUnion exportedUnions) unions
243 where
244 exportedUnions =
245 Map.fromList (Var.getUnions exports)
248filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union
249filterUnion exportedUnions union =
250 case Map.lookup (Docs.unionName union) exportedUnions of
251 Nothing ->
252 Nothing
254 Just (Var.Listing tags unionOpen)
255 | unionOpen ->
256 Just union
257 | otherwise ->
258 let publicTags =
259 filter (\(tag, _) -> tag `elem` tags) (Docs.unionCases union)
260 in
261 Just (union { Docs.unionCases = publicTags })