@@ -1,75 +1,140 @@
1−
1+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
22module Main where
33
4−import SourceSyntax.Declaration (Declaration(Datatype))
4+import System.Console.CmdArgs
5+import System.FilePath
6+import System.Exit
7+
58import Control.Applicative ((<$>), (<*>))
6−import Data.List (intercalate)
7−import Parse.Type
9+import Data.Aeson
10+import qualified Data.List as List
11+import qualified Data.Map as Map
12+import qualified Data.ByteString.Lazy as BS
13+
14+import SourceSyntax.Helpers (isSymbol)
15+import SourceSyntax.Declaration (Declaration(..), Assoc(..))
16+import SourceSyntax.Expression (Def(..))
17+
18+import Text.Parsec hiding (newline,spaces)
19+import Parse.Declaration (alias,datatype,infixDecl)
20+import Parse.Expression (typeAnnotation)
821import Parse.Helpers
922import Parse.Module (moduleDef)
10−import Text.Parsec hiding (newline,spaces)
11−import System.Environment
12−import System.Exit
23+
24+data Flags = Flags
25+ { files :: [FilePath] }
26+ deriving (Data,Typeable,Show,Eq)
27+
28+defaultFlags = Flags
29+ { files = def &= args &= typ "FILES"
30+ } &= help "Generate documentation for Elm"
31+ &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
1332
1433main = do
15− srcs <- mapM readFile =<< getArgs
16− case mapM docParse srcs of
17− Left err -> putStrLn err >> exitFailure
18− Right ms -> putStrLn (toModules ms)
19−
20−toModules ms = wrap (intercalate ",\n " (map toModule ms))
21− where wrap s = "{ \"modules\" : [\n " ++ s ++ "\n ]\n}"
22−
23−toModule (name, values) =
24− "{ \"name\" : " ++ show name ++ ",\n " ++
25− "\"values\" : [\n " ++ vs ++ "\n ]\n }"
26− where vs = intercalate ",\n " (map toValue values)
27−
28−toValue (name, tipe, desc) =
29− "{ \"name\" : " ++ show name ++
30− ",\n \"type\" : " ++ show tipe ++
31− ",\n \"desc\" : " ++ show desc ++ "\n }"
32−
33−docParse :: String -> Either String (String, [(String, String, String)])
34−docParse = setupParser $ do
34+ flags <- cmdArgs defaultFlags
35+ mapM parseFile (files flags)
36+
37+parseFile path = do
38+ source <- readFile path
39+ case iParse docs "" source of
40+ Right json -> do
41+ putStrLn $ "Documenting " ++ path
42+ BS.writeFile ("docs" </> replaceExtension path ".json") (encode json)
43+ Left err -> do
44+ putStrLn $ "Parse error in " ++ path ++ " at " ++ show err
45+ exitFailure
46+
47+docs :: IParser Value
48+docs = do
3549 optional freshLine
3650 (names, exports) <- option (["Main"],[]) moduleDef
37− info <- many (try (annotation exports) <|> try skip <|> end)
38− return (intercalate "." names, concat info)
51+ chompUntilFreshLine
52+ structure <- docComment
53+ things <- document
54+ return $ toJson (List.intercalate "." names) exports structure things
55+
56+docComment :: IParser String
57+docComment = do
58+ try (string "{-|")
59+ contents <- closeComment
60+ return (init (init contents))
61+
62+document :: IParser [(String, Declaration t v, String)]
63+document = go []
3964 where
40− skip = manyTill anyChar simpleNewline >> return []
41− end = many1 anyChar >> return []
42−
43−annotation :: [String] -> IParser [(String, String, String)]
44−annotation exports =
45− do description <- comment
46− extras <- option [] (lookAhead adt)
47− varName <- try typeDef <|> name
48− varType <- tipe
49− return $ extras ++ export varName varType description
50− where
51− comment = concatMap clip <$> many lineComment
52− clip str = case str of { ' ':rest -> rest ; _ -> str } ++ "\n"
65+ go things = do
66+ thing <- optionMaybe docThing
67+ let things' = case thing of
68+ Nothing -> things
69+ Just t -> things ++ [t]
70+ done <- chompUntilFreshLine
71+ case done of
72+ True -> return things'
73+ False -> go things'
5374
54− name = do v <- lowVar <|> parens symOp
55− whitespace ; hasType ; whitespace ; return v
75+-- returns whether the end of file has been reached
76+chompUntilFreshLine :: IParser Bool
77+chompUntilFreshLine =
78+ anyThen . choice $
79+ [ try (simpleNewline >> notFollowedBy (string " ")) >> return False
80+ , eof >> return True ]
5681
57− tipe = manyTill anyChar (try (simpleNewline >> notFollowedBy (string " ")))
82+docThing :: IParser (String, Declaration t v, String)
83+docThing = uncommented <|> commented
84+ where
85+ uncommented = do
86+ ifx <- infixDecl
87+ return ("", ifx, "")
88+
89+ commented = do
90+ comment <- option "" docComment
91+ freshLine
92+ (src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]
93+ return (comment, def, src)
94+
95+
96+toJson name exports structure things =
97+ object $ [ "name" .= name
98+ , "document" .= structure
99+ , "values" .= toList values
100+ , "aliases" .= toList aliases
101+ , "datatypes" .= toList adts
102+ ]
103+ where
104+ (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things
105+
106+ toList dict = map object . Map.elems $ filterPublics dict
58107
59− export name tipe desc =
60− if null exports || name `elem` exports then [(name,tipe,desc)] else []
108+ exportMap = Map.fromList (zip exports exports)
109+ filterPublics dict =
110+ case Map.null exportMap of
111+ True -> dict
112+ False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
61113
62− typeDef = lookAhead ((string "data" <|> string "type") >> whitespace >> capVar)
114+collect infixes types aliases adts things =
115+ case things of
116+ [] -> (Map.union customOps nonCustomOps, aliases, adts)
117+ where
118+ nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
119+ addDefaultInfix name pairs
120+ | all isSymbol name = addInfix (L, 9 :: Int) pairs
121+ | otherwise = pairs
63122
64− adt = do undefined
65−{-- TODO: reimplement this
66− (Datatype name tvs constructors) <- datatype
67− let toType (cName, typeArgs) =
68− (cName, show $ foldr (==>) (kADT name $ map kVarT tvs) typeArgs, "")
69− return $ map toType constructors
70−--}
123+ customOps = Map.intersectionWith addInfix infixes types
124+ addInfix (assoc,prec) pairs =
125+ [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
71126
72−setupParser p source =
73− case iParse p "" source of
74− Right result -> Right result
75− Left err -> Left $ "Parse error at " ++ show err
127+ (comment, decl, source) : rest ->
128+ case decl of
129+ Fixity assoc prec name ->
130+ collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
131+ Definition (TypeAnnotation name tipe) ->
132+ collect infixes (insert name [] types) aliases adts rest
133+ TypeAlias name vars tipe ->
134+ collect infixes types (insert name ["vars" .= vars] aliases) adts rest
135+ Datatype name vars ctors ->
136+ collect infixes types aliases (insert name ["vars" .= vars] adts) rest
137+ where
138+ insert name fields dict = Map.insert name (obj name fields) dict
139+ obj name fields =
140+ [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields