git.iko.soy/elk
on ab53fac help sign in
elk/compiler/Docs.hs
163 lines 5.8 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 Data.Aeson
12import Data.Aeson.Encode.Pretty
13import qualified Data.List as List
14import qualified Data.Map as Map
15import qualified Data.ByteString.Lazy as BS
16import qualified Data.Text as Text
18import SourceSyntax.Helpers (isSymbol)
19import SourceSyntax.Type (Type(..))
20import SourceSyntax.Declaration (Declaration(..), Assoc(..))
21import SourceSyntax.Expression (Def(..))
23import Text.Parsec hiding (newline,spaces)
24import Parse.Declaration (alias,datatype,infixDecl)
25import Parse.Expression (typeAnnotation)
26import Parse.Helpers
27import Parse.Module (moduleDef)
29data Flags = Flags
30 { files :: [FilePath] }
31 deriving (Data,Typeable,Show,Eq)
33defaultFlags = Flags
34 { files = def &= args &= typ "FILES"
35 } &= help "Generate documentation for Elm"
36 &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
38main = do
39 flags <- cmdArgs defaultFlags
40 mapM parseFile (files flags)
42config = Config { confIndent = 2, confCompare = keyOrder keys }
43 where
44 keys = ["name","document","comment","raw","aliases","datatypes"
45 ,"values","typeVariables","type","constructors"]
47parseFile path = do
48 source <- readFile path
49 case iParse docs source of
50 Right json -> do
51 putStrLn $ "Documenting " ++ path
52 let docPath = "docs" </> replaceExtension path ".json"
53 createDirectoryIfMissing True (dropFileName docPath)
54 BS.writeFile docPath (encodePretty' config json)
55 Left err -> do
56 hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
57 exitFailure
59docs :: IParser Value
60docs = do
61 (name, exports, structure) <- moduleDocs
62 things <- document
63 return $ documentToJson name exports structure things
65docComment :: IParser String
66docComment = do
67 try (string "{-|")
68 contents <- closeComment
69 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
70 return $ dropWhile (==' ') (reverse reversed)
72moduleDocs = do
73 optional freshLine
74 (names,exports) <- moduleDef
75 manyTill (string " " <|> newline <?> "more whitespace")
76 (lookAhead (string "{-|") <?> "module documentation comment")
77 structure <- docComment
78 return (List.intercalate "." names, exports, structure)
80document :: IParser [(String, Declaration t v, String)]
81document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
83docThing :: IParser (String, Declaration t v, String)
84docThing = uncommentable <|> commented <|> uncommented ""
85 where
86 uncommentable = do
87 ifx <- infixDecl
88 return ("", ifx, "")
90 commented = do
91 comment <- docComment
92 freshLine
93 uncommented comment
95 uncommented comment = do
96 (src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]
97 return (comment, def, src)
100documentToJson name exports structure things =
101 object $ [ "name" .= name
102 , "document" .= structure
103 , "values" .= toList values
104 , "aliases" .= toList aliases
105 , "datatypes" .= toList adts
106 ]
107 where
108 (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things
110 toList dict = map object . Map.elems $ filterPublics dict
112 exportMap = Map.fromList (zip exports exports)
113 filterPublics dict =
114 case Map.null exportMap of
115 True -> dict
116 False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
118collect infixes types aliases adts things =
119 case things of
120 [] -> (Map.union customOps nonCustomOps, aliases, adts)
121 where
122 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
123 addDefaultInfix name pairs
124 | all isSymbol name = addInfix (L, 9 :: Int) pairs
125 | otherwise = pairs
127 customOps = Map.intersectionWith addInfix infixes types
128 addInfix (assoc,prec) pairs =
129 [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
131 (comment, decl, source) : rest ->
132 case decl of
133 Fixity assoc prec name ->
134 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
135 Definition (TypeAnnotation name tipe) ->
136 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
137 TypeAlias name vars tipe ->
138 let fields = ["typeVariables" .= vars, "type" .= tipe ]
139 in collect infixes types (insert name fields aliases) adts rest
140 Datatype name vars ctors ->
141 let tipe = Data name (map Var vars)
142 fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]
143 in collect infixes types aliases (insert name fields adts) rest
144 where
145 insert name fields dict = Map.insert name (obj name fields) dict
146 obj name fields =
147 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
149instance ToJSON Type where
150 toJSON tipe =
151 case tipe of
152 Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
153 Var x -> toJSON x
154 Data name ts -> toJSON (toJSON name : map toJSON ts)
155 EmptyRecord -> object []
156 Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
157 where fields' = case ext of
158 EmptyRecord -> fields
159 _ -> ("_",ext) : fields
161ctorToJson tipe (ctor, tipes) =
162 object [ "name" .= ctor
163 , "type" .= foldr Lambda tipe tipes ]