{-# LANGUAGE CPP, ViewPatterns #-}
-- | Build a Gtk2hs package.
--
module Gtk2HsSetup (
  gtk2hsUserHooks,
  getPkgConfigPackages,
  checkGtk2hsBuildtools,
  typeGenProgram,
  signalGenProgram,
  c2hsLocal
  ) where

import Data.String(fromString)
import Data.Maybe (mapMaybe)
#if MIN_VERSION_Cabal(3,14,0)
import Data.Bifunctor (bimap)
#endif
#if MIN_VERSION_Cabal(2,4,0)
import Distribution.Pretty (prettyShow)
#else
import Distribution.Simple.LocalBuildInfo (getComponentLocalBuildInfo)
#endif
import Distribution.Simple
import Distribution.Simple.PreProcess
import Distribution.InstalledPackageInfo ( importDirs,
                                           showInstalledPackageInfo,
                                           libraryDirs,
                                           extraLibraries,
                                           extraGHCiLibraries )
import Distribution.Simple.PackageIndex ( lookupUnitId )
import Distribution.PackageDescription as PD ( PackageDescription(..),
                                               updatePackageDescription,
                                               BuildInfo(..),
                                               emptyBuildInfo, allBuildInfo,
                                               Library(..),
                                               explicitLibModules, hasLibs)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), buildDir,
                                           InstallDirs(..),
                                           ComponentLocalBuildInfo,
                                           componentPackageDeps,
                                           absoluteInstallDirs,
                                           relocatable,
                                           compiler)
import Distribution.Types.LocalBuildInfo as LBI (componentNameCLBIs)
import qualified Distribution.Types.LocalBuildInfo as LBI
import Distribution.Simple.Compiler  ( Compiler(..) )
import Distribution.Simple.Program (
  Program(..), ConfiguredProgram(..),
  runDbProgram, getDbProgramOutput, programName, programPath,
  c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram,
  simpleProgram, lookupProgram, getProgramOutput, ProgArg)
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Simple.Program.HcPkg ( defaultRegisterOptions )
import Distribution.Types.PkgconfigDependency ( PkgconfigDependency(..) )
import Distribution.Types.PkgconfigName
#endif
import Distribution.ModuleName ( ModuleName, components, toFilePath )
import Distribution.Simple.Utils hiding (die)
#if MIN_VERSION_Cabal(3,14,0)
import Distribution.Simple.Setup (CommonSetupFlags(..), CopyFlags(..), InstallFlags(..), 
                                  CopyDest(..), defaultCommonSetupFlags, defaultCopyFlags, 
                                  ConfigFlags(configVerbosity), fromFlag, toFlag, 
                                  RegisterFlags(..), flagToMaybe, fromFlagOrDefault, 
                                  defaultRegisterFlags)
#else
import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
                                  defaultCopyFlags, ConfigFlags(configVerbosity),
                                  fromFlag, toFlag, RegisterFlags(..), flagToMaybe,
                                  fromFlagOrDefault, defaultRegisterFlags)
#endif
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Simple.BuildPaths ( autogenPackageModulesDir )
#endif
import Distribution.Simple.Install ( install )
#if MIN_VERSION_Cabal(3,14,0)
import Distribution.Utils.Path (getSymbolicPath, makeRelativePathEx)
#endif
import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage )
import Distribution.Text ( simpleParse, display )
import System.FilePath
import System.Exit (die, 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.PackageDescription as PD
import qualified Distribution.Simple.LocalBuildInfo as LBI
import qualified Distribution.InstalledPackageInfo as IPI
       (installedUnitId)
import Distribution.Simple.Compiler (compilerVersion)
import qualified Distribution.Compat.Graph as Graph
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (getSymbolicPath)
#endif 

import Control.Applicative ((<$>))

import Distribution.Simple.Program.Find ( defaultProgramSearchPath )
import Gtk2HsC2Hs (c2hsMain)
import HookGenerator (hookGen)
import TypeGen (typeGen)
import UNames (unsafeResetRootNameSupply)

#if !MIN_VERSION_Cabal(2,0,0)
versionNumbers :: Version -> [Int]
versionNumbers = versionBranch
#endif

onDefaultSearchPath :: (t -> t -> ProgramSearchPath -> t) -> t -> t -> t
onDefaultSearchPath t -> t -> ProgramSearchPath -> t
f t
a t
b = t -> t -> ProgramSearchPath -> t
f t
a t
b ProgramSearchPath
defaultProgramSearchPath
#if MIN_VERSION_Cabal(2,5,0)
componentsConfigs :: LocalBuildInfo -> [(LBI.ComponentName, ComponentLocalBuildInfo, [LBI.ComponentName])]
componentsConfigs :: LocalBuildInfo
-> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
componentsConfigs LocalBuildInfo
lbi =
    [ (ComponentLocalBuildInfo -> ComponentName
LBI.componentLocalName ComponentLocalBuildInfo
clbi,
       ComponentLocalBuildInfo
clbi,
       (UnitId -> Maybe ComponentName) -> [UnitId] -> [ComponentName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ComponentLocalBuildInfo -> ComponentName)
-> Maybe ComponentLocalBuildInfo -> Maybe ComponentName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ComponentLocalBuildInfo -> ComponentName
LBI.componentLocalName (Maybe ComponentLocalBuildInfo -> Maybe ComponentName)
-> (UnitId -> Maybe ComponentLocalBuildInfo)
-> UnitId
-> Maybe ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
 -> Graph ComponentLocalBuildInfo -> Maybe ComponentLocalBuildInfo)
-> Graph ComponentLocalBuildInfo
-> UnitId
-> Maybe ComponentLocalBuildInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId
-> Graph ComponentLocalBuildInfo -> Maybe ComponentLocalBuildInfo
Key ComponentLocalBuildInfo
-> Graph ComponentLocalBuildInfo -> Maybe ComponentLocalBuildInfo
forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup Graph ComponentLocalBuildInfo
g)
                (ComponentLocalBuildInfo -> [UnitId]
LBI.componentInternalDeps ComponentLocalBuildInfo
clbi))
    | ComponentLocalBuildInfo
