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