git.iko.soy/elk
on 2a930fd help sign in
elk/src/Docs.hs
224 lines 7.4 kB history raw
1{-# OPTIONS_GHC -W #-}
2{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
3module Main where
5import System.Console.CmdArgs
6import System.Directory
7import System.FilePath
8import System.Exit
9import System.IO
11import Control.Applicative ((<$>))
12import Control.Arrow (second)
13import Data.Aeson
14import Data.Aeson.Encode.Pretty
15import Data.Aeson.Types (Pair)
16import qualified Data.List as List
17import qualified Data.Map as Map
18import qualified Data.ByteString.Lazy as BS
19import qualified Data.Text as Text
21import qualified AST.Helpers as Help
22import qualified AST.Type as T
23import qualified AST.Declaration as D
24import qualified AST.Expression.Source as Src
25import qualified AST.Variable as Var
27import Text.Parsec hiding (newline,spaces)
28import Parse.Declaration (typeDecl,infixDecl)
29import Parse.Expression (typeAnnotation)
30import Parse.Helpers
31import qualified Parse.Module as Module
33data Flags = Flags
34 { files :: [FilePath] }
35 deriving (Data,Typeable,Show,Eq)
37defaultFlags :: Flags
38defaultFlags = Flags
39 { files = def &= args &= typ "FILES"
40 } &= help "Generate documentation for Elm"
41 &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
43main :: IO ()
44main = do
45 flags <- cmdArgs defaultFlags
46 mapM_ parseFile (files flags)
48config :: Config
49config = Config { confIndent = 2, confCompare = keyOrder keys }
50 where
51 keys = ["tag","name","document","comment","raw","aliases","datatypes"
52 ,"values","typeVariables","type","constructors"]
54parseFile :: FilePath -> IO ()
55parseFile path = do
56 source <- readFile path
57 case iParse docs source of
58 Right json -> do
59 putStrLn $ "Documenting " ++ path
60 let docPath = "docs" </> replaceExtension path ".json"
61 createDirectoryIfMissing True (dropFileName docPath)
62 BS.writeFile docPath (encodePretty' config json)
63 Left err -> do
64 hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
65 exitFailure
67docs :: IParser Value
68docs = do
69 (name, _exports, structure) <- moduleDocs
70 things <- document
71 return $ documentToJson name structure things
73docComment :: IParser String
74docComment = do
75 try (string "{-|")
76 contents <- closeComment
77 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
78 return $ dropWhile (==' ') (reverse reversed)
80moduleDocs :: IParser (String, Var.Listing Var.Value, String)
81moduleDocs = do
82 optional freshLine
83 (names,exports) <- Module.header
84 manyTill (string " " <|> newline <?> "more whitespace")
85 (lookAhead (string "{-|") <?> "module documentation comment")
86 structure <- docComment
87 return (List.intercalate "." names, exports, structure)
89document :: IParser [(String, D.SourceDecl, String)]
90document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
92docThing :: IParser (String, D.SourceDecl, String)
93docThing = uncommentable <|> commented <|> uncommented ""
94 where
95 uncommentable = do
96 ifx <- infixDecl
97 return ("", ifx, "")
99 commented = do
100 comment <- docComment
101 freshLine
102 uncommented comment
104 uncommented comment = do
105 (src,def) <- withSource $ choice [ typeDecl, D.Definition <$> typeAnnotation ]
106 return (comment, def, src)
109documentToJson :: String -> String -> [(String, D.SourceDecl, String)] -> Value
110documentToJson name structure things =
111 object
112 [ "name" .= name
113 , "document" .= structure
114 , "values" .= toList values
115 , "aliases" .= toList aliases
116 , "datatypes" .= toList adts
117 ]
118 where
119 (values, aliases, adts) =
120 collect Map.empty Map.empty Map.empty Map.empty things
122 toList :: Map.Map String [Pair] -> [Value]
123 toList dict =
124 map object (Map.elems dict)
126type Pairs = Map.Map String [Pair]
128collect :: Map.Map String (D.Assoc, Int) -> Pairs -> Pairs -> Pairs
129 -> [(String, D.SourceDecl, String)]
130 -> (Pairs, Pairs, Pairs)
131collect infixes types aliases adts things =
132 case things of
133 [] -> (Map.union customOps nonCustomOps, aliases, adts)
134 where
135 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
136 addDefaultInfix name pairs
137 | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
138 | otherwise = pairs
140 customOps = Map.intersectionWith addInfix infixes types
141 addInfix (assoc,prec) pairs =
142 [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
144 (comment, decl, source) : rest ->
145 let insert name fields dict = Map.insert name (obj name fields) dict
146 obj name fields =
147 [ "name" .= name
148 , "raw" .= source
149 , "comment" .= comment
150 ] ++ fields
151 in
152 case decl of
153 D.Definition def ->
154 case def of
155 Src.TypeAnnotation name tipe ->
156 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
158 Src.Definition _ _ ->
159 collect infixes types aliases adts rest
161 D.Datatype name vars ctors ->
162 let tipe = T.App (T.Type (Var.Raw name)) (map T.Var vars)
163 fields = [ "typeVariables" .= vars
164 , "constructors" .= map (ctorToJson tipe) ctors
165 ]
166 in collect infixes types aliases (insert name fields adts) rest
168 D.TypeAlias name vars tipe ->
169 let fields = [ "typeVariables" .= vars, "type" .= tipe ]
170 in collect infixes types (insert name fields aliases) adts rest
172 D.Port _ ->
173 collect infixes types aliases adts rest
175 D.Fixity assoc prec name ->
176 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
179instance Var.ToString var => ToJSON (T.Type var) where
180 toJSON tipe =
181 object (getFields tipe)
182 where
183 getFields tipe =
184 case tipe of
185 T.Lambda _ _ ->
186 let tipes = T.collectLambdas tipe in
187 [ "tag" .= ("function" :: Text.Text)
188 , "args" .= toJSON (init tipes)
189 , "result" .= toJSON (last tipes)
190 ]
192 T.Var x ->
193 [ "tag" .= ("var" :: Text.Text)
194 , "name" .= toJSON x
195 ]
197 T.Type name ->
198 [ "tag" .= ("adt" :: Text.Text)
199 , "name" .= toJSON (Var.toString name)
200 , "args" .= ([] :: [()])
201 ]
203 T.App (T.Type name) ts ->
204 [ "tag" .= ("adt" :: Text.Text)
205 , "name" .= toJSON (Var.toString name)
206 , "args" .= map toJSON ts
207 ]
209 T.App _ _ -> error "This is an unexpected error with elm-doc, please report it at <https://github.com/elm-lang/Elm/issues>"
211 T.Record fields ext ->
212 [ "tag" .= ("record" :: Text.Text)
213 , "fields" .= toJSON (map (toJSON . second toJSON) fields)
214 , "extension" .= toJSON ext
215 ]
217 T.Aliased _ t ->
218 getFields t
220ctorToJson :: T.RawType -> (String, [T.RawType]) -> Value
221ctorToJson tipe (ctor, tipes) =
222 object [ "name" .= ctor
223 , "type" .= foldr T.Lambda tipe tipes
224 ]