{-# LANGUAGE CPP, ViewPatterns #-}
module Gtk2HsSetup (
gtk2hsUserHooks,
getPkgConfigPackages,
checkGtk2hsBuildtools,
typeGenProgram,
signalGenProgram,
c2hsLocal
) where
import Data.Maybe (mapMaybe)
#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(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms),
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)
import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
defaultCopyFlags, ConfigFlags(configVerbosity),
fromFlag, toFlag, RegisterFlags(..), flagToMaybe,
fromFlagOrDefault, defaultRegisterFlags)
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Simple.BuildPaths ( autogenPackageModulesDir )
#endif
import Distribution.Simple.Install ( install )
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
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 (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
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
precompFile :: [Char]
precompFile = [Char]
"precompchs.bin"
gtk2hsUserHooks :: UserHooks
gtk2hsUserHooks = UserHooks
simpleUserHooks {
hookedPrograms :: [Program]
hookedPrograms = [Program
typeGenProgram, Program
signalGenProgram, Program
c2hsLocal],
hookedPreProcessors :: [PPSuffixHandler]
hookedPreProcessors = [([Char]
"chs", BuildInfo
-> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ourC2hs)],
confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = \(GenericPackageDescription, HookedBuildInfo)
pd ConfigFlags
cf ->
((LocalBuildInfo -> LocalBuildInfo)
-> IO LocalBuildInfo -> IO LocalBuildInfo
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
-> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()
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
-> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
buildHook = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh BuildFlags
bf -> PackageDescription -> IO PackageDescription
fixDeps PackageDescription
pd IO PackageDescription -> (PackageDescription -> IO ()) -> IO ()
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
-> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()
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 (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
-> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
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 (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
}
getDlls :: [FilePath] -> IO [FilePath]
getDlls :: Args -> IO Args
getDlls Args
dirs = ([Char] -> Bool) -> Args -> Args
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".dll") ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
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
<$>
([Char] -> IO Args) -> Args -> IO [Args]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO Args
getDirectoryContents Args
dirs
fixLibs :: [FilePath] -> [String] -> [String]
fixLibs :: Args -> Args -> Args
fixLibs Args
dlls = ([Char] -> Args) -> Args -> Args
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> Args) -> Args -> Args)
-> ([Char] -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$ \ [Char]
lib ->
case ([Char] -> Bool) -> Args -> Args
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
isLib [Char]
lib) Args
dlls of
dlls :: Args
dlls@([Char]
_:Args
_) -> [[Char] -> [Char]
dropExtension (Args -> [Char]
forall a. [[a]] -> [a]
pickDll Args
dlls)]
Args
_ -> if [Char]
lib [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"z" then [] else [[Char]
lib]
where
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 (t :: * -> *) a. Foldable t => t a -> Int
length)
isLib :: [Char] -> [Char] -> Bool
isLib [Char]
lib [Char]
dll =
case [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([Char]
"lib"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
lib) [Char]
dll of
Just (Char
'.':[Char]
_) -> Bool
True
Just (Char
'-':Char
n:[Char]
_) | Char -> Bool
isNumber Char
n -> Bool
True
Maybe [Char]
_ -> Bool
False
installHook :: PackageDescription -> LocalBuildInfo
-> UserHooks -> InstallFlags -> IO ()
installHook :: PackageDescription
-> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
installHook PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo UserHooks
_ InstallFlags
flags = do
let copyFlags :: CopyFlags
copyFlags = CopyFlags
defaultCopyFlags {
copyDistPref :: Flag [Char]
copyDistPref = InstallFlags -> Flag [Char]
installDistPref InstallFlags
flags,
copyDest :: Flag CopyDest
copyDest = CopyDest -> Flag CopyDest
forall a. a -> Flag a
toFlag CopyDest
NoCopyDest,
copyVerbosity :: Flag Verbosity
copyVerbosity = InstallFlags -> Flag Verbosity
installVerbosity InstallFlags
flags
}
PackageDescription -> LocalBuildInfo -> CopyFlags -> IO ()
install PackageDescription
pkg_descr LocalBuildInfo
localbuildinfo CopyFlags
copyFlags
let registerFlags :: RegisterFlags
registerFlags = RegisterFlags
defaultRegisterFlags {
regDistPref :: Flag [Char]
regDistPref = InstallFlags -> Flag [Char]
installDistPref InstallFlags
flags,
regInPlace :: Flag Bool
regInPlace = InstallFlags -> Flag Bool
installInPlace InstallFlags
flags,
regPackageDB :: Flag PackageDB
regPackageDB = InstallFlags -> Flag PackageDB
installPackageDB InstallFlags
flags,
regVerbosity :: Flag Verbosity
regVerbosity = InstallFlags -> Flag Verbosity
installVerbosity InstallFlags
flags
}
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 -> [Char] -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity
[Char]
"Package contains no library to register:" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr)
where verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
flags)
#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
[] ->
[Char] -> ComponentLocalBuildInfo
forall a. HasCallStack => [Char] -> a
error ([Char] -> ComponentLocalBuildInfo)
-> [Char] -> ComponentLocalBuildInfo
forall a b. (a -> b) -> a -> b
$ [Char]
"internal error: there is no configuration data "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"for component " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ComponentName -> [Char]
forall a. Show a => a -> [Char]
show ComponentName
cname
[ComponentLocalBuildInfo]
clbis ->
[Char] -> ComponentLocalBuildInfo
forall a. HasCallStack => [Char] -> a
error ([Char] -> ComponentLocalBuildInfo)
-> [Char] -> ComponentLocalBuildInfo
forall a b. (a -> b) -> a -> b
$ [Char]
"internal error: the component name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ComponentName -> [Char]
forall a. Show a => a -> [Char]
show ComponentName
cname
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"is ambiguous. Refers to: "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Args -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((ComponentLocalBuildInfo -> [Char])
-> [ComponentLocalBuildInfo] -> Args
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (UnitId -> [Char])
-> (ComponentLocalBuildInfo -> UnitId)
-> ComponentLocalBuildInfo
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentLocalBuildInfo -> UnitId
LBI.componentUnitId) [ComponentLocalBuildInfo]
clbis)
#endif
register :: PackageDescription -> LocalBuildInfo
-> RegisterFlags
-> 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
PackageDBStack
absPackageDBs <- PackageDBStack -> NoCallStackIO PackageDBStack
absolutePackageDBPaths PackageDBStack
packageDbs
InstalledPackageInfo
installedPkgInfoRaw <- Verbosity
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Bool
-> [Char]
-> PackageDB
-> IO InstalledPackageInfo
generateRegistrationInfo
Verbosity
verbosity PackageDescription
pkg Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
inplace Bool
reloc [Char]
distPref
(PackageDBStack -> PackageDB
registrationPackageDB PackageDBStack
absPackageDBs)
Args
dllsInScope <- IO Args
getSearchPath IO Args -> (Args -> IO Args) -> IO Args
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([Char] -> IO Bool) -> Args -> IO Args
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesDirectoryExist) IO Args -> (Args -> IO Args) -> IO Args
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Args -> IO Args
getDlls
let libs :: Args
libs = Args -> Args -> Args
fixLibs Args
dllsInScope (InstalledPackageInfo -> Args
extraLibraries InstalledPackageInfo
installedPkgInfoRaw)
installedPkgInfo :: InstalledPackageInfo
installedPkgInfo = InstalledPackageInfo
installedPkgInfoRaw {
extraGHCiLibraries :: Args
extraGHCiLibraries = Args
libs }
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Bool
regPrintId RegisterFlags
regFlags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
putStrLn (UnitId -> [Char]
forall a. Pretty a => a -> [Char]
display (InstalledPackageInfo -> UnitId
IPI.installedUnitId InstalledPackageInfo
installedPkgInfo))
case () of
()
_ | Bool
modeGenerateRegFile -> InstalledPackageInfo -> IO ()
writeRegistrationFile InstalledPackageInfo
installedPkgInfo
| Bool
modeGenerateRegScript -> [Char] -> IO ()
forall a. [Char] -> IO a
die [Char]
"Generate Reg Script not supported"
| Bool
otherwise -> do
Verbosity -> [Char] -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity [Char]
"Registering" (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg)
Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
#if MIN_VERSION_Cabal(2,0,0)
PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
defaultRegisterOptions
#else
False packageDbs installedPkgInfo
#endif
where
modeGenerateRegFile :: Bool
modeGenerateRegFile = Maybe (Maybe [Char]) -> Bool
forall a. Maybe a -> Bool
isJust (Flag (Maybe [Char]) -> Maybe (Maybe [Char])
forall a. Flag a -> Maybe a
flagToMaybe (RegisterFlags -> Flag (Maybe [Char])
regGenPkgConf RegisterFlags
regFlags))
regFile :: [Char]
regFile = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe (PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
display (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) [Char] -> [Char] -> [Char]
<.> [Char]
"conf")
(Flag (Maybe [Char]) -> Maybe [Char]
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag (Maybe [Char])
regGenPkgConf RegisterFlags
regFlags))
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))
distPref :: [Char]
distPref = Flag [Char] -> [Char]
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag [Char]
regDistPref RegisterFlags
regFlags)
verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)
writeRegistrationFile :: InstalledPackageInfo -> IO ()
writeRegistrationFile InstalledPackageInfo
installedPkgInfo = do
Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity ([Char]
"Creating package registration file: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
regFile)
[Char] -> [Char] -> IO ()
writeUTF8File [Char]
regFile (InstalledPackageInfo -> [Char]
showInstalledPackageInfo InstalledPackageInfo
installedPkgInfo)
register PackageDescription
_ LocalBuildInfo
_ RegisterFlags
regFlags = Verbosity -> [Char] -> IO ()
notice Verbosity
verbosity [Char]
"No package to register"
where
verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (RegisterFlags -> Flag Verbosity
regVerbosity RegisterFlags
regFlags)
#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
#if MIN_VERSION_Cabal(2,0,0)
ourC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ourC2hs :: BuildInfo
-> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ourC2hs BuildInfo
bi LocalBuildInfo
lbi ComponentLocalBuildInfo
_ = PreProcessor :: Bool
-> (([Char], [Char]) -> ([Char], [Char]) -> Verbosity -> IO ())
-> PreProcessor
PreProcessor {
#else
ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ourC2hs bi lbi = PreProcessor {
#endif
platformIndependent :: Bool
platformIndependent = Bool
False,
runPreProcessor :: ([Char], [Char]) -> ([Char], [Char]) -> Verbosity -> IO ()
runPreProcessor = BuildInfo
-> LocalBuildInfo
-> ([Char], [Char])
-> ([Char], [Char])
-> Verbosity
-> IO ()
runC2HS BuildInfo
bi LocalBuildInfo
lbi
}
runC2HS :: BuildInfo -> LocalBuildInfo ->
(FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
runC2HS :: BuildInfo
-> LocalBuildInfo
-> ([Char], [Char])
-> ([Char], [Char])
-> Verbosity
-> IO ()
runC2HS BuildInfo
bi LocalBuildInfo
lbi ([Char]
inDir, [Char]
inFile) ([Char]
outDir, [Char]
outFile) Verbosity
verbosity = do
[Char]
header <- case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"x-c2hs-header" (BuildInfo -> [([Char], [Char])]
customFieldsBI BuildInfo
bi) of
Just [Char]
h -> [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
h
Maybe [Char]
Nothing -> [Char] -> IO [Char]
forall a. [Char] -> IO a
die ([Char]
"Need x-c2hs-Header definition in the .cabal Library section "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"that sets the C header file to process .chs.pp files.")
let ([Char]
outFileDir, [Char]
newOutFile) = [Char] -> ([Char], [Char])
splitFileName [Char]
outFile
let newOutDir :: [Char]
newOutDir = [Char]
outDir [Char] -> [Char] -> [Char]
</> [Char]
outFileDir
let chiDirs :: Args
chiDirs = [ [Char]
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),
[Char]
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) ]
(ConfiguredProgram
gccProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
gccProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
IO ()
unsafeResetRootNameSupply
Args -> IO ()
c2hsMain (Args -> IO ()) -> Args -> IO ()
forall a b. (a -> b) -> a -> b
$
([Char] -> [Char]) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"--include=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char]
outDir[Char] -> Args -> Args
forall a. a -> [a] -> [a]
:Args
chiDirs)
Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [ [Char]
"--cpp=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> [Char]
programPath ConfiguredProgram
gccProg, [Char]
"--cppopts=-E" ]
Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [[Char]
"--cppopts=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
opt | [Char]
opt <- BuildInfo -> LocalBuildInfo -> Args
getCppOptions BuildInfo
bi LocalBuildInfo
lbi]
Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [[Char]
"--output-dir=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
newOutDir,
[Char]
"--output=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
newOutFile,
[Char]
"--precomp=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LocalBuildInfo -> [Char]
buildDir LocalBuildInfo
lbi [Char] -> [Char] -> [Char]
</> [Char]
precompFile,
[Char]
header, [Char]
inDir [Char] -> [Char] -> [Char]
</> [Char]
inFile]
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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
$
[[Char]
"-I" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dir | [Char]
dir <- BuildInfo -> Args
PD.includeDirs BuildInfo
bi]
Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [[Char]
opt | opt :: [Char]
opt@(Char
'-':Char
c:[Char]
_) <- BuildInfo -> Args
PD.cppOptions BuildInfo
bi Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ BuildInfo -> Args
PD.ccOptions BuildInfo
bi, Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"DIU"]
installCHI :: PackageDescription
-> LocalBuildInfo
-> Verbosity -> CopyDest
-> 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 = [Char]
libPref } = PackageDescription
-> LocalBuildInfo -> CopyDest -> InstallDirs [Char]
absoluteInstallDirs PackageDescription
pkg LocalBuildInfo
lbi CopyDest
copydest
[Maybe ([Char], [Char])]
mFiles <- (ModuleName -> IO (Maybe ([Char], [Char])))
-> [ModuleName] -> IO [Maybe ([Char], [Char])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Args -> Args -> [Char] -> IO (Maybe ([Char], [Char]))
findFileWithExtension' [[Char]
"chi"] [LocalBuildInfo -> [Char]
buildDir LocalBuildInfo
lbi] ([Char] -> IO (Maybe ([Char], [Char])))
-> (ModuleName -> [Char])
-> ModuleName
-> IO (Maybe ([Char], [Char]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
toFilePath)
(Library -> [ModuleName]
PD.explicitLibModules Library
lib)
let files :: [([Char], [Char])]
files = [ ([Char], [Char])
f | Just ([Char], [Char])
f <- [Maybe ([Char], [Char])]
mFiles ]
Verbosity -> [Char] -> [([Char], [Char])] -> IO ()
installOrdinaryFiles Verbosity
verbosity [Char]
libPref [([Char], [Char])]
files
installCHI PackageDescription
_ LocalBuildInfo
_ Verbosity
_ CopyDest
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
genSynthezisedFiles Verbosity
verb PackageDescription
pd LocalBuildInfo
lbi = do
[PackageIdentifier]
cPkgs <- Verbosity
-> LocalBuildInfo -> PackageDescription -> IO [PackageIdentifier]
getPkgConfigPackages Verbosity
verb LocalBuildInfo
lbi PackageDescription
pd
let xList :: [([Char], [Char])]
xList = [([Char], [Char])]
-> (Library -> [([Char], [Char])])
-> Maybe Library
-> [([Char], [Char])]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (BuildInfo -> [([Char], [Char])]
customFieldsBI (BuildInfo -> [([Char], [Char])])
-> (Library -> BuildInfo) -> Library -> [([Char], [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> BuildInfo
libBuildInfo) (PackageDescription -> Maybe Library
library PackageDescription
pd)
[([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++PackageDescription -> [([Char], [Char])]
customFieldsPD PackageDescription
pd
typeOpts :: String -> [ProgArg]
typeOpts :: [Char] -> Args
typeOpts [Char]
tag = [Args] -> Args
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ([Char] -> [Char]) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
val -> Char
'-'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'-'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
tag) [Char]
field [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'='Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
val) ([Char] -> Args
words [Char]
content)
| ([Char]
field,[Char]
content) <- [([Char], [Char])]
xList,
[Char]
tag [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
field,
[Char]
field [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= ([Char]
tag[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"file")]
Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [ [Char]
"--tag=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tag
#if MIN_VERSION_Cabal(2,0,0)
| PackageIdentifier PackageName
name Version
version <- [PackageIdentifier]
cPkgs
, let Int
major:Int
minor:[Int]
_ = Version -> [Int]
versionNumbers Version
version
#else
| PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
#endif
, let name' :: [Char]
name' = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlpha (PackageName -> [Char]
forall a. Pretty a => a -> [Char]
display PackageName
name)
, [Char]
tag <- [Char]
name'
[Char] -> Args -> Args
forall a. a -> [a] -> [a]
:[ [Char]
name' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maj [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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
signalsOpts = [Args] -> Args
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ([Char] -> [Char]) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
val -> Char
'-'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'-'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
10 [Char]
field[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Char
'='Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
val) ([Char] -> Args
words [Char]
content)
| ([Char]
field,[Char]
content) <- [([Char], [Char])]
xList,
[Char]
"x-signals-" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
field,
[Char]
field [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"x-signals-file"]
genFile :: ([String] -> IO String) -> [ProgArg] -> FilePath -> IO ()
genFile :: (Args -> IO [Char]) -> Args -> [Char] -> IO ()
genFile Args -> IO [Char]
prog Args
args [Char]
outFile = do
[Char]
res <- Args -> IO [Char]
prog Args
args
Verbosity -> [Char] -> [Char] -> IO ()
rewriteFileEx Verbosity
verb [Char]
outFile [Char]
res
[([Char], [Char])] -> (([Char], [Char]) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Char]
tag,[Char]
_) -> [Char]
"x-types-" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
tag Bool -> Bool -> Bool
&& [Char]
"file" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
tag) [([Char], [Char])]
xList) ((([Char], [Char]) -> IO ()) -> IO ())
-> (([Char], [Char]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\([Char]
fileTag, [Char]
f) -> do
let tag :: [Char]
tag = [Char] -> [Char]
forall a. [a] -> [a]
reverse (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
4 ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
fileTag))
Verbosity -> [Char] -> IO ()
info Verbosity
verb ([Char]
"Ensuring that class hierarchy in "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
f[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" is up-to-date.")
(Args -> IO [Char]) -> Args -> [Char] -> IO ()
genFile Args -> IO [Char]
typeGen ([Char] -> Args
typeOpts [Char]
tag) [Char]
f
case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"x-signals-file" [([Char], [Char])]
xList of
Maybe [Char]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Char]
f -> do
Verbosity -> [Char] -> IO ()
info Verbosity
verb ([Char]
"Ensuring that callback hooks in "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
f[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" are up-to-date.")
(Args -> IO [Char]) -> Args -> [Char] -> IO ()
genFile Args -> IO [Char]
hookGen Args
signalsOpts [Char]
f
[Char] -> [Char] -> IO ()
writeFile [Char]
"gtk2hs_macros.h" ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [PackageIdentifier] -> [Char]
generateMacros [PackageIdentifier]
cPkgs
generateMacros :: [PackageId] -> String
generateMacros :: [PackageIdentifier] -> [Char]
generateMacros [PackageIdentifier]
cPkgs = Args -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Args -> [Char]) -> Args -> [Char]
forall a b. (a -> b) -> a -> b
$
[Char]
"/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" [Char] -> Args -> Args
forall a. a -> [a] -> [a]
:
[ Args -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[[Char]
"/* package ",PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
display PackageIdentifier
pkgid,[Char]
" */\n"
,[Char]
"#define VERSION_",[Char]
pkgname,[Char]
" ",[Char] -> [Char]
forall a. Show a => a -> [Char]
show (Version -> [Char]
forall a. Pretty a => a -> [Char]
display Version
version),[Char]
"\n"
,[Char]
"#define MIN_VERSION_",[Char]
pkgname,[Char]
"(major1,major2,minor) (\\\n"
,[Char]
" (major1) < ",[Char]
major1,[Char]
" || \\\n"
,[Char]
" (major1) == ",[Char]
major1,[Char]
" && (major2) < ",[Char]
major2,[Char]
" || \\\n"
,[Char]
" (major1) == ",[Char]
major1,[Char]
" && (major2) == ",[Char]
major2,[Char]
" && (minor) <= ",[Char]
minor,[Char]
")"
,[Char]
"\n\n"
]
| pkgid :: PackageIdentifier
pkgid@(PackageIdentifier PackageName
name Version
version) <- [PackageIdentifier]
cPkgs
, let ([Char]
major1:[Char]
major2:[Char]
minor:Args
_) = (Int -> [Char]) -> [Int] -> Args
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show (Version -> [Int]
versionNumbers Version
version [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
0)
pkgname :: [Char]
pkgname = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (PackageName -> [Char]
forall a. Pretty a => a -> [Char]
display PackageName
name)
]
where fixchar :: Char -> Char
fixchar Char
'-' = Char
'_'
fixchar Char
'.' = Char
'_'
fixchar Char
c = Char
c
getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
getPkgConfigPackages :: Verbosity
-> LocalBuildInfo -> PackageDescription -> IO [PackageIdentifier]
getPkgConfigPackages Verbosity
verbosity LocalBuildInfo
lbi PackageDescription
pkg =
[IO PackageIdentifier] -> IO [PackageIdentifier]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ do [Char]
version <- Args -> IO [Char]
pkgconfig [[Char]
"--modversion", PkgconfigName -> [Char]
forall a. Pretty a => a -> [Char]
display PkgconfigName
pkgname]
case [Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParse [Char]
version of
Maybe Version
Nothing -> [Char] -> IO PackageIdentifier
forall a. [Char] -> IO a
die [Char]
"parsing output of pkg-config --modversion failed"
#if MIN_VERSION_Cabal(2,0,0)
Just Version
v -> PackageIdentifier -> IO PackageIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Version -> PackageIdentifier
PackageIdentifier ([Char] -> PackageName
mkPackageName ([Char] -> PackageName) -> [Char] -> PackageName
forall a b. (a -> b) -> a -> b
$ PkgconfigName -> [Char]
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 [Char]
pkgconfig = Verbosity -> Program -> ProgramDb -> Args -> IO [Char]
getDbProgramOutput Verbosity
verbosity
Program
pkgConfigProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
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 -> Args
PD.hsSourceDirs = Args
srcDirs,
otherModules :: BuildInfo -> [ModuleName]
PD.otherModules = [ModuleName]
othMods
}}} = do
let findModule :: ModuleName -> NoCallStackIO (Maybe [Char])
findModule ModuleName
m = Args -> Args -> [Char] -> NoCallStackIO (Maybe [Char])
findFileWithExtension [[Char]
".chs.pp",[Char]
".chs"] Args
srcDirs
(Args -> [Char]
joinPath (ModuleName -> Args
components ModuleName
m))
[Maybe [Char]]
mExpFiles <- (ModuleName -> NoCallStackIO (Maybe [Char]))
-> [ModuleName] -> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> NoCallStackIO (Maybe [Char])
findModule [ModuleName]
expMods
[Maybe [Char]]
mOthFiles <- (ModuleName -> NoCallStackIO (Maybe [Char]))
-> [ModuleName] -> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> NoCallStackIO (Maybe [Char])
findModule [ModuleName]
othMods
let modDeps :: [ModDep]
modDeps = (ModuleName -> Maybe [Char] -> ModDep)
-> [ModuleName] -> [Maybe [Char]] -> [ModDep]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> [ModuleName] -> ModuleName -> Maybe [Char] -> ModDep
ModDep Bool
True []) [ModuleName]
expMods [Maybe [Char]]
mExpFiles[ModDep] -> [ModDep] -> [ModDep]
forall a. [a] -> [a] -> [a]
++
(ModuleName -> Maybe [Char] -> ModDep)
-> [ModuleName] -> [Maybe [Char]] -> [ModDep]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> [ModuleName] -> ModuleName -> Maybe [Char] -> ModDep
ModDep Bool
False []) [ModuleName]
othMods [Maybe [Char]]
mOthFiles
[ModDep]
modDeps <- (ModDep -> IO ModDep) -> [ModDep] -> IO [ModDep]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModDep -> IO ModDep
extractDeps [ModDep]
modDeps
let ([ModDep]
othMods, [ModDep]
expMods) = (ModDep -> Bool) -> [ModDep] -> ([ModDep], [ModDep])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (ModDep -> Bool) -> ModDep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModDep -> Bool
mdExposed) ([ModDep] -> ([ModDep], [ModDep]))
-> [ModDep] -> ([ModDep], [ModDep])
forall a b. (a -> b) -> a -> b
$ [ModDep] -> [ModDep]
forall a. [a] -> [a]
reverse ([ModDep] -> [ModDep]) -> [ModDep] -> [ModDep]
forall a b. (a -> b) -> a -> b
$ [ModDep] -> [ModDep]
sortTopological [ModDep]
modDeps
PackageDescription -> IO PackageDescription
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDescription
pd { library :: Maybe Library
PD.library = Library -> Maybe Library
forall a. a -> Maybe a
Just Library
lib {
exposedModules :: [ModuleName]
PD.exposedModules = (ModDep -> ModuleName) -> [ModDep] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModDep -> ModuleName
mdOriginal ([ModDep] -> [ModDep]
forall a. [a] -> [a]
reverse [ModDep]
expMods),
libBuildInfo :: BuildInfo
PD.libBuildInfo = BuildInfo
bi { otherModules :: [ModuleName]
PD.otherModules = (ModDep -> ModuleName) -> [ModDep] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModDep -> ModuleName
mdOriginal ([ModDep] -> [ModDep]
forall a. [a] -> [a]
reverse [ModDep]
othMods) }
}}
data ModDep = ModDep {
ModDep -> Bool
mdExposed :: Bool,
ModDep -> [ModuleName]
mdRequires :: [ModuleName],
ModDep -> ModuleName
mdOriginal :: ModuleName,
ModDep -> Maybe [Char]
mdLocation :: Maybe FilePath
}
instance Show ModDep where
show :: ModDep -> [Char]
show ModDep
x = Maybe [Char] -> [Char]
forall a. Show a => a -> [Char]
show (ModDep -> Maybe [Char]
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
extractDeps :: ModDep -> IO ModDep
md :: ModDep
md@ModDep { mdLocation :: ModDep -> Maybe [Char]
mdLocation = Maybe [Char]
Nothing } = ModDep -> IO ModDep
forall (m :: * -> *) a. Monad m => a -> m a
return ModDep
md
extractDeps md :: ModDep
md@ModDep { mdLocation :: ModDep -> Maybe [Char]
mdLocation = Just [Char]
f } = [Char] -> ([Char] -> IO ModDep) -> IO ModDep
forall a. [Char] -> ([Char] -> IO a) -> IO a
withUTF8FileContents [Char]
f (([Char] -> IO ModDep) -> IO ModDep)
-> ([Char] -> IO ModDep) -> IO ModDep
forall a b. (a -> b) -> a -> b
$ \[Char]
con -> do
let findImports :: [a] -> Args -> IO [a]
findImports [a]
acc ((Char
'{':Char
'#':[Char]
xs):Args
xxs) = case ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) [Char]
xs) of
(Char
'i':Char
'm':Char
'p':Char
'o':Char
'r':Char
't':Char
' ':[Char]
ys) ->
case [Char] -> Maybe a
forall a. Parsec a => [Char] -> Maybe a
simpleParse ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char
'#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) [Char]
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 -> [Char] -> IO [a]
forall a. [Char] -> IO a
die ([Char]
"cannot parse chs import in "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
f[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"offending line is {#"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
xs)
[Char]
_ -> [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
findImports [a]
acc ([Char]
_:Args
xxs) = [a] -> Args -> IO [a]
findImports [a]
acc Args
xxs
findImports [a]
acc [] = [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
[ModuleName]
mods <- [ModuleName] -> Args -> IO [ModuleName]
forall a. Parsec a => [a] -> Args -> IO [a]
findImports [] ([Char] -> Args
lines [Char]
con)
ModDep -> IO ModDep
forall (m :: * -> *) a. Monad m => a -> m a
return ModDep
md { mdRequires :: [ModuleName]
mdRequires = [ModuleName]
mods }
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 (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 (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)
checkGtk2hsBuildtools :: [Program] -> IO ()
checkGtk2hsBuildtools :: [Program] -> IO ()
checkGtk2hsBuildtools [Program]
programs = do
[([Char], Maybe ([Char], Args))]
programInfos <- (Program -> IO ([Char], Maybe ([Char], Args)))
-> [Program] -> IO [([Char], Maybe ([Char], Args))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Program
prog -> do
Maybe ([Char], Args)
location <- (Program
-> Verbosity -> ProgramSearchPath -> IO (Maybe ([Char], Args)))
-> Program -> Verbosity -> IO (Maybe ([Char], Args))
forall t t t. (t -> t -> ProgramSearchPath -> t) -> t -> t -> t
onDefaultSearchPath Program
-> Verbosity -> ProgramSearchPath -> IO (Maybe ([Char], Args))
Program
-> Verbosity -> ProgramSearchPath -> IO (Maybe ([Char], Args))
programFindLocation Program
prog Verbosity
normal
([Char], Maybe ([Char], Args)) -> IO ([Char], Maybe ([Char], Args))
forall (m :: * -> *) a. Monad m => a -> m a
return (Program -> [Char]
programName Program
prog, Maybe ([Char], Args)
location)
) [Program]
programs
let printError :: [Char] -> IO b
printError [Char]
name = do
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot find " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"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
[([Char], Maybe ([Char], Args))]
-> (([Char], Maybe ([Char], Args)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([Char], Maybe ([Char], Args))]
programInfos ((([Char], Maybe ([Char], Args)) -> IO ()) -> IO ())
-> (([Char], Maybe ([Char], Args)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ ([Char]
name, Maybe ([Char], Args)
location) ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ([Char], Args) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ([Char], Args)
location) ([Char] -> IO ()
forall a. [Char] -> IO a
printError [Char]
name)
typeGenProgram :: Program
typeGenProgram :: Program
typeGenProgram = [Char] -> Program
simpleProgram [Char]
"gtk2hsTypeGen"
signalGenProgram :: Program
signalGenProgram :: Program
signalGenProgram = [Char] -> Program
simpleProgram [Char]
"gtk2hsHookGenerator"
c2hsLocal :: Program
c2hsLocal :: Program
c2hsLocal = ([Char] -> Program
simpleProgram [Char]
"gtk2hsC2hs") {
programFindVersion :: Verbosity -> [Char] -> IO (Maybe Version)
programFindVersion = \Verbosity
_ [Char]
_ -> Maybe Version -> IO (Maybe Version)
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
}