Moved man page creation out of Setup.hs.

* MakeManPage.hs has been transformed into
  man/make-pandoc-man-pages.hs.
* There is now a cabal stanza for this, so the dependencies are
  handled by cabal.
* Special treatment in Setup.hs ensures that this never gets installed;
  it is built and used to create the man pages.
* Setup.hs cleaned up.
This commit is contained in:
John MacFarlane 2012-10-15 21:26:24 -07:00
parent 6f9151c64e
commit b3ad94bde9
5 changed files with 126 additions and 127 deletions

View file

@ -1,69 +0,0 @@
-- Create pandoc.1 man and pandoc_markdown.5 man pages from README
import Text.Pandoc
import Data.ByteString.UTF8 (toString, fromString)
import Data.Char (toUpper)
import qualified Data.ByteString as B
import Control.Monad
import System.FilePath
import System.Environment (getArgs)
import Text.Pandoc.Shared (normalize)
main = do
rmContents <- liftM toString $ B.readFile "README"
let (Pandoc meta blocks) = readMarkdown def rmContents
let manBlocks = removeSect [Str "Wrappers"]
$ removeSect [Str "Pandoc's",Space,Str "markdown"] blocks
let syntaxBlocks = extractSect [Str "Pandoc's",Space,Str "markdown"] blocks
args <- getArgs
let verbose = "--verbose" `elem` args
makeManPage verbose ("man" </> "man1" </> "pandoc.1")
meta manBlocks
makeManPage verbose ("man" </> "man5" </> "pandoc_markdown.5")
meta syntaxBlocks
makeManPage :: Bool -> FilePath -> Meta -> [Block] -> IO ()
makeManPage verbose page meta blocks = do
let templ = page <.> "template"
manTemplate <- liftM toString $ B.readFile templ
writeManPage page manTemplate (Pandoc meta blocks)
when verbose $ putStrLn $ "Created " ++ page
writeManPage :: FilePath -> String -> Pandoc -> IO ()
writeManPage page templ doc = do
let opts = def{ writerStandalone = True
, writerTemplate = templ }
let manPage = writeMan opts $
bottomUp (concatMap removeLinks) $
bottomUp capitalizeHeaders doc
B.writeFile page $ fromString manPage
removeLinks :: Inline -> [Inline]
removeLinks (Link l _) = l
removeLinks x = [x]
capitalizeHeaders :: Block -> Block
capitalizeHeaders (Header 1 xs) = Header 1 $ bottomUp capitalize xs
capitalizeHeaders x = x
capitalize :: Inline -> Inline
capitalize (Str xs) = Str $ map toUpper xs
capitalize x = x
removeSect :: [Inline] -> [Block] -> [Block]
removeSect ils (Header 1 x:xs) | normalize x == normalize ils =
dropWhile (not . isHeader1) xs
removeSect ils (x:xs) = x : removeSect ils xs
removeSect _ [] = []
extractSect :: [Inline] -> [Block] -> [Block]
extractSect ils (Header 1 z:xs) | normalize z == normalize ils =
bottomUp promoteHeader $ takeWhile (not . isHeader1) xs
where promoteHeader (Header n x) = Header (n-1) x
promoteHeader x = x
extractSect ils (x:xs) = extractSect ils xs
extractSect _ [] = []
isHeader1 :: Block -> Bool
isHeader1 (Header 1 _) = True
isHeader1 _ = False

View file

