git.iko.soy/elk
on 96dfd88 help sign in
elk/src/Docs.hs
202 lines 5.6 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.Declaration as Decl
17import qualified AST.Expression.Source as Source
19import Text.Parsec hiding (newline, spaces)
20import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
21import qualified Parse.Expression as Parse (typeAnnotation)
22import qualified Parse.Helpers as Parse
23import qualified Parse.Module as Parse (header)
24import qualified Elm.Compiler.Module as Module
25import qualified Elm.Compiler.Type.Extract as Type
26import qualified Elm.Docs as Docs
29-- FLAGS
31data Flags = Flags
32 { input :: FilePath
33 , output :: Maybe FilePath
34 }
35 deriving (Data,Typeable,Show,Eq)
38defaultFlags :: Flags
39defaultFlags = Flags
40 { input = def &= args &= typ "FILE"
42 , output = Nothing &= typFile
43 &= help "file name for generated JSON documentation"
45 } &= help "Generate documentation for Elm"
46 &= summary "Generate documentation for Elm, (c) Evan Czaplicki"
49-- GENERATE DOCUMENTATION
51main :: IO ()
52main =
53 do flags <- cmdArgs defaultFlags
54 source <- readFile (input flags)
55 case Parse.iParse documentation source of
56 Right docs ->
57 let json = Json.encodePretty' config docs in
58 case output flags of
59 Nothing -> BS.putStrLn json
60 Just docPath ->
61 do createDirectoryIfMissing True (dropFileName docPath)
62 BS.writeFile docPath json
64 Left err ->
65 do hPutStrLn stderr (show err)
66 exitFailure
69config :: Json.Config
70config =
71 Json.Config
72 { Json.confIndent = 2
73 , Json.confCompare = Json.keyOrder keys
74 }
75 where
76 keys =
77 [ "tag", "name", "comment", "aliases", "types"
78 , "values", "func", "args", "type", "cases"
79 ]
82-- PARSE DOCUMENTATION
84documentation :: Parse.IParser Docs.Documentation
85documentation =
86 do optional Parse.freshLine
87 (names, _exports) <- Parse.header
89 manyTill (string " " <|> Parse.newline <?> "more whitespace")
90 (lookAhead (string "{-|") <?> "module documentation comment")
92 overview <- docComment
94 decls <- allDeclarations
96 let (aliases, unions, values) = categorizeDeclarations decls
98 return (Docs.Documentation (Module.Name names) overview aliases unions values)
101docComment :: Parse.IParser String
102docComment =
103 do try (string "{-|")
104 contents <- Parse.closeComment
106 let reversed =
107 dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
109 return $ dropWhile (==' ') (reverse reversed)
112allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)]
113allDeclarations =
114 Parse.onFreshLines (:) [] declaration
117declaration :: Parse.IParser (String, Decl.SourceDecl)
118declaration =
119 uncommentable <|> commented <|> uncommented ""
120 where
121 uncommentable =
122 (,) "" <$> Parse.infixDecl
124 commented =
125 do comment <- docComment
126 Parse.freshLine
127 uncommented comment
129 uncommented comment =
130 (,) comment
131 <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ]
134-- CATEGORIZE DECLARATIONS
136data CategoryInfo = CategoryInfo
137 { aliases :: [Docs.Alias]
138 , unions :: [Docs.Union]
139 , values :: Map.Map String Docs.Value
140 , infixes :: Map.Map String (String, Int)
141 }
144emptyInfo :: CategoryInfo
145emptyInfo =
146 CategoryInfo [] [] Map.empty Map.empty
149categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value])
150categorizeDeclarations decls =
151 (aliases, unions, Map.elems values)
152 where
153 (CategoryInfo aliases unions rawValues infixes) =
154 foldr collectInfo emptyInfo decls
156 values =
157 Map.union
158 (Map.intersectionWith addInfixInfo rawValues infixes)
159 rawValues
162addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value
163addInfixInfo value infixInfo =
164 value { Docs.valueAssocPrec = Just infixInfo }
167collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo
168collectInfo (comment, decl) info =
169 case decl of
170 Decl.Definition def ->
171 case def of
172 Source.Definition _ _ -> error errorMessage
173 Source.TypeAnnotation name tipe ->
174 let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing
175 in
176 info { values = Map.insert name value (values info) }
178 Decl.Datatype name args cases ->
179 let cases' = map (second (map Type.fromInternalType)) cases
180 union = Docs.Union name comment args cases'
181 in
182 info { unions = union : unions info }
184 Decl.TypeAlias name args tipe ->
185 let alias = Docs.Alias name comment args (Type.fromInternalType tipe)
186 in
187 info { aliases = alias : aliases info }
189 Decl.Fixity assoc prec name ->
190 let infixInfo = (Decl.assocToString assoc, prec)
191 in
192 info { infixes = Map.insert name infixInfo (infixes info) }
194 Decl.Port _ ->
195 error errorMessage
198errorMessage :: String
199errorMessage =
200 "there appears to be a bug in this tool.\n" ++
201 "Please report it to <https://github.com/elm-lang/Elm/issues>"