clbi <- Graph ComponentLocalBuildInfo -> [ComponentLocalBuildInfo]
forall a. Graph a -> [a]
Graph.toList Graph ComponentLocalBuildInfo
g ]
  where
    g :: Graph ComponentLocalBuildInfo
g = LocalBuildInfo -> Graph ComponentLocalBuildInfo
LBI.componentGraph LocalBuildInfo
lbi

libraryConfig :: LocalBuildInfo -> Maybe ComponentLocalBuildInfo
libraryConfig LocalBuildInfo
lbi = case [ComponentLocalBuildInfo
clbi | (LBI.CLibName LibraryName
_, ComponentLocalBuildInfo
clbi, [ComponentName]
_) <- LocalBuildInfo
-> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
componentsConfigs LocalBuildInfo
lbi] of
#else
libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of
#endif
  [ComponentLocalBuildInfo
clbi] -> ComponentLocalBuildInfo -> Maybe ComponentLocalBuildInfo
forall a. a -> Maybe a
Just ComponentLocalBuildInfo
clbi
  [ComponentLocalBuildInfo]
_ -> Maybe ComponentLocalBuildInfo
forall a. Maybe a
Nothing

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

gtk2hsUserHooks :: UserHooks
gtk2hsUserHooks = UserHooks
simpleUserHooks {
    -- hookedPrograms is only included for backwards compatibility with older Setup.hs.
    hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],
    hookedPreProcessors = [(fromString "chs", ourC2hs)],
    confHook = \(GenericPackageDescription, HookedBuildInfo)
pd ConfigFlags
cf ->
      ((LocalBuildInfo -> LocalBuildInfo)
-> IO LocalBuildInfo -> IO LocalBuildInfo
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalBuildInfo -> LocalBuildInfo
adjustLocalBuildInfo (UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
simpleUserHooks (GenericPackageDescription, HookedBuildInfo)
pd ConfigFlags
cf)),
    postConf = \Args
args ConfigFlags
cf PackageDescription
pd LocalBuildInfo
lbi -> do
      Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
genSynthezisedFiles (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
cf)) PackageDescription
pd LocalBuildInfo
lbi
      UserHooks
-> Args
-> ConfigFlags
-> PackageDescription
-> LocalBuildInfo
-> IO ()
postConf UserHooks
simpleUserHooks Args
args ConfigFlags
cf PackageDescription
pd LocalBuildInfo
lbi,
    buildHook = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh BuildFlags
bf -> PackageDescription -> IO PackageDescription
fixDeps PackageDescription
pd IO PackageDescription -> (PackageDescription -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PackageDescription
pd ->
                                 UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
buildHook UserHooks
simpleUserHooks PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh BuildFlags
bf,
    copyHook = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh CopyFlags
flags -> UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> CopyFlags
-> IO ()
copyHook UserHooks
simpleUserHooks PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh CopyFlags
flags IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      PackageDescription
-> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()
installCHI PackageDescription
pd LocalBuildInfo
lbi (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (CopyFlags -> Flag Verbosity
copyVerbosity CopyFlags
flags)) (Flag CopyDest -> CopyDest
forall a. WithCallStack (Flag a -> a)
fromFlag (CopyFlags -> Flag CopyDest
copyDest CopyFlags
flags)),
    instHook = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh InstallFlags
flags ->
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
      installHook pd lbi uh flags >>
      installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest,
    regHook = registerHook
#else
      UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> InstallFlags
-> IO ()
instHook UserHooks
simpleUserHooks PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh InstallFlags
flags IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      PackageDescription
-> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()
installCHI PackageDescription
pd LocalBuildInfo
lbi (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (InstallFlags -> Flag Verbosity
installVerbosity InstallFlags
flags)) CopyDest
NoCopyDest
#endif
  }

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

getDlls :: [FilePath] -> IO [FilePath]
getDlls :: Args -> IO Args
getDlls Args
dirs = (String -> Bool) -> Args -> Args
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".dll") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) (Args -> Args) -> ([Args] -> Args) -> [Args] -> Args
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Args] -> Args
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Args] -> Args) -> IO [Args] -> IO Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (String -> IO Args) -> Args -> IO [Args]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO Args
getDirectoryContents Args
dirs

fixLibs :: [FilePath] -> [String] -> [String]
fixLibs :: Args -> Args -> Args
fixLibs Args
dlls = (String -> Args) -> Args -> Args
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> Args) -> Args -> Args)
-> (String -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$ \ String
lib ->
    case (String -> Bool) -> Args -> Args
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
isLib String
lib) Args
dlls of
                dlls :: Args
dlls@(String
_:Args
_) -> [String -> String
dropExtension (Args -> String
forall {a}. [[a]] -> [a]
pickDll Args
dlls)]
                Args
_          -> if String
lib String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"z" then [] else [String
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 :: [[a]] -> [a]
pickDll = ([a] -> [a] -> Ordering) -> [[a]] -> [a]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (([a] -> Int) -> [a] -> [a] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Ord.comparing [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
    isLib :: String -> String -> Bool
isLib String
lib String
dll =
        case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String
"lib"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lib) String
dll of
            Just (Char
'.':String
_)                -> Bool
True
            Just (Char
'-':Char
n:String
_) | Char -> Bool
isNumber Char
n -> Bool
True
            Maybe String
_                           -> Bool
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 :: PackageDescription
-> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
installHook PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo UserHooks
_ InstallFlags
flags = do
# if MIN_VERSION_Cabal(3,14,0)
  let copyFlags = defaultCopyFlags { 
                        copyCommonFlags = defaultCommonSetupFlags {
                          setupDistPref = installDistPref flags,
                          setupVerbosity = installVerbosity flags
                        },
                        copyDest = toFlag NoCopyDest 
                   }
#else
  let copyFlags :: CopyFlags
copyFlags = CopyFlags
defaultCopyFlags {
                      copyDistPref   = installDistPref flags,
                      copyDest       = toFlag NoCopyDest,
                      copyVerbosity  = installVerbosity flags
                  }
#endif
  PackageDescription -> LocalBuildInfo -> CopyFlags -> IO ()
install PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo CopyFlags
copyFlags
#if MIN_VERSION_Cabal(3,14,0)
  let registerFlags = defaultRegisterFlags {
                          registerCommonFlags  = defaultCommonSetupFlags {
                             setupDistPref = installDistPref flags,
                             setupVerbosity = installVerbosity flags
                                                },
                          regInPlace   = installInPlace flags,
                          regPackageDB = installPackageDB flags
                      }
#else
  let registerFlags :: RegisterFlags
registerFlags = RegisterFlags
defaultRegisterFlags {
                          regDistPref = installDistPref flags,
                          regInPlace   = installInPlace flags,
                          regPackageDB = installPackageDB flags,
                          regVerbosity = installVerbosity flags
                      }
#endif
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageDescription -> Bool
hasLibs PackageDescription
pkg_descr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
register PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo RegisterFlags
registerFlags

registerHook :: PackageDescription -> LocalBuildInfo
        -> UserHooks -> RegisterFlags -> IO ()
registerHook :: PackageDescription
-> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()
registerHook PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo UserHooks
_ RegisterFlags
flags =
    if PackageDescription -> Bool
hasLibs PackageDescription
pkg_descr
    then PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
register PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo RegisterFlags
flags
    else Verbosity -> String -> PackageId -> IO ()
setupMessage Verbosity
verbosity
           String
"Package contains no library to register:" (PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg_descr)
#if MIN_VERSION_Cabal(3,14,0)
  where verbosity = fromFlag (setupVerbosity . registerCommonFlags $ flags)
#else
  where verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
flags)
#endif
#if MIN_VERSION_Cabal(2,4,0)
getComponentLocalBuildInfo :: LocalBuildInfo -> LBI.ComponentName -> ComponentLocalBuildInfo
getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
getComponentLocalBuildInfo LocalBuildInfo
lbi ComponentName
cname =
    case LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo]
LBI.componentNameCLBIs LocalBuildInfo
lbi ComponentName
cname of
      [ComponentLocalBuildInfo
clbi] -> ComponentLocalBuildInfo
clbi
      [] ->
          String -> ComponentLocalBuildInfo
forall a. HasCallStack => String -> a
error (String -> ComponentLocalBuildInfo)
-> String -> ComponentLocalBuildInfo
forall a b. (a -> b) -> a -> b
$ String
"internal error: there is no configuration data "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"for component " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
forall a. Show a => a -> String
show ComponentName
cname
      [ComponentLocalBuildInfo]
clbis ->
          String -> ComponentLocalBuildInfo
forall a. HasCallStack => String -> a
error (String -> ComponentLocalBuildInfo)
-> String -> ComponentLocalBuildInfo
forall a b. (a -> b) -> a -> b
$ String
"internal error: the component name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
forall a. Show a => a -> String
show ComponentName
cname
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is ambiguous.  Refers to: "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Args -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((ComponentLocalBuildInfo -> String)
-> [ComponentLocalBuildInfo] -> Args
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> String
forall a. Pretty a => a -> String
prettyShow (UnitId -> String)
-> (ComponentLocalBuildInfo -> UnitId)
-> ComponentLocalBuildInfo
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentLocalBuildInfo -> UnitId
LBI.componentUnitId) [ComponentLocalBuildInfo]
clbis)
#endif

register :: PackageDescription -> LocalBuildInfo
         -> RegisterFlags -- ^Install in the user's database?; verbose
         -> IO ()
register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
register pkg :: PackageDescription
pkg@PackageDescription { library :: PackageDescription -> Maybe Library
library       = Just Library
lib  } LocalBuildInfo
lbi RegisterFlags
regFlags
  = do
    let clbi :: ComponentLocalBuildInfo
clbi = LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
getComponentLocalBuildInfo LocalBuildInfo
lbi
#if MIN_VERSION_Cabal(2,5,0)
                   (LibraryName -> ComponentName
LBI.CLibName (LibraryName -> ComponentName) -> LibraryName -> ComponentName
forall a b. (a -> b) -> a -> b
$ Library -> LibraryName
PD.libName Library
lib)
#else
                    LBI.CLibName
#endif

#if MIN_VERSION_Cabal(3,14,0)
    absPackageDBs       <- absolutePackageDBPaths Nothing packageDbs
#else
    absPackageDBs       <- PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths PackageDBStack
packageDbs
#endif
    installedPkgInfoRaw <- generateRegistrationInfo
                           verbosity pkg lib lbi clbi inplace reloc distPref
                           (registrationPackageDB absPackageDBs)

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

    when (fromFlag (regPrintId regFlags)) $ do
      putStrLn (display (IPI.installedUnitId installedPkgInfo))

     -- Three different modes:
    case () of
     ()
