git.iko.soy/rowtype-yoga/purescript-native
on e35596a help sign in
rowtype-yoga/purescript-native/psc-docs/Main.hs
259 lines 8.7 kB history raw
1{-# LANGUAGE TupleSections #-}
2----------------------------------------------------------------------------
3--
4-- Module : Main
5-- Copyright : (c) Phil Freeman 2013
6-- License : MIT
7--
8-- Maintainer : Phil Freeman <paf31@cantab.net>
9-- Stability : experimental
10-- Portability :
11--
12-- |
13--
14-----------------------------------------------------------------------------
16module Main where
18import Control.Applicative
19import Control.Monad.Trans.Except (runExceptT)
20import Control.Arrow (first, second)
21import Control.Category ((>>>))
22import Control.Monad.Writer
23import Data.Function (on)
24import Data.List
25import Data.Maybe (fromMaybe)
26import Data.Tuple (swap)
27import Data.Version (showVersion)
29import Options.Applicative
30import qualified Text.PrettyPrint.ANSI.Leijen as PP
32import qualified Language.PureScript as P
33import qualified Paths_purescript as Paths
34import System.Exit (exitFailure)
35import System.IO (hPutStrLn, stderr)
36import System.Directory (createDirectoryIfMissing)
37import System.FilePath (takeDirectory)
38import System.FilePath.Glob (glob)
40import Etags
41import Ctags
42import qualified Language.PureScript.Docs as D
43import qualified Language.PureScript.Docs.AsMarkdown as D
45-- Available output formats
46data Format = Markdown -- Output documentation in Markdown format
47 | Ctags -- Output ctags symbol index suitable for use with vi
48 | Etags -- Output etags symbol index suitable for use with emacs
49 deriving (Show, Eq, Ord)
51-- | Available methods of outputting Markdown documentation
52data DocgenOutput
53 = EverythingToStdOut
54 | ToStdOut [P.ModuleName]
55 | ToFiles [(P.ModuleName, FilePath)]
56 deriving (Show)
58data PSCDocsOptions = PSCDocsOptions
59 { pscdFormat :: Format
60 , pscdInputFiles :: [FilePath]
61 , pscdDocgen :: DocgenOutput
62 }
63 deriving (Show)
65docgen :: PSCDocsOptions -> IO ()
66docgen (PSCDocsOptions fmt inputGlob output) = do
67 input <- concat <$> mapM glob inputGlob
68 case fmt of
69 Etags -> dumpTags input dumpEtags
70 Ctags -> dumpTags input dumpCtags
71 Markdown -> do
72 ms <- runExceptT (D.parseAndDesugar input []
73 >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))
74 >>= successOrExit
76 case output of
77 EverythingToStdOut ->
78 putStrLn (D.runDocs (D.modulesAsMarkdown ms))
79 ToStdOut names -> do
80 let (ms', missing) = takeByName ms (map P.runModuleName names)
81 guardMissing missing
82 putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
83 ToFiles names -> do
84 let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)
85 guardMissing missing
87 let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
88 forM_ ms'' $ \grp -> do
89 let fp = fst (head grp)
90 createDirectoryIfMissing True (takeDirectory fp)
91 writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
93 where
94 guardMissing [] = return ()
95 guardMissing [mn] = do
96 hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")
97 exitFailure
98 guardMissing mns = do
99 hPutStrLn stderr "psc-docs: error: unknown modules:"
100 forM_ mns $ \mn ->
101 hPutStrLn stderr (" * " ++ mn)
102 exitFailure
104 successOrExit :: Either P.MultipleErrors a -> IO a
105 successOrExit act =
106 case act of
107 Right x ->
108 return x
109 Left err -> do
110 hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
111 exitFailure
113 takeByName = takeModulesByName D.modName
114 takeByName' = takeModulesByName' D.modName
116-- |
117-- Given a list of module names and a list of modules, return a list of modules
118-- whose names appeared in the given name list, together with a list of names
119-- for which no module could be found in the module list.
120--
121takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
122takeModulesByName getModuleName modules names =
123 first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
125-- |
126-- Like takeModulesByName, but also keeps some extra information with each
127-- module.
128--
129takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
130takeModulesByName' getModuleName modules = foldl go ([], [])
131 where
132 go (ms, missing) (name, x) =
133 case find ((== name) . getModuleName) modules of
134 Just m -> ((m, x) : ms, missing)
135 Nothing -> (ms, name : missing)
137dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO ()
138dumpTags input renderTags = do
139 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
140 case e of
141 Left err -> do
142 hPutStrLn stderr (show err)
143 exitFailure
144 Right ms ->
145 ldump (renderTags (pairs ms))
147 where
148 pairs :: [(Maybe String, m)] -> [(String, m)]
149 pairs = map (first (fromMaybe ""))
151 ldump :: [String] -> IO ()
152 ldump = mapM_ putStrLn
154parseFile :: FilePath -> IO (FilePath, String)
155parseFile input = (,) input <$> readFile input
157inputFile :: Parser FilePath
158inputFile = strArgument $
159 metavar "FILE"
160 <> help "The input .purs file(s)"
162instance Read Format where
163 readsPrec _ "etags" = [(Etags, "")]
164 readsPrec _ "ctags" = [(Ctags, "")]
165 readsPrec _ "markdown" = [(Markdown, "")]
166 readsPrec _ _ = []
168format :: Parser Format
169format = option auto $ value Markdown
170 <> long "format"
171 <> metavar "FORMAT"
172 <> help "Set output FORMAT (markdown | etags | ctags)"
174docgenModule :: Parser String
175docgenModule = strOption $
176 long "docgen"
177 <> 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."
179pscDocsOptions :: Parser (Format, [FilePath], [String])
180pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule
182parseDocgen :: [String] -> Either String DocgenOutput
183parseDocgen [] = Right EverythingToStdOut
184parseDocgen xs = go xs
185 where
186 go = intersperse " "
187 >>> concat
188 >>> words
189 >>> map parseItem
190 >>> combine
192data DocgenOutputItem
193 = IToStdOut P.ModuleName
194 | IToFile (P.ModuleName, FilePath)
196parseItem :: String -> DocgenOutputItem
197parseItem s = case elemIndex ':' s of
198 Just i ->
199 s # splitAt i
200 >>> first P.moduleNameFromString
201 >>> second (drop 1)
202 >>> IToFile
203 Nothing ->
204 IToStdOut (P.moduleNameFromString s)
206 where
207 infixr 1 #
208 (#) = flip ($)
210combine :: [DocgenOutputItem] -> Either String DocgenOutput
211combine [] = Right EverythingToStdOut
212combine (x:xs) = foldM go (initial x) xs
213 where
214 initial (IToStdOut m) = ToStdOut [m]
215 initial (IToFile m) = ToFiles [m]
217 go (ToStdOut ms) (IToStdOut m) = Right (ToStdOut (m:ms))
218 go (ToFiles ms) (IToFile m) = Right (ToFiles (m:ms))
219 go _ _ = Left "Can't mix module names and module name/file path pairs in the same invocation."
221buildOptions :: (Format, [FilePath], [String]) -> IO PSCDocsOptions
222buildOptions (fmt, input, mapping) =
223 case parseDocgen mapping of
224 Right mapping' -> return (PSCDocsOptions fmt input mapping')
225 Left err -> do
226 hPutStrLn stderr "psc-docs: error in --docgen option:"
227 hPutStrLn stderr (" " ++ err)
228 exitFailure
230main :: IO ()
231main = execParser opts >>= buildOptions >>= docgen
232 where
233 opts = info (version <*> helper <*> pscDocsOptions) infoModList
234 infoModList = fullDesc <> headerInfo <> footerInfo
235 headerInfo = header "psc-docs - Generate Markdown documentation from PureScript source files"
236 footerInfo = footerDoc $ Just $ PP.vcat
237 [ examples, PP.empty, PP.text ("psc-docs " ++ showVersion Paths.version) ]
239 version :: Parser (a -> a)
240 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
242examples :: PP.Doc
243examples =
244 PP.vcat $ map PP.text
245 [ "Examples:"
246 , " print documentation for Data.List to stdout:"
247 , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
248 , " --docgen Data.List"
249 , ""
250 , " write documentation for Data.List to docs/Data.List.md:"
251 , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
252 , " --docgen Data.List:docs/Data.List.md"
253 , ""
254 , " write documentation for Data.List to docs/Data.List.md, and"
255 , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
256 , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\"
257 , " --docgen Data.List:docs/Data.List.md \\"
258 , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
259 ]