@@ -1,3 +1,4 @@
1+{-# LANGUAGE TupleSections #-}
12----------------------------------------------------------------------------
23--
34-- Module : Main
@@ -16,50 +17,124 @@ module Main where
1617
1718import Control.Applicative
1819import Control.Monad.Writer
19−import Control.Arrow (first)
20+import Control.Arrow (first, second)
21+import Control.Category ((>>>))
2022import Data.List
2123import Data.Maybe (fromMaybe)
2224import Data.Version (showVersion)
2325
2426import Options.Applicative
27+import qualified Text.PrettyPrint.ANSI.Leijen as PP
2528
2629import qualified Language.PureScript as P
2730import qualified Paths_purescript as Paths
28−import System.Exit (exitSuccess, exitFailure)
31+import System.Exit (exitFailure)
2932import System.IO (hPutStrLn, stderr)
3033
3134import Etags
3235import Ctags
33−import Language.PureScript.Docs.AsMarkdown
36+import qualified Language.PureScript.Docs as D
37+import qualified Language.PureScript.Docs.AsMarkdown as D
3438
3539-- Available output formats
3640data Format = Markdown -- Output documentation in Markdown format
3741 | Ctags -- Output ctags symbol index suitable for use with vi
3842 | Etags -- Output etags symbol index suitable for use with emacs
43+ deriving (Show, Eq, Ord)
44+
45+-- | Available methods of outputting Markdown documentation
46+data DocgenOutput
47+ = EverythingToStdOut
48+ | ToStdOut [P.ModuleName]
49+ | ToFiles [(P.ModuleName, FilePath)]
50+ deriving (Show)
3951
4052data PSCDocsOptions = PSCDocsOptions
4153 { pscdFormat :: Format
4254 , pscdInputFiles :: [FilePath]
55+ , pscdDocgen :: DocgenOutput
4356 }
57+ deriving (Show)
4458
4559docgen :: PSCDocsOptions -> IO ()
46−docgen (PSCDocsOptions fmt input) = do
60+docgen (PSCDocsOptions fmt input output) =
61+ case fmt of
62+ Etags -> dumpTags input dumpEtags
63+ Ctags -> dumpTags input dumpCtags
64+ Markdown -> do
65+ e <- D.parseAndDesugar input [] (\_ ms -> return ms)
66+ case e of
67+ Left (D.ParseError err) -> do
68+ hPutStrLn stderr $ show err
69+ exitFailure
70+ Left (D.SortModulesError err) -> do
71+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
72+ exitFailure
73+ Left (D.DesugarError err) -> do
74+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
75+ exitFailure
76+ Right ms' -> do
77+ case output of
78+ EverythingToStdOut ->
79+ putStrLn (D.renderModulesAsMarkdown ms')
80+ ToStdOut names -> do
81+ let (ms, missing) = takeModulesByName ms' names
82+ guardMissing missing
83+ putStrLn (D.renderModulesAsMarkdown ms)
84+ ToFiles names -> do
85+ let (ms, missing) = takeModulesByName' ms' names
86+ guardMissing missing
87+ forM_ ms $ \(m, fp) ->
88+ writeFile fp (D.renderModulesAsMarkdown [m])
89+
90+ where
91+ guardMissing [] = return ()
92+ guardMissing [mn] = do
93+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
94+ exitFailure
95+ guardMissing mns = do
96+ hPutStrLn stderr "psc-docs: error: unknown modules:"
97+ forM_ mns $ \mn ->
98+ hPutStrLn stderr (" * " ++ show mn)
99+ exitFailure
100+
101+-- |
102+-- Given a list of module names and a list of modules, return a list of modules
103+-- whose names appeared in the given name list, together with a list of names
104+-- for which no module could be found in the module list.
105+--
106+takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
107+takeModulesByName modules names =
108+ first (map fst) (takeModulesByName' modules (map (,()) names))
109+
110+-- |
111+-- Like takeModulesByName but also keeps some extra data with the module.
112+--
113+takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
114+takeModulesByName' modules = foldl go ([], [])
115+ where
116+ go (ms, missing) (name, x) =
117+ case find ((== name) . P.getModuleName) modules of
118+ Just m -> ((m, x) : ms, missing)
119+ Nothing -> (ms, name : missing)
120+
121+dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO ()
122+dumpTags input renderTags = do
47123 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
48124 case e of
49125 Left err -> do
50− hPutStrLn stderr $ show err
126+ hPutStrLn stderr (show err)
51127 exitFailure
52− Right ms -> do
53− case fmt of
54− Markdown -> putStrLn $ renderModulesAsMarkdown $ map snd ms
55− Etags -> ldump $ dumpEtags $ pairs ms
56− Ctags -> ldump $ dumpCtags $ pairs ms
57− exitSuccess
58− where pairs :: [(Maybe String, m)] -> [(String, m)]
59− pairs = map (\(k,m) -> (fromMaybe "" k,m))
60− ldump :: [String] -> IO ()
61− ldump = mapM_ putStrLn
62−
128+ Right ms ->
129+ ldump (renderTags (pairs ms))
130+
131+ where
132+ pairs :: [(Maybe String, m)] -> [(String, m)]
133+ pairs = map (first (fromMaybe ""))
134+
135+ ldump :: [String] -> IO ()
136+ ldump = mapM_ putStrLn
137+
63138parseFile :: FilePath -> IO (FilePath, String)
64139parseFile input = (,) input <$> readFile input
65140
@@ -72,24 +147,97 @@ instance Read Format where
72147 readsPrec _ "etags" = [(Etags, "")]
73148 readsPrec _ "ctags" = [(Ctags, "")]
74149 readsPrec _ "markdown" = [(Markdown, "")]
75− readsPrec _ _ = []
150+ readsPrec _ _ = []
76151
77152format :: Parser Format
78153format = option auto $ value Markdown
79154 <> long "format"
80155 <> metavar "FORMAT"
81− <> help "Set output FORMAT (markdown | etags | ctags)"
156+ <> help "Set output FORMAT (markdown | etags | ctags)"
82157
83−pscDocsOptions :: Parser PSCDocsOptions
84−pscDocsOptions = PSCDocsOptions <$> format <*> many inputFile
158+docgenModule :: Parser String
159+docgenModule = strOption $
160+ long "docgen"
161+ <> help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times."
162+
163+pscDocsOptions :: Parser (Format, [FilePath], [String])
164+pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule
165+
166+parseDocgen :: [String] -> Either String DocgenOutput
167+parseDocgen [] = Right EverythingToStdOut
168+parseDocgen xs = go xs
169+ where
170+ go = intersperse " "
171+ >>> concat
172+ >>> words
173+ >>> map parseItem
174+ >>> combine
175+
176+data DocgenOutputItem
177+ = IToStdOut P.ModuleName
178+ | IToFile (P.ModuleName, FilePath)
179+
180+parseItem :: String -> DocgenOutputItem
181+parseItem s = case elemIndex ':' s of
182+ Just i ->
183+ s # splitAt i
184+ >>> first P.moduleNameFromString
185+ >>> second (drop 1)
186+ >>> IToFile
187+ Nothing ->
188+ IToStdOut (P.moduleNameFromString s)
189+
190+ where
191+ infixr 1 #
192+ (#) = flip ($)
193+
194+combine :: [DocgenOutputItem] -> Either String DocgenOutput
195+combine [] = Right EverythingToStdOut
196+combine (x:xs) = foldM go (initial x) xs
197+ where
198+ initial (IToStdOut m) = ToStdOut [m]
199+ initial (IToFile m) = ToFiles [m]
200+
201+ go (ToStdOut ms) (IToStdOut m) = Right (ToStdOut (m:ms))
202+ go (ToFiles ms) (IToFile m) = Right (ToFiles (m:ms))
203+ go _ _ = Left "Can't mix module names and module name/file path pairs in the same invocation."
204+
205+buildOptions :: (Format, [FilePath], [String]) -> IO PSCDocsOptions
206+buildOptions (fmt, input, mapping) =
207+ case parseDocgen mapping of
208+ Right mapping' -> return (PSCDocsOptions fmt input mapping')
209+ Left err -> do
210+ hPutStrLn stderr "psc-docs: error in --docgen option:"
211+ hPutStrLn stderr (" " ++ err)
212+ exitFailure
85213
86214main :: IO ()
87−main = execParser opts >>= docgen
215+main = execParser opts >>= buildOptions >>= docgen
88216 where
89217 opts = info (version <*> helper <*> pscDocsOptions) infoModList
90218 infoModList = fullDesc <> headerInfo <> footerInfo
91− headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
92− footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
219+ headerInfo = header "psc-docs - Generate Markdown documentation from PureScript source files"
220+ footerInfo = footerDoc $ Just $ PP.vcat
221+ [ examples, PP.empty, PP.text ("psc-docs " ++ showVersion Paths.version) ]
93222
94223 version :: Parser (a -> a)
95224 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
225+
226+examples :: PP.Doc
227+examples =
228+ PP.vcat $ map PP.text
229+ [ "Examples:"
230+ , " print documentation for Data.List to stdout:"
231+ , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
232+ , " --docgen Data.List"
233+ , ""
234+ , " write documentation for Data.List to docs/Data.List.md:"
235+ , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
236+ , " --docgen Data.List:docs/Data.List.md"
237+ , ""
238+ , " write documentation for Data.List to docs/Data.List.md, and"
239+ , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
240+ , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
241+ , " --docgen Data.List:docs/Data.List.md \\"
242+ , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
243+ ]