_ | Bool
modeGenerateRegFile   -> InstalledPackageInfo -> IO ()
writeRegistrationFile InstalledPackageInfo
installedPkgInfo
       | Bool
modeGenerateRegScript -> String -> IO ()
forall a. String -> IO a
die String
"Generate Reg Script not supported"
       | Bool
otherwise             -> do
           Verbosity -> String -> PackageId -> IO ()
setupMessage Verbosity
verbosity String
"Registering" (PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg)
#if MIN_VERSION_Cabal(3,14,0)
           registerPackage verbosity (compiler lbi) (withPrograms lbi) Nothing
#else
           Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
#endif
#if MIN_VERSION_Cabal(2,0,0)
             PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
defaultRegisterOptions
#else
             False packageDbs installedPkgInfo
#endif

  where
    modeGenerateRegFile :: Bool
modeGenerateRegFile = Maybe (Maybe String) -> Bool
forall a. Maybe a -> Bool
isJust (Flag (Maybe String) -> Maybe (Maybe String)
forall a. Flag a -> Maybe a
flagToMaybe (RegisterFlags -> Flag (Maybe String)
regGenPkgConf RegisterFlags
regFlags))
#if MIN_VERSION_Cabal(3,14,0)
    regFile             = fromMaybe (display (packageId pkg) <.> "conf")
                                    (getSymbolicPath <$> fromFlag (regGenPkgConf regFlags))
#else
    regFile :: String
regFile             = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (PackageId -> String
forall a. Pretty a => a -> String
display (PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg) String -> String -> String
<.> String
"conf")
                                    (Flag (Maybe String) -> Maybe String
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag (Maybe String)
regGenPkgConf RegisterFlags
regFlags))
#endif
    modeGenerateRegScript :: Bool
modeGenerateRegScript = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regGenScript RegisterFlags
regFlags)
    inplace :: Bool
inplace   = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regInPlace RegisterFlags
regFlags)
    reloc :: Bool
reloc     = LocalBuildInfo -> Bool
relocatable LocalBuildInfo
lbi
    packageDbs :: PackageDBStack
packageDbs = PackageDBStack -> PackageDBStack
forall a. Eq a => [a] -> [a]
nub (PackageDBStack -> PackageDBStack)
-> PackageDBStack -> PackageDBStack
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
                    PackageDBStack -> PackageDBStack -> PackageDBStack
forall a. [a] -> [a] -> [a]
++ Maybe PackageDB -> PackageDBStack
forall a. Maybe a -> [a]
maybeToList (Flag PackageDB -> Maybe PackageDB
forall a. Flag a -> Maybe a
flagToMaybe  (RegisterFlags -> Flag PackageDB
regPackageDB RegisterFlags
regFlags))
#if MIN_VERSION_Cabal(3,14,0)
    distPref  = fromFlag (setupDistPref . registerCommonFlags $ regFlags)
    verbosity = fromFlag (setupVerbosity . registerCommonFlags $ regFlags)
#else
    distPref :: String
distPref  = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag String
regDistPref RegisterFlags
regFlags)
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)
#endif
    writeRegistrationFile :: InstalledPackageInfo -> IO ()
writeRegistrationFile InstalledPackageInfo
installedPkgInfo = do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String
"Creating package registration file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
regFile)
      String -> String -> IO ()
writeUTF8File String
regFile (InstalledPackageInfo -> String
showInstalledPackageInfo InstalledPackageInfo
installedPkgInfo)

register PackageDescription
_ LocalBuildInfo
_ RegisterFlags
regFlags = Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"No package to register"
  where
#if MIN_VERSION_Cabal(3,14,0)
    verbosity = fromFlag (setupVerbosity . registerCommonFlags $ regFlags)
#else
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)
#endif

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

#if MIN_VERSION_Cabal(2,0,0)
adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
adjustLocalBuildInfo = LocalBuildInfo -> LocalBuildInfo
forall a. a -> a
id
#else
adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
adjustLocalBuildInfo lbi =
  let extra = (Just libBi, [])
      libBi = emptyBuildInfo { includeDirs = [ autogenPackageModulesDir lbi
                                             , buildDir lbi ] }
   in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }
#endif

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

#if MIN_VERSION_Cabal(2,0,0)
ourC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ourC2hs :: BuildInfo
-> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ourC2hs BuildInfo
bi LocalBuildInfo
lbi ComponentLocalBuildInfo
_ = PreProcessor {
#else
ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ourC2hs bi lbi = PreProcessor {
#endif
#if MIN_VERSION_Cabal(3,8,1)
  ppOrdering :: Verbosity -> Args -> [ModuleName] -> IO [ModuleName]
ppOrdering = \Verbosity
_ Args
_ [ModuleName]
ms -> [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ModuleName]
ms,
#endif
  platformIndependent :: Bool
platformIndependent = Bool
False,
  runPreProcessor :: (String, String) -> (String, String) -> Verbosity -> IO ()
runPreProcessor = BuildInfo
-> LocalBuildInfo
-> (String, String)
-> (String, String)
-> Verbosity
-> IO ()
runC2HS BuildInfo
bi LocalBuildInfo
lbi
}

runC2HS :: BuildInfo -> LocalBuildInfo ->
           (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
runC2HS :: BuildInfo
-> LocalBuildInfo
-> (String, String)
-> (String, String)
-> Verbosity
-> IO ()
runC2HS BuildInfo
bi LocalBuildInfo
lbi (String
inDir, String
inFile)  (String
outDir, String
outFile) Verbosity
verbosity = do
  -- have the header file name if we don't have the precompiled header yet
  header <- case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"x-c2hs-header" (BuildInfo -> [(String, String)]
customFieldsBI BuildInfo
bi) of
    Just String
h -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
h
    Maybe String
Nothing -> String -> IO String
forall a. String -> IO a
die (String
"Need x-c2hs-Header definition in the .cabal Library section "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
"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 = String
outDir String -> String -> String
</> String
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 = [ String
dir |
                  UnitId
ipi <- [UnitId]
-> (ComponentLocalBuildInfo -> [UnitId])
-> Maybe ComponentLocalBuildInfo
-> [UnitId]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((UnitId, MungedPackageId) -> UnitId)
-> [(UnitId, MungedPackageId)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, MungedPackageId)] -> [UnitId])
-> (ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)])
-> ComponentLocalBuildInfo
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps) (LocalBuildInfo -> Maybe ComponentLocalBuildInfo
libraryConfig LocalBuildInfo
lbi),
                  String
