Gtk2HsSetup.hs.old

{-# LANGUAGE CPP, ViewPatterns #-}

#ifndef CABAL_VERSION_CHECK
#error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file
#endif

-- | Build a Gtk2hs package.
--
module Gtk2HsSetup (
  gtk2hsUserHooks,
  getPkgConfigPackages,
  checkGtk2hsBuildtools,
  typeGenProgram,
  signalGenProgram,
  c2hsLocal
  ) where

import Distribution.Simple
import Distribution.Simple.Configure     ( configCompilerEx )
import Distribution.Simple.PreProcess
import Distribution.InstalledPackageInfo ( importDirs,
                                           showInstalledPackageInfo,
                                           libraryDirs,
                                           extraLibraries,
                                           extraGHCiLibraries )
import Distribution.Simple.PackageIndex ( lookupInstalledPackageId )
import Distribution.PackageDescription as PD ( PackageDescription(..),
                                               updatePackageDescription,
                                               BuildInfo(..),
                                               emptyBuildInfo, allBuildInfo,
                                               Library(..),
                                               libModules, hasLibs)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms),
                                           InstallDirs(..),
                                           componentPackageDeps,
                                           absoluteInstallDirs)
import Distribution.Simple.Compiler  ( Compiler(..) )
import Distribution.Simple.Program (
  Program(..), ConfiguredProgram(..),
  defaultProgramConfiguration,
  rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath,
  c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram,
  simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)
import Distribution.ModuleName ( ModuleName, components, toFilePath )
import Distribution.Simple.Utils
import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
                                  defaultCopyFlags, ConfigFlags(configVerbosity),
                                  fromFlag, toFlag, RegisterFlags(..), flagToMaybe,
                                  fromFlagOrDefault, defaultRegisterFlags)
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.Install ( install )
import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage )
import Distribution.Text ( simpleParse, display )
import System.FilePath
import System.Exit (exitFailure)
import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist )
import Distribution.Version (Version(..))
import Distribution.Verbosity
import Control.Monad (when, unless, filterM, liftM, forM, forM_)
import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList, catMaybes )
import Data.List (isPrefixOf, isSuffixOf, nub, minimumBy, stripPrefix, tails )
import Data.Ord as Ord (comparing)
import Data.Char (isAlpha, isNumber)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Compiler (compilerVersion)

import Control.Applicative ((<$>))

import Distribution.Simple.Program.Find ( defaultProgramSearchPath )
onDefaultSearchPath f a b = f a b defaultProgramSearchPath
libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of
  [clbi] -> Just clbi
  _ -> Nothing

-- the name of the c2hs pre-compiled header file
precompFile = "precompchs.bin"

gtk2hsUserHooks = simpleUserHooks {
    hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],
    hookedPreProcessors = [("chs", ourC2hs)],
    confHook = \pd cf ->
      (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)),
    postConf = \args cf pd lbi -> do
      genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi
      postConf simpleUserHooks args cf pd lbi,
    buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->
                                 buildHook simpleUserHooks pd lbi uh bf,
    copyHook = \pd lbi uh flags -> copyHook simpleUserHooks pd lbi uh flags >>
      installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),
    instHook = \pd lbi uh flags ->
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
      installHook pd lbi uh flags >>
      installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest,
    regHook = registerHook
#else
      instHook simpleUserHooks pd lbi uh flags >>
      installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest
#endif
  }

------------------------------------------------------------------------------
-- Lots of stuff for windows ghci support
------------------------------------------------------------------------------

getDlls :: [FilePath] -> IO [FilePath]
getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$>
    mapM getDirectoryContents dirs

fixLibs :: [FilePath] -> [String] -> [String]
fixLibs dlls = concatMap $ \ lib ->
    case filter (isLib lib) dlls of
                dlls@(_:_) -> [dropExtension (pickDll dlls)]
                _          -> if lib == "z" then [] else [lib]
  where
    -- If there are several .dll files matching the one we're after then we
    -- just have to guess. For example for recent Windows cairo builds we get
    -- libcairo-2.dll libcairo-gobject-2.dll libcairo-script-interpreter-2.dll
    -- Our heuristic is to pick the one with the shortest name.
    -- Yes this is a hack but the proper solution is hard: we would need to
    -- parse the .a file and see which .dll file(s) it needed to link to.
    pickDll = minimumBy (Ord.comparing length)
    isLib lib dll =
        case stripPrefix ("lib"++lib) dll of
            Just ('.':_)                -> True
            Just ('-':n:_) | isNumber n -> True
            _                           -> False

-- The following code is a big copy-and-paste job from the sources of
-- Cabal 1.8 just to be able to fix a field in the package file. Yuck.

installHook :: PackageDescription -> LocalBuildInfo
                   -> UserHooks -> InstallFlags -> IO ()
installHook pkg_descr localbuildinfo _ flags = do
  let copyFlags = defaultCopyFlags {
                      copyDistPref   = installDistPref flags,
                      copyDest       = toFlag NoCopyDest,
                      copyVerbosity  = installVerbosity flags
                  }
  install pkg_descr localbuildinfo copyFlags
  let registerFlags = defaultRegisterFlags {
                          regDistPref  = installDistPref flags,
                          regInPlace   = installInPlace flags,
                          regPackageDB = installPackageDB flags,
                          regVerbosity = installVerbosity flags
                      }
  when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags

registerHook :: PackageDescription -> LocalBuildInfo
        -> UserHooks -> RegisterFlags -> IO ()
registerHook pkg_descr localbuildinfo _ flags =
    if hasLibs pkg_descr
    then register pkg_descr localbuildinfo flags
    else setupMessage verbosity
           "Package contains no library to register:" (packageId pkg_descr)
  where verbosity = fromFlag (regVerbosity flags)

register :: PackageDescription -> LocalBuildInfo
         -> RegisterFlags -- ^Install in the user's database?; verbose
         -> IO ()
register pkg@PackageDescription { library       = Just lib  } lbi regFlags
  = do
    let clbi = LBI.getComponentLocalBuildInfo lbi LBI.CLibName

    installedPkgInfoRaw <- generateRegistrationInfo
                           verbosity pkg lib lbi clbi inplace False distPref packageDb

    dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls
    let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw)
        installedPkgInfo = installedPkgInfoRaw {
                                extraGHCiLibraries = libs }

     -- Three different modes:
    case () of
     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo
       | modeGenerateRegScript -> die "Generate Reg Script not supported"
       | otherwise             -> do
       (compiler,_,_) <- configCompilerEx defaultCompilerFlavor Nothing Nothing defaultProgramConfiguration verbosity
       registerPackage verbosity compiler defaultProgramConfiguration inplace packageDbs installedPkgInfo
  where
    modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
    regFile             = fromMaybe (display (packageId pkg) <.> "conf")
                                    (fromFlag (regGenPkgConf regFlags))
    modeGenerateRegScript = fromFlag (regGenScript regFlags)
    inplace   = fromFlag (regInPlace regFlags)
    packageDbs = nub $ withPackageDB lbi
                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))
    packageDb = registrationPackageDB packageDbs
    distPref  = fromFlag (regDistPref regFlags)
    verbosity = fromFlag (regVerbosity regFlags)

    writeRegistrationFile installedPkgInfo = do
      notice verbosity ("Creating package registration file: " ++ regFile)
      writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)

register _ _ regFlags = notice verbosity "No package to register"
  where
    verbosity = fromFlag (regVerbosity regFlags)


------------------------------------------------------------------------------
-- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later
------------------------------------------------------------------------------

adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
adjustLocalBuildInfo lbi =
  let extra = (Just libBi, [])
      libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi
                                             , buildDir lbi ] }
   in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }

------------------------------------------------------------------------------
-- Processing .chs files with our local c2hs.
------------------------------------------------------------------------------

ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ourC2hs bi lbi = PreProcessor {
  platformIndependent = False,
  runPreProcessor = runC2HS bi lbi
}

runC2HS :: BuildInfo -> LocalBuildInfo ->
           (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
runC2HS bi lbi (inDir, inFile)  (outDir, outFile) verbosity = do
  -- have the header file name if we don't have the precompiled header yet
  header <- case lookup "x-c2hs-header" (customFieldsBI bi) of
    Just h -> return h
    Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++
                    "that sets the C header file to process .chs.pp files.")

  -- c2hs will output files in out dir, removing any leading path of the input file.
  -- Thus, append the dir of the input file to the output dir.
  let (outFileDir, newOutFile) = splitFileName outFile
  let newOutDir = outDir </> outFileDir
  -- additional .chi files might be needed that other packages have installed;
  -- we assume that these are installed in the same place as .hi files
  let chiDirs = [ dir |
                  ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),
                  dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]
  (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
  rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $
       map ("--include=" ++) (outDir:chiDirs)
    ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]
    ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]
    ++ ["--output-dir=" ++ newOutDir,
        "--output=" ++ newOutFile,
        "--precomp=" ++ buildDir lbi </> precompFile,
        header, inDir </> inFile]

getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
getCppOptions bi lbi
    = nub $
      ["-I" ++ dir | dir <- PD.includeDirs bi]
   ++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"]
   ++ ["-D__GLASGOW_HASKELL__="++show (ghcDefine . ghcVersion . compilerId $ LBI.compiler lbi)]
 where
  ghcDefine (v1:v2:_) = v1 * 100 + v2
  ghcDefine _ = __GLASGOW_HASKELL__

  ghcVersion :: CompilerId -> [Int]
-- This version is nicer, but we need to know the Cabal version that includes the new CompilerId
-- #if CABAL_VERSION_CHECK(1,19,2)
--   ghcVersion (CompilerId GHC v _) = versionBranch v
--   ghcVersion (CompilerId _ _ (Just c)) = ghcVersion c
-- #else
--   ghcVersion (CompilerId GHC v) = versionBranch v
-- #endif
--   ghcVersion _ = []
-- This version should work fine for now
  ghcVersion = concat . take 1 . map (read . (++"]") . takeWhile (/=']')) . catMaybes
               . map (stripPrefix "CompilerId GHC (Version {versionBranch = ") . tails . show

installCHI :: PackageDescription -- ^information from the .cabal file
        -> LocalBuildInfo -- ^information from the configure step
        -> Verbosity -> CopyDest -- ^flags sent to copy or install
        -> IO ()
installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do
  let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest
  -- cannot use the recommended 'findModuleFiles' since it fails if there exists
  -- a modules that does not have a .chi file
  mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath)
                   (PD.libModules lib)

  let files = [ f | Just f <- mFiles ]
  installOrdinaryFiles verbosity libPref files


installCHI _ _ _ _ = return ()

------------------------------------------------------------------------------
-- Generating the type hierarchy and signal callback .hs files.
------------------------------------------------------------------------------

typeGenProgram :: Program
typeGenProgram = simpleProgram "gtk2hsTypeGen"

signalGenProgram :: Program
signalGenProgram = simpleProgram "gtk2hsHookGenerator"

c2hsLocal :: Program
c2hsLocal = (simpleProgram "gtk2hsC2hs") {
    programFindVersion = findProgramVersion "--version" $ \str ->
      -- Invoking "gtk2hsC2hs --version" gives a string like:
      -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004
      case words str of
        (_:_:_:ver:_) -> ver
        _             -> ""
  }


genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
genSynthezisedFiles verb pd lbi = do
  cPkgs <- getPkgConfigPackages verb lbi pd

  let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)
              ++customFieldsPD pd
      typeOpts :: String -> [ProgArg]
      typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field ++ '=':val) (words content)
                            | (field,content) <- xList,
                              tag `isPrefixOf` field,
                              field /= (tag++"file")]
              ++ [ "--tag=" ++ tag
                 | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
                 , let name' = filter isAlpha (display name)
                 , tag <- name'
                        :[ name' ++ "-" ++ show maj ++ "." ++ show d2
                          | (maj, d2) <- [(maj,   d2) | maj <- [0..(major-1)], d2 <- [0,2..20]]
                                      ++ [(major, d2) | d2 <- [0,2..minor]] ]
                 ]

      signalsOpts :: [ProgArg]
      signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content)
                        | (field,content) <- xList,
                          "x-signals-" `isPrefixOf` field,
                          field /= "x-signals-file"]

      genFile :: Program -> [ProgArg] -> FilePath -> IO ()
      genFile prog args outFile = do
         res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args
         rewriteFile outFile res

  forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $
    \(fileTag, f) -> do
      let tag = reverse (drop 4 (reverse fileTag))
      info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")
      genFile typeGenProgram (typeOpts tag) f

  case lookup "x-signals-file" xList of
    Nothing -> return ()
    Just f -> do
      info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")
      genFile signalGenProgram signalsOpts f

  writeFile "gtk2hs_macros.h" $ generateMacros cPkgs

-- Based on Cabal/Distribution/Simple/Build/Macros.hs
generateMacros :: [PackageId] -> String
generateMacros cPkgs = concat $
  "/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" :
  [ concat
    ["/* package ",display pkgid," */\n"
    ,"#define VERSION_",pkgname," ",show (display version),"\n"
    ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"
    ,"  (major1) <  ",major1," || \\\n"
    ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
    ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
    ,"\n\n"
    ]
  | pkgid@(PackageIdentifier name version) <- cPkgs
  , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
        pkgname = map fixchar (display name)
  ]
  where fixchar '-' = '_'
        fixchar '.' = '_'
        fixchar c   = c

