git.iko.soy/elk
on 4bec310 help sign in
elk/compiler/Docs.hs
187 lines 6.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 Data.Aeson
13import Data.Aeson.Encode.Pretty
14import qualified Data.List as List
15import qualified Data.Map as Map
16import qualified Data.ByteString.Lazy as BS
17import qualified Data.Text as Text
19import qualified SourceSyntax.Helpers as Help
20import qualified SourceSyntax.Type as T
21import qualified SourceSyntax.Expression as E
22import qualified SourceSyntax.Declaration as D
24import Text.Parsec hiding (newline,spaces)
25import Parse.Declaration (alias,datatype,infixDecl)
26import Parse.Expression (typeAnnotation)
27import Parse.Helpers
28import Parse.Module (moduleDef)
30data Flags = Flags
31 { files :: [FilePath] }
32 deriving (Data,Typeable,Show,Eq)
34defaultFlags :: Flags
35defaultFlags = Flags
36 { files = def &= args &= typ "FILES"
37 } &= help "Generate documentation for Elm"
38 &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
40main :: IO ()
41main = do
42 flags <- cmdArgs defaultFlags
43 mapM_ parseFile (files flags)
45config :: Config
46config = Config { confIndent = 2, confCompare = keyOrder keys }
47 where
48 keys = ["tag","name","document","comment","raw","aliases","datatypes"
49 ,"values","typeVariables","type","constructors"]
51parseFile :: FilePath -> IO ()
52parseFile path = do
53 source <- readFile path
54 case iParse docs source of
55 Right json -> do
56 putStrLn $ "Documenting " ++ path
57 let docPath = "docs" </> replaceExtension path ".json"
58 createDirectoryIfMissing True (dropFileName docPath)
59 BS.writeFile docPath (encodePretty' config json)
60 Left err -> do
61 hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
62 exitFailure
64docs :: IParser Value
65docs = do
66 (name, exports, structure) <- moduleDocs
67 things <- document
68 return $ documentToJson name exports structure things
70docComment :: IParser String
71docComment = do
72 try (string "{-|")
73 contents <- closeComment
74 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
75 return $ dropWhile (==' ') (reverse reversed)
77moduleDocs :: IParser (String, [String], String)
78moduleDocs = do
79 optional freshLine
80 (names,exports) <- moduleDef
81 manyTill (string " " <|> newline <?> "more whitespace")
82 (lookAhead (string "{-|") <?> "module documentation comment")
83 structure <- docComment
84 return (List.intercalate "." names, exports, structure)
86document :: IParser [(String, D.ParseDeclaration, String)]
87document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
89docThing :: IParser (String, D.ParseDeclaration, String)
90docThing = uncommentable <|> commented <|> uncommented ""
91 where
92 uncommentable = do
93 ifx <- infixDecl
94 return ("", ifx, "")
96 commented = do
97 comment <- docComment
98 freshLine
99 uncommented comment
101 uncommented comment = do
102 (src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]
103 return (comment, def, src)
106documentToJson name exports structure things =
107 object $ [ "name" .= name
108 , "document" .= structure
109 , "values" .= toList values
110 , "aliases" .= toList aliases
111 , "datatypes" .= toList adts
112 ]
113 where
114 (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things
116 toList dict = map object . Map.elems $ filterPublics dict
118 exportMap = Map.fromList (zip exports exports)
119 filterPublics dict =
120 case Map.null exportMap of
121 True -> dict
122 False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
124collect infixes types aliases adts things =
125 case things of
126 [] -> (Map.union customOps nonCustomOps, aliases, adts)
127 where
128 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
129 addDefaultInfix name pairs
130 | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
131 | otherwise = pairs
133 customOps = Map.intersectionWith addInfix infixes types
134 addInfix (assoc,prec) pairs =
135 [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
137 (comment, decl, source) : rest ->
138 case decl of
139 D.Fixity assoc prec name ->
140 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
141 D.Definition (E.TypeAnnotation name tipe) ->
142 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
143 D.TypeAlias name vars tipe ->
144 let fields = ["typeVariables" .= vars, "type" .= tipe ]
145 in collect infixes types (insert name fields aliases) adts rest
146 D.Datatype name vars ctors ->
147 let tipe = T.Data name (map T.Var vars)
148 fields = ["typeVariables" .= vars
149 , "constructors" .= map (ctorToJson tipe) ctors ]
150 in collect infixes types aliases (insert name fields adts) rest
151 where
152 insert name fields dict = Map.insert name (obj name fields) dict
153 obj name fields =
154 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
156instance ToJSON T.Type where
157 toJSON tipe =
158 object $
159 case tipe of
160 T.Lambda _ _ ->
161 let tipes = T.collectLambdas tipe in
162 [ "tag" .= ("function" :: Text.Text)
163 , "args" .= toJSON (init tipes)
164 , "result" .= toJSON (last tipes)
165 ]
167 T.Var x ->
168 [ "tag" .= ("var" :: Text.Text)
169 , "name" .= toJSON x
170 ]
172 T.Data name ts ->
173 [ "tag" .= ("adt" :: Text.Text)
174 , "name" .= toJSON name
175 , "args" .= map toJSON ts
176 ]
178 T.Record fields ext ->
179 [ "tag" .= ("record" :: Text.Text)
180 , "fields" .= toJSON (map (toJSON . second toJSON) fields)
181 , "extension" .= toJSON ext
182 ]
184ctorToJson :: T.Type -> (String, [T.Type]) -> Value
185ctorToJson tipe (ctor, tipes) =
186 object [ "name" .= ctor
187 , "type" .= foldr T.Lambda tipe tipes ]