dir <- Args
-> (InstalledPackageInfo -> Args)
-> Maybe InstalledPackageInfo
-> Args
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] InstalledPackageInfo -> Args
importDirs (PackageIndex InstalledPackageInfo
-> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
lookupUnitId (LocalBuildInfo -> PackageIndex InstalledPackageInfo
installedPkgs LocalBuildInfo
lbi) UnitId
ipi) ]
  (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
  unsafeResetRootNameSupply
  c2hsMain $
       map ("--include=" ++) (outDir:chiDirs)
    ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]
    ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]
    ++ ["--output-dir=" ++ newOutDir,
        "--output=" ++ newOutFile,
#if MIN_VERSION_Cabal(3,14,0)
        "--precomp=" ++ (getSymbolicPath . buildDir $ lbi) </> precompFile,
#else
        "--precomp=" ++ buildDir lbi </> precompFile,
#endif
        header, inDir </> inFile]
  return ()

getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
getCppOptions :: BuildInfo -> LocalBuildInfo -> Args
getCppOptions BuildInfo
bi LocalBuildInfo
lbi
    = Args -> Args
forall a. Eq a => [a] -> [a]
nub (Args -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_Cabal(3,14,0)
      ["-I" ++ getSymbolicPath dir | dir <- PD.includeDirs bi]
#else
      [String
"-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir | String
dir <- BuildInfo -> Args
PD.includeDirs BuildInfo
bi]
#endif
   Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [String
opt | opt :: String
opt@(Char
'-':Char
c:String
_) <- BuildInfo -> Args
PD.cppOptions BuildInfo
bi Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ BuildInfo -> Args
PD.ccOptions BuildInfo
bi, Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"DIU"]

installCHI :: PackageDescription -- ^information from the .cabal file
        -> LocalBuildInfo -- ^information from the configure step
        -> Verbosity -> CopyDest -- ^flags sent to copy or install
        -> IO ()
installCHI :: PackageDescription
-> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()
installCHI pkg :: PackageDescription
pkg@PD.PackageDescription { library :: PackageDescription -> Maybe Library
library = Just Library
lib } LocalBuildInfo
lbi Verbosity
verbosity CopyDest
copydest = do
  let InstallDirs { libdir :: forall dir. InstallDirs dir -> dir
libdir = String
libPref } = PackageDescription
-> LocalBuildInfo -> CopyDest -> InstallDirs String
absoluteInstallDirs PackageDescription
pkg LocalBuildInfo
lbi CopyDest
copydest
  -- cannot use the recommended 'findModuleFiles' since it fails if there exists
  -- a modules that does not have a .chi file
#if MIN_VERSION_Cabal(3,14,0)
  mFiles <- mapM (findFileWithExtension' [fromString "chi"] [buildDir lbi] . makeRelativePathEx . toFilePath)
                   (PD.explicitLibModules lib)
#else
  mFiles <- (ModuleName -> IO (Maybe (String, String)))
-> [ModuleName] -> IO [Maybe (String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Suffix] -> Args -> String -> IO (Maybe (String, String))
findFileWithExtension' [String -> Suffix
forall a. IsString a => String -> a
fromString String
"chi"] [LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi] (String -> IO (Maybe (String, String)))
-> (ModuleName -> String)
-> ModuleName
-> IO (Maybe (String, String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
toFilePath)
                   (Library -> [ModuleName]
PD.explicitLibModules Library
lib)
#endif

#if MIN_VERSION_Cabal(3,14,0)
  let files = [ bimap getSymbolicPath getSymbolicPath $ f | Just f <- mFiles ]
#else
  let files = [ (String, String)
f | Just (String, String)
f <- [Maybe (String, String)]
mFiles ]
#endif
  installOrdinaryFiles verbosity libPref files

installCHI PackageDescription
_ LocalBuildInfo
_ Verbosity
_ CopyDest
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

  let xList = [(String, String)]
-> (Library -> [(String, String)])
-> Maybe Library
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (BuildInfo -> [(String, String)]
customFieldsBI (BuildInfo -> [(String, String)])
-> (Library -> BuildInfo) -> Library -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> BuildInfo
libBuildInfo) (PackageDescription -> Maybe Library
library PackageDescription
pd)
              [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++PackageDescription -> [(String, String)]
customFieldsPD PackageDescription
pd
      typeOpts :: String -> [ProgArg]
      typeOpts String
tag = [Args] -> Args
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (String -> String) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map (\String
val -> Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
tag) String
field String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'='Char -> String -> String
forall a. a -> [a] -> [a]
:String
val) (String -> Args
words String
content)
                            | (String
field,String
content) <- [(String, String)]
xList,
                              String
tag String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
field,
                              String
field String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= (String
tagString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"file")]
              Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [ String
"--tag=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
#if MIN_VERSION_Cabal(2,0,0)
                 | PackageIdentifier PackageName
name Version
version <- [PackageId]
cPkgs
                 , let Int
major:Int
minor:[Int]
_ = Version -> [Int]
versionNumbers Version
version
#else
                 | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
#endif
                 , let name' :: String
name' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlpha (PackageName -> String
forall a. Pretty a => a -> String
display PackageName
name)
                 , String
tag <- String
name'
                        String -> Args -> Args
forall a. a -> [a] -> [a]
:[ String
name' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
maj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
d2
                          | (Int
maj, Int
d2) <- [(Int
maj,   Int
d2) | Int
maj <- [Int
0..(Int
majorInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)], Int
d2 <- [Int
0,Int
2..Int
20]]
                                      [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
major, Int
d2) | Int
d2 <- [Int
0,Int
2..Int
minor]] ]
                 ]

      signalsOpts :: [ProgArg]
      signalsOpts = [Args] -> Args
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (String -> String) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map (\String
val -> Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
10 String
fieldString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
'='Char -> String -> String
forall a. a -> [a] -> [a]
:String
val) (String -> Args
words String
content)
                        | (String
field,String
content) <- [(String, String)]
xList,
                          String