--FIXME: Cabal should tell us the selected pkg-config package versions in the
--       LocalBuildInfo or equivalent.
--       In the mean time, ask pkg-config again.

getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
getPkgConfigPackages verbosity lbi pkg =
  sequence
    [ do version <- pkgconfig ["--modversion", display pkgname]
         case simpleParse version of
           Nothing -> die "parsing output of pkg-config --modversion failed"
           Just v  -> return (PackageIdentifier pkgname v)
    | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]
  where
    pkgconfig = rawSystemProgramStdoutConf verbosity
                  pkgConfigProgram (withPrograms lbi)

------------------------------------------------------------------------------
-- Dependency calculation amongst .chs files.
------------------------------------------------------------------------------

-- Given all files of the package, find those that end in .chs and extract the
-- .chs files they depend upon. Then return the PackageDescription with these
-- files rearranged so that they are built in a sequence that files that are
-- needed by other files are built first.
fixDeps :: PackageDescription -> IO PackageDescription
fixDeps pd@PD.PackageDescription {
          PD.library = Just lib@PD.Library {
            PD.exposedModules = expMods,
            PD.libBuildInfo = bi@PD.BuildInfo {
              PD.hsSourceDirs = srcDirs,
              PD.otherModules = othMods
            }}} = do
  let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs
                       (joinPath (components m))
  mExpFiles <- mapM findModule expMods
  mOthFiles <- mapM findModule othMods

  -- tag all exposed files with True so we throw an error if we need to build
  -- an exposed module before an internal modules (we cannot express this)
  let modDeps = zipWith (ModDep True []) expMods mExpFiles++
                zipWith (ModDep False []) othMods mOthFiles
  modDeps <- mapM extractDeps modDeps
  let (othMods, expMods) = span (not . mdExposed) $ reverse $ sortTopological modDeps
  return pd { PD.library = Just lib {
    PD.exposedModules = map mdOriginal (reverse expMods),
    PD.libBuildInfo = bi { PD.otherModules = map mdOriginal (reverse othMods) }
  }}

data ModDep = ModDep {
  mdExposed :: Bool,
  mdRequires :: [ModuleName],
  mdOriginal :: ModuleName,
  mdLocation :: Maybe FilePath
}

instance Show ModDep where
  show x = show (mdLocation x)

instance Eq ModDep where
  ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2
instance Ord ModDep where
  compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2

-- Extract the dependencies of this file. This is intentionally rather naive as it
-- ignores CPP conditionals. We just require everything which means that the
-- existance of a .chs module may not depend on some CPP condition.
extractDeps :: ModDep -> IO ModDep
extractDeps md@ModDep { mdLocation = Nothing } = return md
extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do
  let findImports acc (('{':'#':xs):xxs) = case (dropWhile (' ' ==) xs) of
        ('i':'m':'p':'o':'r':'t':' ':ys) ->
          case simpleParse (takeWhile ('#' /=) ys) of
            Just m -> findImports (m:acc) xxs
            Nothing -> die ("cannot parse chs import in "++f++":\n"++
                            "offending line is {#"++xs)
         -- no more imports after the first non-import hook
        _ -> return acc
      findImports acc (_:xxs) = findImports acc xxs
      findImports acc [] = return acc
  mods <- findImports [] (lines con)
  return md { mdRequires = mods }

-- Find a total order of the set of modules that are partially sorted by their
-- dependencies on each other. The function returns the sorted list of modules
-- together with a list of modules that are required but not supplied by this
-- in the input set of modules.
sortTopological :: [ModDep] -> [ModDep]
sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)
  where
  set = M.fromList (map (\m -> (mdOriginal m, m)) ms)
  visit (out,visited) m
    | m `S.member` visited = (out,visited)
    | otherwise = case m `M.lookup` set of
        Nothing -> (out, m `S.insert` visited)
        Just md -> (md:out', visited')
          where
            (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)

-- Check user whether install gtk2hs-buildtools correctly.
checkGtk2hsBuildtools :: [Program] -> IO ()
checkGtk2hsBuildtools programs = do
  programInfos <- mapM (\ prog -> do
                         location <- onDefaultSearchPath programFindLocation prog normal
                         return (programName prog, location)
                      ) programs
  let printError name = do
        putStrLn $ "Cannot find " ++ name ++ "\n"
                 ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)."
        exitFailure
  forM_ programInfos $ \ (name, location) ->
    when (isNothing location) (printError name)