@@ -1,275 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
2−module Main where
3−
4−import System.Console.CmdArgs
5−import System.Directory
6−import System.FilePath
7−import System.Exit
8−import System.IO
9−
10−import Control.Applicative ((<$>))
11−import Control.Arrow (second)
12−import Control.Monad (when)
13−import qualified Data.Aeson.Encode.Pretty as Json
14−import qualified Data.ByteString.Lazy.Char8 as BS
15−import qualified Data.Map as Map
16−import qualified Data.Maybe as Maybe
17−import qualified Data.Set as Set
18−
19−import qualified AST.Declaration as Decl
20−import qualified AST.Expression.Source as Source
21−import qualified AST.Variable as Var
22−
23−import Text.Parsec hiding (newline, spaces)
24−import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
25−import qualified Parse.Expression as Parse (typeAnnotation)
26−import qualified Parse.Helpers as Parse
27−import qualified Parse.Module as Parse (header)
28−import qualified Elm.Compiler.Module as Module
29−import qualified Elm.Compiler.Type.Extract as Type
30−import qualified Elm.Docs as Docs
31−
32−
33−-- FLAGS
34−
35−data Flags = Flags
36− { input :: FilePath
37− , output :: Maybe FilePath
38− }
39− deriving (Data,Typeable,Show,Eq)
40−
41−
42−defaultFlags :: Flags
43−defaultFlags = Flags
44− { input = def &= args &= typ "FILE"
45−
46− , output = Nothing &= typFile
47− &= help "file name for generated JSON documentation"
48−
49− } &= help "Generate documentation for Elm"
50− &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
51−
52−
53−-- GENERATE DOCUMENTATION
54−
55−main :: IO ()
56−main =
57− do flags <- cmdArgs defaultFlags
58− let inputFileName = input flags
59−
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
67−
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
77−
78− Left err ->
79− do hPutStrLn stderr (show err)
80− exitFailure
81−
82−
83−config :: Json.Config
84−config =
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− ]
94−
95−
96−-- PARSE DOCUMENTATION
97−
98−documentation :: Parse.IParser Docs.Documentation
99−documentation =
100− do optional Parse.freshLine
101− (names, exports) <- Parse.header
102−
103− manyTill (string " " <|> Parse.newline <?> "more whitespace")
104− (lookAhead (string "{-|") <?> "module documentation comment")
105−
106− overview <- docComment
107−
108− decls <- allDeclarations
109−
110− let (aliases, unions, values) = categorizeDeclarations decls
111−
112− return $
113− Docs.Documentation
114− (Module.Name names)
115− overview
116− (filterAliases exports aliases)
117− (filterUnions exports unions)
118− (filterValues exports values)
119−
120−
121−docComment :: Parse.IParser String
122−docComment =
123− do try (string "{-|")
124− contents <- Parse.closeComment
125−
126− let reversed =
127− dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
128−
129− return $ dropWhile (==' ') (reverse reversed)
130−
131−
132−allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
133−allDeclarations =
134− Parse.onFreshLines (:) [] declaration
135−
136−
137−declaration :: Parse.IParser (String, Decl.SourceDecl)
138−declaration =
139− uncommentable <|> commented <|> uncommented ""
140− where
141− uncommentable =
142− (,) "" <$> Parse.infixDecl
143−
144− commented =
145− do comment <- docComment
146− Parse.freshLine
147− uncommented comment
148−
149− uncommented comment =
150− (,) comment
151− <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
152−
153−
154−-- CATEGORIZE DECLARATIONS
155−
156−data 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− }
162−
163−
164−emptyInfo :: CategoryInfo
165−emptyInfo =
166− CategoryInfo [] [] Map.empty Map.empty
167−
168−
169−categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
170−categorizeDeclarations decls =
171− (aliases, unions, Map.elems values)
172− where
173− (CategoryInfo aliases unions rawValues infixes) =
174− foldr collectInfo emptyInfo decls
175−
176− values =
177− Map.union
178− (Map.intersectionWith addInfixInfo rawValues infixes)
179− rawValues
180−
181−
182−addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
183−addInfixInfo value infixInfo =
184− value { Docs.valueAssocPrec = Just infixInfo }
185−
186−
187−collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
188−collectInfo (comment, decl) info =
189− case decl of
190− Decl.Definition def ->
191− case def of
192− Source.Definition _ _ ->
193− error (errorMessage "unannotated definitions")
194−
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) }
199−
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 }
205−
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 }
210−
211− Decl.Fixity assoc prec name ->
212− let infixInfo = (Decl.assocToString assoc, prec)
213− in
214− info { infixes = Map.insert name infixInfo (infixes info) }
215−
216− Decl.Port _ ->
217− error (errorMessage "ports")
218−
219−
220−errorMessage :: String -> String
221−errorMessage 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>"
224−
225−
226−-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS
227−
228−filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value]
229−filterValues (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
237−
238−
239−filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias]
240−filterAliases (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
248−
249−
250−filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union]
251−filterUnions (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)
259−
260−
261−filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union
262−filterUnion exportedUnions union =
263− case Map.lookup (Docs.unionName union) exportedUnions of
264− Nothing ->
265− Nothing
266−
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 })
275−