"x-signals-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
field,
                          String
field String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"x-signals-file"]

      genFile :: ([String] -> IO String) -> [ProgArg] -> FilePath -> IO ()
      genFile Args -> IO String
prog Args
args String
outFile = do
         res <- Args -> IO String
prog Args
args
         rewriteFileEx verb outFile res

  forM_ (filter (\(String
tag,String
_) -> String
"x-types-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
tag Bool -> Bool -> Bool
&& String
"file" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
tag) xList) $
    \(String
fileTag, String
f) -> do
      let tag :: String
tag = String -> String
forall a. [a] -> [a]
reverse (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
4 (String -> String
forall a. [a] -> [a]
reverse String
fileTag))
      Verbosity -> String -> IO ()
info Verbosity
verb (String
"Ensuring that class hierarchy in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" is up-to-date.")
      (Args -> IO String) -> Args -> String -> IO ()
genFile Args -> IO String
typeGen (String -> Args
typeOpts String
tag) String
f

  case lookup "x-signals-file" xList of
    Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
f -> do
      Verbosity -> String -> IO ()
info Verbosity
verb (String
"Ensuring that callback hooks in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" are up-to-date.")
      (Args -> IO String) -> Args -> String -> IO ()
genFile Args -> IO String
hookGen Args
signalsOpts String
f

  writeFile "gtk2hs_macros.h" $ generateMacros cPkgs

-- Based on Cabal/Distribution/Simple/Build/Macros.hs
generateMacros :: [PackageId] -> String
generateMacros :: [PackageId] -> String
generateMacros [PackageId]
cPkgs = Args -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Args -> String) -> Args -> String
forall a b. (a -> b) -> a -> b
$
  String
"/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" String -> Args -> Args
forall a. a -> [a] -> [a]
:
  [ Args -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [String
"/* package ",PackageId -> String
forall a. Pretty a => a -> String
display PackageId
pkgid,String
" */\n"
    ,String
"#define VERSION_",String
pkgname,String
" ",String -> String
forall a. Show a => a -> String
show (Version -> String
forall a. Pretty a => a -> String
display Version
version),String
"\n"
    ,String
"#define MIN_VERSION_",String
pkgname,String
"(major1,major2,minor) (\\\n"
    ,String
"  (major1) <  ",String
major1,String
" || \\\n"
    ,String
"  (major1) == ",String
major1,String
" && (major2) <  ",String
major2,String
" || \\\n"
    ,String
"  (major1) == ",String
major1,String
" && (major2) == ",String
major2,String
" && (minor) <= ",String
minor,String
")"
    ,String
"\n\n"
    ]
  | pkgid :: PackageId
pkgid@(PackageIdentifier PackageName
name Version
version) <- [PackageId]
cPkgs
  , let (String
major1:String
major2:String
minor:Args
_) = (Int -> String) -> [Int] -> Args
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show (Version -> [Int]
versionNumbers Version
version [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
0)
        pkgname :: String
pkgname = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (PackageName -> String
forall a. Pretty a => a -> String
display PackageName
name)
  ]
  where fixchar :: Char -> Char
fixchar Char
'-' = Char
'_'
        fixchar Char
'.' = Char
'_'
        fixchar Char
c   = Char
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 -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
getPkgConfigPackages Verbosity
verbosity LocalBuildInfo
lbi PackageDescription
pkg =
  [IO PackageId] -> IO [PackageId]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ do version <- Args -> IO String
pkgconfig [String
"--modversion", PkgconfigName -> String
forall a. Pretty a => a -> String
display PkgconfigName
pkgname]
         case simpleParse version of
           Maybe Version
Nothing -> String -> IO PackageId
forall a. String -> IO a
die String
"parsing output of pkg-config --modversion failed"
#if MIN_VERSION_Cabal(2,0,0)
           Just Version
v  -> PackageId -> IO PackageId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Version -> PackageId
PackageIdentifier (String -> PackageName
mkPackageName (String -> PackageName) -> String -> PackageName
forall a b. (a -> b) -> a -> b
$ PkgconfigName -> String
unPkgconfigName PkgconfigName
pkgname) Version
v)
    | PkgconfigDependency PkgconfigName
pkgname PkgconfigVersionRange
_
#else
           Just v  -> return (PackageIdentifier pkgname v)
    | Dependency pkgname _
#endif
    <- (BuildInfo -> [PkgconfigDependency])
-> [BuildInfo] -> [PkgconfigDependency]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BuildInfo -> [PkgconfigDependency]
pkgconfigDepends (PackageDescription -> [BuildInfo]
allBuildInfo PackageDescription
pkg) ]
  where
    pkgconfig :: Args -> IO String
