git.iko.soy/elk
on fdcaaed help sign in
elk/src/Docs.hs
229 lines 6.1 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.Map as Map
14import qualified Data.ByteString.Lazy.Char8 as BS
16import qualified AST.Type as Type
17import qualified AST.Declaration as Decl
18import qualified AST.Expression.Source as Source
19import qualified AST.Variable as Var
21import Text.Parsec hiding (newline, spaces)
22import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
23import qualified Parse.Expression as Parse (typeAnnotation)
24import qualified Parse.Helpers as Parse
25import qualified Parse.Module as Parse (header)
26import qualified Elm.Compiler.Module as Module
27import qualified Elm.Docs as Docs
30-- FLAGS
32data Flags = Flags
33 { input :: FilePath
34 , output :: Maybe FilePath
35 }
36 deriving (Data,Typeable,Show,Eq)
39defaultFlags :: Flags
40defaultFlags = Flags
41 { input = def &= args &= typ "FILE"
43 , output = Nothing &= typFile
44 &= help "file name for generated JSON documentation"
46 } &= help "Generate documentation for Elm"
47 &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
50-- GENERATE DOCUMENTATION
52main :: IO ()
53main =
54 do flags <- cmdArgs defaultFlags
55 source <- readFile (input flags)
56 case Parse.iParse documentation source of
57 Right docs ->
58 let json = Json.encodePretty' config docs in
59 case output flags of
60 Nothing -> BS.putStrLn json
61 Just docPath ->
62 do createDirectoryIfMissing True (dropFileName docPath)
63 BS.writeFile docPath json
65 Left err ->
66 do hPutStrLn stderr (show err)
67 exitFailure
70config :: Json.Config
71config =
72 Json.Config
73 { Json.confIndent = 2
74 , Json.confCompare = Json.keyOrder keys
75 }
76 where
77 keys =
78 [ "tag", "name", "comment", "aliases", "types"
79 , "values", "func", "args", "type", "cases"
80 ]
83-- PARSE DOCUMENTATION
85documentation :: Parse.IParser Docs.Documentation
86documentation =
87 do optional Parse.freshLine
88 (names, _exports) <- Parse.header
90 manyTill (string " " <|> Parse.newline <?> "more whitespace")
91 (lookAhead (string "{-|") <?> "module documentation comment")
93 overview <- docComment
95 decls <- allDeclarations
97 let (aliases, unions, values) = categorizeDeclarations decls
99 return (Docs.Documentation (Module.Name names) overview aliases unions values)
102docComment :: Parse.IParser String
103docComment =
104 do try (string "{-|")
105 contents <- Parse.closeComment
107 let reversed =
108 dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
110 return $ dropWhile (==' ') (reverse reversed)
113allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
114allDeclarations =
115 Parse.onFreshLines (:) [] declaration
118declaration :: Parse.IParser (String, Decl.SourceDecl)
119declaration =
120 uncommentable <|> commented <|> uncommented ""
121 where
122 uncommentable =
123 (,) "" <$> Parse.infixDecl
125 commented =
126 do comment <- docComment
127 Parse.freshLine
128 uncommented comment
130 uncommented comment =
131 (,) comment
132 <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
135-- CATEGORIZE DECLARATIONS
137data CategoryInfo = CategoryInfo
138 { aliases :: [Docs.Alias]
139 , unions :: [Docs.Union]
140 , values :: Map.Map String Docs.Value
141 , infixes :: Map.Map String (String, Int)
142 }
145emptyInfo :: CategoryInfo
146emptyInfo =
147 CategoryInfo [] [] Map.empty Map.empty
150categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
151categorizeDeclarations decls =
152 (aliases, unions, Map.elems values)
153 where
154 (CategoryInfo aliases unions rawValues infixes) =
155 foldr collectInfo emptyInfo decls
157 values =
158 Map.union
159 (Map.intersectionWith addInfixInfo rawValues infixes)
160 rawValues
163addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
164addInfixInfo value infixInfo =
165 value { Docs.valueAssocPrec = Just infixInfo }
168collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
169collectInfo (comment, decl) info =
170 case decl of
171 Decl.Definition def ->
172 case def of
173 Source.Definition _ _ -> error errorMessage
174 Source.TypeAnnotation name tipe ->
175 let value = Docs.Value name comment (toDocType tipe) Nothing
176 in
177 info { values = Map.insert name value (values info) }
179 Decl.Datatype name args cases ->
180 let cases' = map (second (map toDocType)) cases
181 union = Docs.Union name comment args cases'
182 in
183 info { unions = union : unions info }
185 Decl.TypeAlias name args tipe ->
186 let alias = Docs.Alias name comment args (toDocType tipe)
187 in
188 info { aliases = alias : aliases info }
190 Decl.Fixity assoc prec name ->
191 let infixInfo = (Decl.assocToString assoc, prec)
192 in
193 info { infixes = Map.insert name infixInfo (infixes info) }
195 Decl.Port _ ->
196 error errorMessage
199errorMessage :: String
200errorMessage =
201 "there appears to be a bug in this tool.\n" ++
202 "Please report it to <https://github.com/elm-lang/Elm/issues>"
205-- AST TYPE TO DOC TYPE
207toDocType :: Type.Type Var.Raw -> Docs.Type
208toDocType astType =
209 case astType of
210 Type.Lambda t1 t2 ->
211 Docs.Lambda (toDocType t1) (toDocType t2)
213 Type.Var x ->
214 Docs.Var x
216 Type.Type (Var.Raw name) ->
217 Docs.Type name
219 Type.App t ts ->
220 Docs.App (toDocType t) (map toDocType ts)
222 Type.Record fields ext ->
223 Docs.Record (map (second toDocType) fields) (fmap toDocType ext)
225 Type.Aliased _ t ->
226 toDocType t