Setup.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}

#if !defined(MIN_VERSION_Cabal)
# define MIN_VERSION_Cabal(x,y,z) 0
#endif

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.PackageDescription (PackageDescription(..))
import Distribution.Simple.InstallDirs
                            (InstallDirs(..))
import Distribution.Simple.Program
                            (Program(..),ConfiguredProgram(..),
                             ProgramLocation(..),simpleProgram,lookupProgram,
                             runDbProgram)
import Distribution.Simple.Program.Db (ProgramDb)
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,6]
shortversion = show (numversion `div` 100) ++ "." ++ show (numversion `mod` 100)
version = shortversion ++ if ispre then "pre" ++ show pre else ""
numversion = 125
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 runDbProgram 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  runDbProgram 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
                       ->  ProgramDb              -- ^ 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 -> ProgramDb -> 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' silent (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' silent dieMsg)
  str <- readFile lhs2texBuildInfoFile
  case reads str of
    [(bi,_)] -> return bi
    _        -> die' silent 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

#if !(MIN_VERSION_Cabal(2,0,0))
die' :: Verbosity -> String -> IO a
die' _ = die
#endif