pkgconfig = Verbosity -> Program -> ProgramDb -> Args -> IO String
getDbProgramOutput Verbosity
verbosity
                  Program
pkgConfigProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
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 :: PackageDescription -> IO PackageDescription
fixDeps pd :: PackageDescription
pd@PD.PackageDescription {
          library :: PackageDescription -> Maybe Library
PD.library = Just lib :: Library
lib@PD.Library {
            exposedModules :: Library -> [ModuleName]
PD.exposedModules = [ModuleName]
expMods,
            libBuildInfo :: Library -> BuildInfo
PD.libBuildInfo = bi :: BuildInfo
bi@PD.BuildInfo {
              hsSourceDirs :: BuildInfo -> [SymbolicPath PackageDir SourceDir]
PD.hsSourceDirs = [SymbolicPath PackageDir SourceDir]
srcDirs,
              otherModules :: BuildInfo -> [ModuleName]
PD.otherModules = [ModuleName]
othMods
            }}} = do
  let toPath :: SymbolicPath from to -> String
toPath = 
#if MIN_VERSION_Cabal(3,6,0)
        SymbolicPath from to -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath
#else 
        id 
#endif 
#if MIN_VERSION_Cabal(3,14,0)
  let findModule m = findFileWithExtension [fromString ".chs.pp", fromString ".chs"] srcDirs
                       (makeRelativePathEx . toFilePath $ m)
#else
  let findModule :: ModuleName -> IO (Maybe String)
findModule ModuleName
m = [Suffix] -> Args -> String -> IO (Maybe String)
findFileWithExtension [String -> Suffix
forall a. IsString a => String -> a
fromString String
".chs.pp", String -> Suffix
forall a. IsString a => String -> a
fromString String
".chs"] ((SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> Args
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
toPath [SymbolicPath PackageDir SourceDir]
srcDirs)
                       (Args -> String
joinPath (ModuleName -> Args
components ModuleName
m))
#endif
  mExpFiles <- (ModuleName -> IO (Maybe String))
-> [ModuleName] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ModuleName -> IO (Maybe String)
findModule [ModuleName]
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)
#if MIN_VERSION_Cabal(3,14,0)  
  let modDeps = zipWith (ModDep True []) expMods (map (getSymbolicPath <$>) mExpFiles) ++
                zipWith (ModDep False []) othMods (map (getSymbolicPath <$>) mOthFiles)
#else
  let modDeps = (ModuleName -> Maybe String -> ModDep)
-> [ModuleName] -> [Maybe String] -> [ModDep]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> [ModuleName] -> ModuleName -> Maybe String -> ModDep
ModDep Bool
True []) [ModuleName]
expMods [Maybe String]
mExpFiles [ModDep] -> [ModDep] -> [ModDep]
forall a. [a] -> [a] -> [a]
++
                (ModuleName -> Maybe String -> ModDep)
-> [ModuleName] -> [Maybe String] -> [ModDep]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> [ModuleName] -> ModuleName -> Maybe String -> ModDep
ModDep Bool
False []) [ModuleName]
othMods [Maybe String]
mOthFiles
#endif
  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 {
  ModDep -> Bool
mdExposed :: Bool,
  ModDep -> [ModuleName]
mdRequires :: [ModuleName],
  ModDep -> ModuleName
mdOriginal :: ModuleName,
  ModDep -> Maybe String
mdLocation :: Maybe FilePath
}

instance Show ModDep where
  show :: ModDep -> String
show ModDep
x = Maybe String -> String
forall a. Show a => a -> String
show (ModDep -> Maybe String
mdLocation ModDep
x)

instance Eq ModDep where
  ModDep { mdOriginal :: ModDep -> ModuleName
mdOriginal = ModuleName
m1 } == :: ModDep -> ModDep -> Bool
== ModDep { mdOriginal :: ModDep -> ModuleName
mdOriginal = ModuleName
m2 } = ModuleName
m1ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==ModuleName
m2
instance Ord ModDep where
  compare :: ModDep -> ModDep -> Ordering
compare ModDep { mdOriginal :: ModDep -> ModuleName
mdOriginal = ModuleName
m1 } ModDep { mdOriginal :: ModDep -> ModuleName
mdOriginal = ModuleName
m2 } = ModuleName -> ModuleName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ModuleName
m1 ModuleName
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 :: ModDep -> IO ModDep
extractDeps md :: ModDep
md@ModDep { mdLocation :: ModDep -> Maybe String
mdLocation = Maybe String
Nothing } = ModDep -> IO ModDep
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModDep
md
extractDeps md :: ModDep
md@ModDep { mdLocation :: ModDep -> Maybe String
mdLocation = Just String
f } = String -> (String -> IO ModDep) -> IO ModDep
forall a. String -> (String -> IO a) -> IO a
withUTF8FileContents String
f ((String -> IO ModDep) -> IO ModDep)
-> (String -> IO ModDep) -> IO ModDep
forall a b. (a -> b) -> a -> b
$ \String
con -> do
  let findImports :: [a] -> Args -> IO [a]
findImports [a]
acc ((Char
'{':Char
'#':String
xs):Args
xxs) = case ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs) of
        (Char
'i':Char
'm':Char
'p':Char
'o':Char
'r':Char
't':Char
' ':String
ys) ->
          case String -> Maybe a
forall a. Parsec a => String -> Maybe a
simpleParse ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char
'#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
ys) of
            Just a
m -> [a] -> Args -> IO [a]
findImports (a
ma -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) Args
xxs
            Maybe a
