lhs2tex-1.21: Setup.hs
{-# LANGUAGE PackageImports #-}
import Distribution.Simple.Setup (CopyDest(..),ConfigFlags(..),BuildFlags(..),
CopyFlags(..),RegisterFlags(..),InstallFlags(..),
defaultRegisterFlags,fromFlagOrDefault,Flag(..),
defaultCopyFlags)
import Distribution.Simple (UserHooks(..), simpleUserHooks, defaultMainWithHooks)
import Distribution.Simple.LocalBuildInfo
(LocalBuildInfo(..),absoluteInstallDirs)
import Distribution.Simple.Configure (configCompilerAux)
import Distribution.PackageDescription (PackageDescription(..))
import Distribution.Simple.InstallDirs
(InstallDirs(..))
import Distribution.Simple.Program
(Program(..),ConfiguredProgram(..),ProgramConfiguration(..),
ProgramLocation(..),simpleProgram,lookupProgram,
rawSystemProgramConf)
import Distribution.Simple.Utils
import Distribution.Verbosity
import Data.Char (isSpace, showLitChar)
import Data.List (isSuffixOf,isPrefixOf)
import Data.Maybe (listToMaybe,isJust)
import Data.Version
import Control.Exception (try)
import Control.Monad (when,unless)
import "regex-compat" Text.Regex (matchRegex,matchRegexAll,mkRegex,mkRegexWithOpts,subRegex)
import Text.ParserCombinators.ReadP (readP_to_S)
import System.Exit (ExitCode)
import System.IO (hGetContents,hClose,hPutStr,stderr)
import System.Process (runInteractiveProcess,waitForProcess)
import System.Directory
import System.Info (os)
lhs2tex = "lhs2TeX"
minPolytableVersion = [0,8,2]
shortversion = show (numversion `div` 100) ++ "." ++ show (numversion `mod` 100)
version = shortversion ++ if ispre then "pre" ++ show pre else ""
numversion = 121
ispre = False
pre = 1
main = defaultMainWithHooks lhs2texHooks
sep = if isWindows then ";" else ":"
lhs2texBuildInfoFile :: FilePath
lhs2texBuildInfoFile = "." `joinFileName` ".setup-lhs2tex-config"
generatedFiles = ["src" `joinFileName` "Version.lhs",
"lhs2TeX.1",
"doc" `joinFileName` "InteractiveHugs.lhs",
"doc" `joinFileName` "InteractivePre.lhs"]
data Lhs2texBuildInfo =
Lhs2texBuildInfo { installPolyTable :: Maybe String,
rebuildDocumentation :: Bool }
deriving (Show, Read)
lhs2texHooks = simpleUserHooks
{ hookedPrograms = [simpleProgram "hugs",
simpleProgram "kpsewhich",
simpleProgram "pdflatex",
simpleProgram "mktexlsr"],
postConf = lhs2texPostConf,
postBuild = lhs2texPostBuild,
postCopy = lhs2texPostCopy,
postInst = lhs2texPostInst,
regHook = lhs2texRegHook,
cleanHook = lhs2texCleanHook
}
lhs2texPostConf a cf pd lbi =
do let v = fromFlagOrDefault normal (configVerbosity cf)
-- check polytable
tmft <- do let kpseExists = lookupProgram (simpleProgram "kpsewhich") (withPrograms lbi)
case kpseExists of
Nothing -> return Nothing
Just _ -> do (_,b,_) <- runKpseWhichVar "TEXMFLOCAL"
b <- return . stripQuotes . stripNewlines $ b
ex <- return (not . all isSpace $ b) -- or check if directory exists?
b <- if ex then return b
else do (_,b,_) <- (runKpseWhichVar "TEXMFMAIN")
return . stripQuotes . stripNewlines $ b
if not . all isSpace $ b -- or check if directory exists?
then return (Just b)
else return Nothing
i <- case tmft of
Just b -> do (_,p,_) <- runKpseWhich "polytable.sty"
p <- return . stripNewlines $ p
ex <- doesFileExist p
nec <- if ex then do info v $ "Found polytable package at: " ++ p
x <- readFile p
let vp = do vs <- matchRegex (mkRegexWithOpts " v(.*) .polytable. package" True True) x
listToMaybe [ r | v <- vs, (r,"") <- readP_to_S parseVersion v ]
let (sv,nec) = case vp of
Just n -> (showVersion n,versionBranch n < minPolytableVersion)
Nothing -> ("unknown",True)
info v $ "Package polytable version: " ++ sv
return nec
else return True
info v $ "Package polytable installation necessary: " ++ showYesNo nec
when nec $ info v $ "Using texmf tree at: " ++ b
return (if nec then Just b else Nothing)
Nothing -> do warn v "No texmf tree found, polytable package cannot be installed"
return Nothing
-- check documentation
ex <- doesFileExist $ "doc" `joinFileName` "Guide2.dontbuild"
r <- if ex then do info v "Documentation will not be rebuilt unless you remove the file \"doc/Guide2.dontbuild\""
return False
else do let mProg = lookupProgram (simpleProgram "pdflatex") (withPrograms lbi)
case mProg of
Nothing -> info v "Documentation cannot be rebuilt without pdflatex" >> return False
Just _ -> return True
unless r $ info v $ "Using pre-built documentation"
writePersistLhs2texBuildConfig (Lhs2texBuildInfo { installPolyTable = i, rebuildDocumentation = r })
mapM_ (\f -> do info v $ "Creating " ++ f
let hugsExists = lookupProgram (simpleProgram "hugs") (withPrograms lbi)
hugs <- case hugsExists of
Nothing -> return ""
Just _ -> fmap fst (getProgram "hugs" (withPrograms lbi))
let lhs2texDir = buildDir lbi `joinFileName` lhs2tex
let lhs2texBin = lhs2texDir `joinFileName` lhs2tex
readFile (f ++ ".in") >>= return .
-- these paths could contain backslashes, so we
-- need to escape them.
replace "@prefix@" (escapeChars $ prefix (absoluteInstallDirs pd lbi NoCopyDest)) .
replace "@stydir@" (escapeChars $ datadir (absoluteInstallDirs pd lbi NoCopyDest)) .
replace "@LHS2TEX@" lhs2texBin .
replace "@HUGS@" hugs .
replace "@VERSION@" version .
replace "@SHORTVERSION@" shortversion .
replace "@NUMVERSION@" (show numversion) .
replace "@SEP@" sep .
replace "@PRE@" (show pre) >>= writeFile f)
generatedFiles
where runKpseWhich v = runCommandProgramConf silent "kpsewhich" (withPrograms lbi) [v]
runKpseWhichVar v = runKpseWhich $ "-expand-var='$" ++ v ++ "'"
lhs2texPostBuild a bf@(BuildFlags { buildVerbosity = vf }) pd lbi =
do let v = fromFlagOrDefault normal vf
ebi <- getPersistLhs2texBuildConfig
let lhs2texDir = buildDir lbi `joinFileName` lhs2tex
let lhs2texBin = lhs2texDir `joinFileName` lhs2tex
let lhs2texDocDir = lhs2texDir `joinFileName` "doc"
callLhs2tex v lbi ["--code", "lhs2TeX.sty.lit"] (lhs2texDir `joinFileName` "lhs2TeX.sty")
callLhs2tex v lbi ["--code", "lhs2TeX.fmt.lit"] (lhs2texDir `joinFileName` "lhs2TeX.fmt")
createDirectoryIfMissing True lhs2texDocDir
if rebuildDocumentation ebi then lhs2texBuildDocumentation a bf pd lbi
else copyFileVerbose v ("doc" `joinFileName` "Guide2.pdf") (lhs2texDocDir `joinFileName` "Guide2.pdf")
lhs2texBuildDocumentation a (BuildFlags { buildVerbosity = vf }) pd lbi =
do let v = fromFlagOrDefault normal vf
let lhs2texDir = buildDir lbi `joinFileName` lhs2tex
let lhs2texBin = lhs2texDir `joinFileName` lhs2tex
let lhs2texDocDir = lhs2texDir `joinFileName` "doc"
snippets <- do guide <- readFile $ "doc" `joinFileName` "Guide2.lhs"
let s = matchRegexRepeatedly (mkRegexWithOpts "^.*input\\{(.*)\\}.*$" True True) guide
return s
mapM_ (\s -> do let snippet = "doc" `joinFileName` (s ++ ".lhs")
c <- readFile $ snippet
let inc = maybe ["poly"] id (matchRegex (mkRegexWithOpts "^%include (.*)\\.fmt" True True) c)
-- rewrite the path to ghc/hugs, and to the preprocessor
writeFile (lhs2texDir `joinFileName` snippet)
( -- replace "^%options ghc" "%options ghc" .
-- replace "^%options hugs" "%options hugs" .
-- TODO: replace or replaceEscaped
replace "-pgmF \\.\\./lhs2TeX" ("-pgmF " ++ lhs2texBin ++ " -optF-Pdoc" ++ sep) $ c )
let incToStyle ["verbatim"] = "verb"
incToStyle ["stupid"] = "math"
incToStyle ["tex"] = "poly"
incToStyle ["polytt"] = "poly"
incToStyle ["typewriter"] = "tt"
incToStyle [x] = x
incToStyle [] = "poly"
callLhs2tex v lbi ["--" ++ incToStyle inc , "-Pdoc" ++ sep, lhs2texDir `joinFileName` snippet]
(lhs2texDocDir `joinFileName` s ++ ".tex")
) snippets
callLhs2tex v lbi ["--poly" , "-Pdoc" ++ sep, "-Psrc" ++ sep, "doc" `joinFileName` "Guide2.lhs"]
(lhs2texDocDir `joinFileName` "Guide2.tex")
copyFileVerbose v ("polytable" `joinFileName` "polytable.sty") (lhs2texDocDir `joinFileName` "polytable.sty")
copyFileVerbose v ("polytable" `joinFileName` "lazylist.sty") (lhs2texDocDir `joinFileName` "lazylist.sty")
d <- getCurrentDirectory
setCurrentDirectory lhs2texDocDir
-- call pdflatex as long as necessary
let loop = do rawSystemProgramConf v (simpleProgram "pdflatex") (withPrograms lbi) ["Guide2.tex"]
x <- readFile "Guide2.log"
case matchRegex (mkRegexWithOpts "Warning.*Rerun" True True) x of
Just _ -> loop
Nothing -> return ()
loop
setCurrentDirectory d
lhs2texPostCopy a (CopyFlags { copyDest = cdf, copyVerbosity = vf }) pd lbi =
do let v = fromFlagOrDefault normal vf
let cd = fromFlagOrDefault NoCopyDest cdf
ebi <- getPersistLhs2texBuildConfig
let dataPref = datadir (absoluteInstallDirs pd lbi cd)
createDirectoryIfMissing True dataPref
let lhs2texDir = buildDir lbi `joinFileName` lhs2tex
-- lhs2TeX.{fmt,sty}
mapM_ (\f -> installOrdinaryFile v (lhs2texDir `joinFileName` f) (dataPref `joinFileName` f))
["lhs2TeX.fmt","lhs2TeX.sty"]
-- lhs2TeX library
fmts <- fmap (filter (".fmt" `isSuffixOf`)) (getDirectoryContents "Library")
mapM_ (\f -> installOrdinaryFile v ("Library" `joinFileName` f) (dataPref `joinFileName` f))
fmts
-- documentation difficult due to lack of docdir
let lhs2texDocDir = lhs2texDir `joinFileName` "doc"
let docDir = if isWindows
then dataPref `joinFileName` "Documentation"
else docdir (absoluteInstallDirs pd lbi cd) `joinFileName` "doc"
let manDir = if isWindows
then dataPref `joinFileName` "Documentation"
else datadir (absoluteInstallDirs pd lbi cd) `joinFileName` ".." `joinFileName` "man" `joinFileName` "man1"
createDirectoryIfMissing True docDir
installOrdinaryFile v (lhs2texDocDir `joinFileName` "Guide2.pdf") (docDir `joinFileName` "Guide2.pdf")
when (not isWindows) $
do createDirectoryIfMissing True manDir
installOrdinaryFile v ("lhs2TeX.1") (manDir `joinFileName` "lhs2TeX.1")
-- polytable
case (installPolyTable ebi) of
Just texmf -> do let texmfDir = texmf
ptDir = texmfDir `joinFileName` "tex" `joinFileName` "latex"
`joinFileName` "polytable"
createDirectoryIfMissing True ptDir
stys <- fmap (filter (".sty" `isSuffixOf`))
(getDirectoryContents "polytable")
mapM_ (\f -> installOrdinaryFile v ("polytable" `joinFileName` f)
(ptDir `joinFileName` f))
stys
Nothing -> return ()
lhs2texPostInst a (InstallFlags { installPackageDB = db, installVerbosity = v }) pd lbi =
do lhs2texPostCopy a (defaultCopyFlags { copyDest = Flag NoCopyDest, copyVerbosity = v }) pd lbi
lhs2texRegHook pd lbi Nothing (defaultRegisterFlags { regPackageDB = db, regVerbosity = v })
lhs2texRegHook pd lbi _ (RegisterFlags { regVerbosity = vf }) =
do let v = fromFlagOrDefault normal vf
ebi <- getPersistLhs2texBuildConfig
when (isJust . installPolyTable $ ebi) $
do rawSystemProgramConf v (simpleProgram "mktexlsr") (withPrograms lbi) []
return ()
lhs2texCleanHook pd lbi v pshs =
do cleanHook simpleUserHooks pd lbi v pshs
tryIO $ removeFile lhs2texBuildInfoFile
mapM_ (tryIO . removeFile) generatedFiles
matchRegexRepeatedly re str =
case matchRegexAll re str of
Just (_,_,r,[s]) -> s : matchRegexRepeatedly re r
Nothing -> []
replace re t x = subRegex (mkRegexWithOpts re True True) x (escapeRegex t)
where
-- subRegex requires us to escape backslashes
escapeRegex [] = []
escapeRegex ('\\':xs) = '\\':'\\': escapeRegex xs
escapeRegex (x:xs) = x : escapeRegex xs
escapeChars :: String -> String
escapeChars t = foldr showLitChar [] t
showYesNo :: Bool -> String
showYesNo p | p = "yes"
| otherwise = "no"
stripNewlines :: String -> String
stripNewlines = filter (/='\n')
stripQuotes :: String -> String
stripQuotes ('\'':s@(_:_)) = init s
stripQuotes x = x
callLhs2tex v lbi params outf =
do let lhs2texDir = buildDir lbi `joinFileName` lhs2tex
let lhs2texBin = lhs2texDir `joinFileName` lhs2tex
let args = [ "-P" ++ lhs2texDir ++ sep ]
++ [ "-o" ++ outf ]
++ (if v == deafening then ["-v"] else [])
++ params
(ex,_,err) <- runCommand v lhs2texBin args
hPutStr stderr (unlines . lines $ err)
maybeExit (return ex)
runCommandProgramConf :: Verbosity -- ^ verbosity
-> String -- ^ program name
-> ProgramConfiguration -- ^ lookup up the program here
-> [String] -- ^ args
-> IO (ExitCode,String,String)
runCommandProgramConf v progName programConf extraArgs =
do (prog,args) <- getProgram progName programConf
runCommand v prog (args ++ extraArgs)
getProgram :: String -> ProgramConfiguration -> IO (String, [String])
getProgram progName programConf =
do let mProg = lookupProgram (simpleProgram progName) programConf
case mProg of
Just (ConfiguredProgram { programLocation = UserSpecified p,
programDefaultArgs = args }) -> return (p,args)
Just (ConfiguredProgram { programLocation = FoundOnSystem p,
programDefaultArgs = args }) -> return (p,args)
_ -> (die (progName ++ " command not found"))
-- | Run a command in a specific environment and return the output and errors.
runCommandInEnv :: Verbosity -- ^ verbosity
-> String -- ^ the command
-> [String] -- ^ args
-> [(String,String)] -- ^ the environment
-> IO (ExitCode,String,String)
runCommandInEnv v cmd args env =
do when (v >= verbose) $ putStrLn (cmd ++ concatMap (' ':) args)
let env' = if null env then Nothing else Just env
(cin,cout,cerr,pid) <- runInteractiveProcess cmd args Nothing env'
hClose cin
out <- hGetContents cout
err <- hGetContents cerr
stringSeq out (hClose cout)
stringSeq err (hClose cerr)
exit <- waitForProcess pid
return (exit,out,err)
-- | Run a command and return the output and errors.
runCommand :: Verbosity -- ^ verbosity
-> String -- ^ the command
-> [String] -- ^ args
-> IO (ExitCode,String,String)
runCommand v cmd args = runCommandInEnv v cmd args []
-- | Completely evaluates a string.
stringSeq :: String -> b -> b
stringSeq [] c = c
stringSeq (x:xs) c = stringSeq xs c
getPersistLhs2texBuildConfig :: IO Lhs2texBuildInfo
getPersistLhs2texBuildConfig = do
e <- doesFileExist lhs2texBuildInfoFile
let dieMsg = "error reading " ++ lhs2texBuildInfoFile ++ "; run \"setup configure\" command?\n"
when (not e) (die dieMsg)
str <- readFile lhs2texBuildInfoFile
case reads str of
[(bi,_)] -> return bi
_ -> die dieMsg
writePersistLhs2texBuildConfig :: Lhs2texBuildInfo -> IO ()
writePersistLhs2texBuildConfig lbi = do
writeFile lhs2texBuildInfoFile (show lbi)
tryIO :: IO a -> IO (Either IOError a)
tryIO = try
-- HACKS because the Cabal API isn't sufficient:
-- Distribution.Compat.FilePath is supposed to be hidden in future
-- versions, so we need our own version of it:
joinFileName :: String -> String -> FilePath
joinFileName "" fname = fname
joinFileName "." fname = fname
joinFileName dir "" = dir
joinFileName dir fname
| isPathSeparator (last dir) = dir++fname
| otherwise = dir++pathSeparator:fname
where
isPathSeparator :: Char -> Bool
isPathSeparator | isWindows = ( `elem` "/\\" )
| otherwise = ( == '/' )
pathSeparator | isWindows = '\\'
| otherwise = '/'
-- It would be nice if there'd be a predefined way to detect this
isWindows = "mingw" `isPrefixOf` os || "win" `isPrefixOf` os