@ -3,26 +3,16 @@
import Distribution.Simple import Distribution.Simple
import Distribution.Simple.Setup import Distribution.Simple.Setup
(copyDest, copyVerbosity, fromFlag, installVerbosity, BuildFlags(..)) (copyDest, copyVerbosity, fromFlag, installVerbosity, BuildFlags(..))
import Distribution.PackageDescription import Distribution.PackageDescription (PackageDescription(..), Executable(..))
(PackageDescription(..), Executable(..), BuildInfo(..))
import Distribution.Simple.LocalBuildInfo import Distribution.Simple.LocalBuildInfo
(LocalBuildInfo(..), absoluteInstallDirs) (LocalBuildInfo(..), absoluteInstallDirs)
import Distribution.Verbosity ( Verbosity, silent ) import Distribution.Verbosity ( Verbosity, silent )
import Distribution.Simple.GHC (ghcPackageDbOptions) import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))
import Distribution.Simple.InstallDirs (mandir, bindir, CopyDest (NoCopyDest))
import Distribution.Simple.Utils (installOrdinaryFiles) import Distribution.Simple.Utils (installOrdinaryFiles)
import Prelude hiding (catch) import Prelude hiding (catch)
import Control.Exception ( bracket_, catch ) import System.Process ( rawSystem )
import Control.Monad ( unless )
import System.Process ( rawSystem, runCommand, waitForProcess )
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import System.Directory
import System.Exit import System.Exit
import System.Time
import System.IO.Error ( isDoesNotExistError )
import Data.Maybe ( catMaybes )
import Data.List ( (\\) )
import Data.Time.Clock (UTCTime(..))
main :: IO () main :: IO ()
main = do main = do
@ -33,39 +23,22 @@ main = do
(fromFlag $ copyDest flags) (fromFlag $ copyDest flags)
, postInst = \ _ flags pkg lbi -> , postInst = \ _ flags pkg lbi ->
installManpages pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest installManpages pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest
, copyHook = \pkgdescr ->
(copyHook simpleUserHooks) pkgdescr{ executables =
[x | x <- executables pkgdescr, exeName x /= "make-pandoc-man-pages"] }
, instHook = \pkgdescr ->
(instHook simpleUserHooks) pkgdescr{ executables =
[x | x <- executables pkgdescr, exeName x /= "make-pandoc-man-pages"] }
} }
exitWith ExitSuccess exitWith ExitSuccess
-- | Build man pages from markdown sources in man/ -- | Build man pages from markdown sources in man/
makeManPages :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () makeManPages :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
makeManPages _ flags _ lbi = do makeManPages _ flags _ _ = do
ds1 <- modifiedDependencies (manDir </> "man1" </> "pandoc.1") let verbosity = fromFlag $ buildVerbosity flags
["README", manDir </> "man1" </> "pandoc.1.template"] let args = ["--verbose" | verbosity /= silent]
ds2 <- modifiedDependencies (manDir </> "man5" </> "pandoc_markdown.5") rawSystem ("dist" </> "build" </> "make-pandoc-man-pages" </> "make-pandoc-man-pages")
["README", manDir </> "man5" </> "pandoc_markdown.5.template"] args >>= exitWith
let distPref = fromFlag (buildDistPref flags)
packageDB =
withPackageDB lbi
++ [SpecificPackageDB $ distPref </> "package.conf.inplace"]
verbosity = fromFlag $ buildVerbosity flags
args = makeGhcArgs (ghcPackageDbOptions packageDB)
++ ["MakeManPage.hs"]
args' = if verbosity == silent
then args
else args ++ ["--verbose"]
-- Don't run MakeManPage.hs unless we have to
unless (null ds1 && null ds2) $ do
rawSystem "runghc" args' >>= exitWith
-- format arguments to runghc that we wish to pass to ghc
-- normally runghc gets it right, unless the argument does
-- not begin with a '-' charecter, so we need to give clear
-- directions.
makeGhcArgs :: [String] -> [String]
makeGhcArgs = map ("--ghc-arg="++)
manpages :: [FilePath] manpages :: [FilePath]
manpages = ["man1" </> "pandoc.1" manpages = ["man1" </> "pandoc.1"
@ -80,18 +53,3 @@ installManpages pkg lbi verbosity copy =
installOrdinaryFiles verbosity (mandir (absoluteInstallDirs pkg lbi copy)) installOrdinaryFiles verbosity (mandir (absoluteInstallDirs pkg lbi copy))
(zip (repeat manDir) manpages) (zip (repeat manDir) manpages)
-- | Returns a list of 'dependencies' that have been modified after 'file'.
modifiedDependencies :: FilePath -> [FilePath] -> IO [FilePath]
modifiedDependencies file dependencies = do
fileModTime <- catch (getModificationTime file) $
\e -> if isDoesNotExistError e
#if __GLASGOW_HASKELL__ >= 706
then return (UTCTime (toEnum 0) 0) -- the minimum ClockTime
#else
then return (TOD 0 0) -- the minimum ClockTime
#endif
else ioError e
depModTimes <- mapM getModificationTime dependencies
let modified = zipWith (\dep time -> if time > fileModTime then Just dep else Nothing) dependencies depModTimes
return $ catMaybes modified

View file

@ -0,0 +1,98 @@
-- Create pandoc.1 man and pandoc_markdown.5 man pages from README
import Text.Pandoc
import qualified Text.Pandoc.UTF8 as UTF8
import Data.Char (toUpper)
import Control.Monad
import System.FilePath
import System.Environment (getArgs)
import Text.Pandoc.Shared (normalize)
import Data.Maybe ( catMaybes )
import Data.Time.Clock (UTCTime(..))
import Prelude hiding (catch)
import Control.Exception ( catch )
import System.IO.Error ( isDoesNotExistError )
import System.Time (ClockTime(..))
import System.Directory
main :: IO ()
main = do
ds1 <- modifiedDependencies ("man" </> "man1" </> "pandoc.1")
["README", "man" </> "man1" </> "pandoc.1.template"]
ds2 <- modifiedDependencies ("man" </> "man5" </> "pandoc_markdown.5")
["README", "man" </> "man5" </> "pandoc_markdown.5.template"]
unless (null ds1 && null ds2) $ do
rmContents <- UTF8.readFile "README"
let (Pandoc meta blocks) = readMarkdown def rmContents
let manBlocks = removeSect [Str "Wrappers"]
$ removeSect [Str "Pandoc's",Space,Str "markdown"] blocks
let syntaxBlocks = extractSect [Str "Pandoc's",Space,Str "markdown"] blocks
args <- getArgs
let verbose = "--verbose" `elem` args
unless (null ds1) $
makeManPage verbose ("man" </> "man1" </> "pandoc.1") meta manBlocks
unless (null ds2) $
makeManPage verbose ("man" </> "man5" </> "pandoc_markdown.5") meta syntaxBlocks
makeManPage :: Bool -> FilePath -> Meta -> [Block] -> IO ()
makeManPage verbose page meta blocks = do
let templ = page <.> "template"
manTemplate <- UTF8.readFile templ
writeManPage page manTemplate (Pandoc meta blocks)
when verbose $ putStrLn $ "Created " ++ page
writeManPage :: FilePath -> String -> Pandoc -> IO ()
writeManPage page templ doc = do
let opts = def{ writerStandalone = True
, writerTemplate = templ }
let manPage = writeMan opts $
bottomUp (concatMap removeLinks) $
bottomUp capitalizeHeaders doc
UTF8.writeFile page manPage
removeLinks :: Inline -> [Inline]
removeLinks (Link l _) = l
removeLinks x = [x]
capitalizeHeaders :: Block -> Block
capitalizeHeaders (Header 1 xs) = Header 1 $ bottomUp capitalize xs
capitalizeHeaders x = x
capitalize :: Inline -> Inline
capitalize (Str xs) = Str $ map toUpper xs
capitalize x = x
removeSect :: [Inline] -> [Block] -> [Block]
removeSect ils (Header 1 x:xs) | normalize x == normalize ils =
dropWhile (not . isHeader1) xs
removeSect ils (x:xs) = x : removeSect ils xs
removeSect _ [] = []
extractSect :: [Inline] -> [Block] -> [Block]
extractSect ils (Header 1 z:xs) | normalize z == normalize ils =
bottomUp promoteHeader $ takeWhile (not . isHeader1) xs
where promoteHeader (Header n x) = Header (n-1) x
promoteHeader x = x
extractSect ils (x:xs) = extractSect ils xs
extractSect _ [] = []
isHeader1 :: Block -> Bool
isHeader1 (Header 1 _) = True
isHeader1 _ = False
-- | Returns a list of 'dependencies' that have been modified after 'file'.
modifiedDependencies :: FilePath -> [FilePath] -> IO [FilePath]
modifiedDependencies file dependencies = do
fileModTime <- catch (getModificationTime file) $
\e -> if isDoesNotExistError e
#if __GLASGOW_HASKELL__ >= 706
then return (UTCTime (toEnum 0) 0) -- the minimum ClockTime
#else
then return (TOD 0 0) -- the minimum ClockTime
#endif
else ioError e
depModTimes <- mapM getModificationTime dependencies
let modified = zipWith (\dep time -> if time > fileModTime then Just dep else Nothing) dependencies depModTimes
return $ catMaybes modified

View file

@ -370,6 +370,19 @@ Executable pandoc
else else
Buildable: False Buildable: False
-- NOTE: A trick in Setup.hs makes sure this won't be installed:
Executable make-pandoc-man-pages
Main-Is: make-pandoc-man-pages.hs
Hs-Source-Dirs: man
Build-Depends: base >= 4.2 && < 5,
pandoc,
directory >= 1 && < 1.3,
filepath >= 1.1 && < 1.4,
old-time >= 1.1 && < 1.2,
time >= 1.2 && < 1.5
Default-Language: Haskell98
Default-Extensions: CPP
Test-Suite test-pandoc Test-Suite test-pandoc
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
Main-Is: test-pandoc.hs Main-Is: test-pandoc.hs

View file

@ -1,8 +1,7 @@
@echo off @echo off
cd .. cd ..
ghc --make MakeManPage
MakeManPage.exe
cabal update cabal update
cabal-dev clean
cabal-dev install --disable-library-for-ghci highlighting-kate cabal-dev install --disable-library-for-ghci highlighting-kate
cabal-dev install --flags="embed_data_files" citeproc-hs cabal-dev install --flags="embed_data_files" citeproc-hs
cabal-dev install --flags="executable -library blaze_html_0_5" --datasubdir= cabal-dev install --flags="executable -library blaze_html_0_5" --datasubdir=