Nothing -> String -> IO [a]
forall a. String -> IO a
die (String
"cannot parse chs import in "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
"offending line is {#"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xs)
         -- no more imports after the first non-import hook
        String
_ -> [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
      findImports [a]
acc (String
_:Args
xxs) = [a] -> Args -> IO [a]
findImports [a]
acc Args
xxs
      findImports [a]
acc [] = [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
  mods <- [ModuleName] -> Args -> IO [ModuleName]
forall {a}. Parsec a => [a] -> Args -> IO [a]
findImports [] (String -> Args
lines String
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 :: [ModDep] -> [ModDep]
sortTopological [ModDep]
ms = [ModDep] -> [ModDep]
forall a. [a] -> [a]
reverse ([ModDep] -> [ModDep]) -> [ModDep] -> [ModDep]
forall a b. (a -> b) -> a -> b
$ ([ModDep], Set ModuleName) -> [ModDep]
forall a b. (a, b) -> a
fst (([ModDep], Set ModuleName) -> [ModDep])
-> ([ModDep], Set ModuleName) -> [ModDep]
forall a b. (a -> b) -> a -> b
$ (([ModDep], Set ModuleName)
 -> ModuleName -> ([ModDep], Set ModuleName))
-> ([ModDep], Set ModuleName)
-> [ModuleName]
-> ([ModDep], Set ModuleName)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([ModDep], Set ModuleName)
-> ModuleName -> ([ModDep], Set ModuleName)
visit ([], Set ModuleName
forall a. Set a
S.empty) ((ModDep -> ModuleName) -> [ModDep] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModDep -> ModuleName
mdOriginal [ModDep]
ms)
  where
  set :: Map ModuleName ModDep
set = [(ModuleName, ModDep)] -> Map ModuleName ModDep
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((ModDep -> (ModuleName, ModDep))
-> [ModDep] -> [(ModuleName, ModDep)]
forall a b. (a -> b) -> [a] -> [b]
map (\ModDep
m -> (ModDep -> ModuleName
mdOriginal ModDep
m, ModDep
m)) [ModDep]
ms)
  visit :: ([ModDep], Set ModuleName)
-> ModuleName -> ([ModDep], Set ModuleName)
visit ([ModDep]
out,Set ModuleName
visited) ModuleName
m
    | ModuleName
m ModuleName -> Set ModuleName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ModuleName
visited = ([ModDep]
out,Set ModuleName
visited)
    | Bool
otherwise = case ModuleName
m ModuleName -> Map ModuleName ModDep -> Maybe ModDep
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map ModuleName ModDep
set of
        Maybe ModDep
Nothing -> ([ModDep]
out, ModuleName
m ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => a -> Set a -> Set a
`S.insert` Set ModuleName
visited)
        Just ModDep
md -> (ModDep
mdModDep -> [ModDep] -> [ModDep]
forall a. a -> [a] -> [a]
:[ModDep]
out', Set ModuleName
visited')
          where
            ([ModDep]
out',Set ModuleName
visited') = (([ModDep], Set ModuleName)
 -> ModuleName -> ([ModDep], Set ModuleName))
-> ([ModDep], Set ModuleName)
-> [ModuleName]
-> ([ModDep], Set ModuleName)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([ModDep], Set ModuleName)
-> ModuleName -> ([ModDep], Set ModuleName)
visit ([ModDep]
out, ModuleName
m ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => a -> Set a -> Set a
`S.insert` Set ModuleName
visited) (ModDep -> [ModuleName]
mdRequires ModDep
md)

-- Included for backwards compatibility with older Setup.hs.
checkGtk2hsBuildtools :: [Program] -> IO ()
checkGtk2hsBuildtools :: [Program] -> IO ()
checkGtk2hsBuildtools [Program]
programs = do
  programInfos <- (Program -> IO (String, Maybe (String, Args)))
-> [Program] -> IO [(String, Maybe (String, Args))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ Program
prog -> do
                         location <- (Program
 -> Verbosity -> ProgramSearchPath -> IO (Maybe (String, Args)))
-> Program -> Verbosity -> IO (Maybe (String, Args))
forall {t} {t} {t}.
(t -> t -> ProgramSearchPath -> t) -> t -> t -> t
onDefaultSearchPath Program
-> Verbosity -> ProgramSearchPath -> IO (Maybe (String, Args))
programFindLocation Program
prog Verbosity
normal
                         return (programName prog, location)
                      ) [Program]
programs
  let printError String
name = do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)."
        IO b
forall a. IO a
exitFailure
  forM_ programInfos $ \ (String
name, Maybe (String, Args)
location) ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (String, Args) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (String, Args)
location) (String -> IO ()
forall a. String -> IO a
printError String
name)

-- Included for backwards compatibility with older Setup.hs.
typeGenProgram :: Program
typeGenProgram :: Program
typeGenProgram = String -> Program
simpleProgram String
"gtk2hsTypeGen"

-- Included for backwards compatibility with older Setup.hs.
signalGenProgram :: Program
signalGenProgram :: Program
signalGenProgram = String -> Program
simpleProgram String
"gtk2hsHookGenerator"

-- Included for backwards compatibility with older Setup.hs.
-- We are not going to use this, so reporting the version we will use
c2hsLocal :: Program
c2hsLocal :: Program
c2hsLocal = (String -> Program
simpleProgram String
"gtk2hsC2hs") {
    programFindVersion = \Verbosity
_ String
_ -> Maybe Version -> IO (Maybe Version)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> (Version -> Maybe Version) -> Version -> IO (Maybe Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> IO (Maybe Version)) -> Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_Cabal(2,0,0)
      [Int] -> Version
mkVersion [Int
0,Int
13,Int
13]
#else
      Version [0,13,13] []
#endif
  }