git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Docs.hs
167 lines 6.0 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 qualified SourceSyntax.Expression as E
21import qualified SourceSyntax.Declaration as D
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, D.ParseDeclaration, String)]
81document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
83docThing :: IParser (String, D.ParseDeclaration, 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, D.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 (D.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 D.Fixity assoc prec name ->
134 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
135 D.Definition (E.TypeAnnotation name tipe) ->
136 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
137 D.TypeAlias name vars tipe derivations ->
138 let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]
139 in collect infixes types (insert name fields aliases) adts rest
140 D.Datatype name vars ctors derivations ->
141 let tipe = Data name (map Var vars)
142 fields = ["typeVariables" .= vars
143 , "constructors" .= map (ctorToJson tipe) ctors
144 , "deriving" .= derivations ]
145 in collect infixes types aliases (insert name fields adts) rest
146 where
147 insert name fields dict = Map.insert name (obj name fields) dict
148 obj name fields =
149 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
151instance ToJSON Type where
152 toJSON tipe =
153 case tipe of
154 Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
155 Var x -> toJSON x
156 Data name ts -> toJSON (toJSON name : map toJSON ts)
157 Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
158 where fields' = case ext of
159 Nothing -> fields
160 Just x -> ("_", Var x) : fields
162ctorToJson tipe (ctor, tipes) =
163 object [ "name" .= ctor
164 , "type" .= foldr Lambda tipe tipes ]
166instance ToJSON D.Derivation where
167 toJSON = toJSON . show