module Gtk2HsSetup (
gtk2hsUserHooks,
getPkgConfigPackages,
checkGtk2hsBuildtools,
typeGenProgram,
signalGenProgram,
c2hsLocal
) where
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(..),
libModules, hasLibs)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms),
InstallDirs(..),
componentPackageDeps,
absoluteInstallDirs,
relocatable,
compiler)
import Distribution.Simple.Compiler ( Compiler(..) )
import Distribution.Simple.Program (
Program(..), ConfiguredProgram(..),
rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath,
c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram,
simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)
import Distribution.ModuleName ( ModuleName, components, toFilePath )
import Distribution.Simple.Utils
import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
defaultCopyFlags, ConfigFlags(configVerbosity),
fromFlag, toFlag, RegisterFlags(..), flagToMaybe,
fromFlagOrDefault, defaultRegisterFlags)
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.Install ( install )
import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage )
import Distribution.Text ( simpleParse, display )
import System.FilePath
import System.Exit (exitFailure)
import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist )
import Distribution.Version (Version(..))
import Distribution.Verbosity
import Control.Monad (when, unless, filterM, liftM, forM, forM_)
import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList, catMaybes )
import Data.List (isPrefixOf, isSuffixOf, nub, minimumBy, stripPrefix, tails )
import Data.Ord as Ord (comparing)
import Data.Char (isAlpha, isNumber)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Distribution.Simple.LocalBuildInfo as LBI
import qualified Distribution.InstalledPackageInfo as IPI
(installedUnitId)
import Distribution.Simple.Compiler (compilerVersion)
import Control.Applicative ((<$>))
import Distribution.Simple.Program.Find ( defaultProgramSearchPath )
import Gtk2HsC2Hs (c2hsMain)
import HookGenerator (hookGen)
import TypeGen (typeGen)
import UNames (unsafeResetRootNameSupply)
onDefaultSearchPath f a b = f a b defaultProgramSearchPath
libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of
[clbi] -> Just clbi
_ -> Nothing
precompFile = "precompchs.bin"
gtk2hsUserHooks = simpleUserHooks {
hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],
hookedPreProcessors = [("chs", ourC2hs)],
confHook = \pd cf ->
(fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)),
postConf = \args cf pd lbi -> do
genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi
postConf simpleUserHooks args cf pd lbi,
buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->
buildHook simpleUserHooks pd lbi uh bf,
copyHook = \pd lbi uh flags -> copyHook simpleUserHooks pd lbi uh flags >>
installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),
instHook = \pd lbi uh flags ->
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
installHook pd lbi uh flags >>
installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest,
regHook = registerHook
#else
instHook simpleUserHooks pd lbi uh flags >>
installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest
#endif
}
getDlls :: [FilePath] -> IO [FilePath]
getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$>
mapM getDirectoryContents dirs
fixLibs :: [FilePath] -> [String] -> [String]
fixLibs dlls = concatMap $ \ lib ->
case filter (isLib lib) dlls of
dlls@(_:_) -> [dropExtension (pickDll dlls)]
_ -> if lib == "z" then [] else [lib]
where
pickDll = minimumBy (Ord.comparing length)
isLib lib dll =
case stripPrefix ("lib"++lib) dll of
Just ('.':_) -> True
Just ('-':n:_) | isNumber n -> True
_ -> False
installHook :: PackageDescription -> LocalBuildInfo
-> UserHooks -> InstallFlags -> IO ()
installHook pkg_descr localbuildinfo _ flags = do
let copyFlags = defaultCopyFlags {
copyDistPref = installDistPref flags,
copyDest = toFlag NoCopyDest,
copyVerbosity = installVerbosity flags
}
install pkg_descr localbuildinfo copyFlags
let registerFlags = defaultRegisterFlags {
regDistPref = installDistPref flags,
regInPlace = installInPlace flags,
regPackageDB = installPackageDB flags,
regVerbosity = installVerbosity flags
}
when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags
registerHook :: PackageDescription -> LocalBuildInfo
-> UserHooks -> RegisterFlags -> IO ()
registerHook pkg_descr localbuildinfo _ flags =
if hasLibs pkg_descr
then register pkg_descr localbuildinfo flags
else setupMessage verbosity
"Package contains no library to register:" (packageId pkg_descr)
where verbosity = fromFlag (regVerbosity flags)
register :: PackageDescription -> LocalBuildInfo
-> RegisterFlags
-> IO ()
register pkg@PackageDescription { library = Just lib } lbi regFlags
= do
let clbi = LBI.getComponentLocalBuildInfo lbi LBI.CLibName
absPackageDBs <- absolutePackageDBPaths packageDbs
installedPkgInfoRaw <- generateRegistrationInfo
verbosity pkg lib lbi clbi inplace reloc distPref
(registrationPackageDB absPackageDBs)
dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls
let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw)
installedPkgInfo = installedPkgInfoRaw {
extraGHCiLibraries = libs }
when (fromFlag (regPrintId regFlags)) $ do
putStrLn (display (IPI.installedUnitId installedPkgInfo))
case () of
_ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo
| modeGenerateRegScript -> die "Generate Reg Script not supported"
| otherwise -> do
setupMessage verbosity "Registering" (packageId pkg)
registerPackage verbosity (compiler lbi) (withPrograms lbi) False
packageDbs installedPkgInfo
where
modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
regFile = fromMaybe (display (packageId pkg) <.> "conf")
(fromFlag (regGenPkgConf regFlags))
modeGenerateRegScript = fromFlag (regGenScript regFlags)
inplace = fromFlag (regInPlace regFlags)
reloc = relocatable lbi
packageDbs = nub $ withPackageDB lbi
++ maybeToList (flagToMaybe (regPackageDB regFlags))
distPref = fromFlag (regDistPref regFlags)
verbosity = fromFlag (regVerbosity regFlags)
writeRegistrationFile installedPkgInfo = do
notice verbosity ("Creating package registration file: " ++ regFile)
writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)
register _ _ regFlags = notice verbosity "No package to register"
where
verbosity = fromFlag (regVerbosity regFlags)
adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
adjustLocalBuildInfo lbi =
let extra = (Just libBi, [])
libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi
, buildDir lbi ] }
in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }
ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
ourC2hs bi lbi = PreProcessor {
platformIndependent = False,
runPreProcessor = runC2HS bi lbi
}
runC2HS :: BuildInfo -> LocalBuildInfo ->
(FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do
header <- case lookup "x-c2hs-header" (customFieldsBI bi) of
Just h -> return h
Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++
"that sets the C header file to process .chs.pp files.")
let (outFileDir, newOutFile) = splitFileName outFile
let newOutDir = outDir </> outFileDir
let chiDirs = [ dir |
ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),
dir <- maybe [] importDirs (lookupUnitId (installedPkgs lbi) 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,
"--precomp=" ++ buildDir lbi </> precompFile,
header, inDir </> inFile]
return ()
getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
getCppOptions bi lbi
= nub $
["-I" ++ dir | dir <- PD.includeDirs bi]
++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"]
++ ["-D__GLASGOW_HASKELL__="++show (ghcDefine . ghcVersion . compilerId $ LBI.compiler lbi)]
where
ghcDefine (v1:v2:_) = v1 * 100 + v2
ghcDefine _ = __GLASGOW_HASKELL__
ghcVersion :: CompilerId -> [Int]
ghcVersion (CompilerId GHCJS v) = drop 3 $ versionBranch v
ghcVersion (CompilerId GHC v) = versionBranch v
ghcVersion _ = error "Not GHC"
installCHI :: PackageDescription
-> LocalBuildInfo
-> Verbosity -> CopyDest
-> IO ()
installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do
let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest
mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath)
(PD.libModules lib)
let files = [ f | Just f <- mFiles ]
installOrdinaryFiles verbosity libPref files
installCHI _ _ _ _ = return ()
genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
genSynthezisedFiles verb pd lbi = do
cPkgs <- getPkgConfigPackages verb lbi pd
let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)
++customFieldsPD pd
typeOpts :: String -> [ProgArg]
typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field ++ '=':val) (words content)
| (field,content) <- xList,
tag `isPrefixOf` field,
field /= (tag++"file")]
++ [ "--tag=" ++ tag
| PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
, let name' = filter isAlpha (display name)
, tag <- name'
:[ name' ++ "-" ++ show maj ++ "." ++ show d2
| (maj, d2) <- [(maj, d2) | maj <- [0..(major1)], d2 <- [0,2..20]]
++ [(major, d2) | d2 <- [0,2..minor]] ]
]
signalsOpts :: [ProgArg]
signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content)
| (field,content) <- xList,
"x-signals-" `isPrefixOf` field,
field /= "x-signals-file"]
genFile :: ([String] -> IO String) -> [ProgArg] -> FilePath -> IO ()
genFile prog args outFile = do
res <- prog args
rewriteFile outFile res
forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $
\(fileTag, f) -> do
let tag = reverse (drop 4 (reverse fileTag))
info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")
genFile typeGen (typeOpts tag) f
case lookup "x-signals-file" xList of
Nothing -> return ()
Just f -> do
info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")
genFile hookGen signalsOpts f
writeFile "gtk2hs_macros.h" $ generateMacros cPkgs
generateMacros :: [PackageId] -> String
generateMacros cPkgs = concat $
"/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" :
[ concat
["/* package ",display pkgid," */\n"
,"#define VERSION_",pkgname," ",show (display version),"\n"
,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"
," (major1) < ",major1," || \\\n"
," (major1) == ",major1," && (major2) < ",major2," || \\\n"
," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
,"\n\n"
]
| pkgid@(PackageIdentifier name version) <- cPkgs
, let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
pkgname = map fixchar (display name)
]
where fixchar '-' = '_'
fixchar '.' = '_'
fixchar c = c
getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
getPkgConfigPackages verbosity lbi pkg =
sequence
[ do version <- pkgconfig ["--modversion", display pkgname]
case simpleParse version of
Nothing -> die "parsing output of pkg-config --modversion failed"
Just v -> return (PackageIdentifier pkgname v)
| Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]
where
pkgconfig = rawSystemProgramStdoutConf verbosity
pkgConfigProgram (withPrograms lbi)
fixDeps :: PackageDescription -> IO PackageDescription
fixDeps pd@PD.PackageDescription {
PD.library = Just lib@PD.Library {
PD.exposedModules = expMods,
PD.libBuildInfo = bi@PD.BuildInfo {
PD.hsSourceDirs = srcDirs,
PD.otherModules = othMods
}}} = do
let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs
(joinPath (components m))
mExpFiles <- mapM findModule expMods
mOthFiles <- mapM findModule othMods
let modDeps = zipWith (ModDep True []) expMods mExpFiles++
zipWith (ModDep False []) othMods mOthFiles
modDeps <- mapM extractDeps modDeps
let (othMods, expMods) = span (not . mdExposed) $ reverse $ sortTopological modDeps
return pd { PD.library = Just lib {
PD.exposedModules = map mdOriginal (reverse expMods),
PD.libBuildInfo = bi { PD.otherModules = map mdOriginal (reverse othMods) }
}}
data ModDep = ModDep {
mdExposed :: Bool,
mdRequires :: [ModuleName],
mdOriginal :: ModuleName,
mdLocation :: Maybe FilePath
}
instance Show ModDep where
show x = show (mdLocation x)
instance Eq ModDep where
ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2
instance Ord ModDep where
compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2
extractDeps :: ModDep -> IO ModDep
extractDeps md@ModDep { mdLocation = Nothing } = return md
extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do
let findImports acc (('{':'#':xs):xxs) = case (dropWhile (' ' ==) xs) of
('i':'m':'p':'o':'r':'t':' ':ys) ->
case simpleParse (takeWhile ('#' /=) ys) of
Just m -> findImports (m:acc) xxs
Nothing -> die ("cannot parse chs import in "++f++":\n"++
"offending line is {#"++xs)
_ -> return acc
findImports acc (_:xxs) = findImports acc xxs
findImports acc [] = return acc
mods <- findImports [] (lines con)
return md { mdRequires = mods }
sortTopological :: [ModDep] -> [ModDep]
sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)
where
set = M.fromList (map (\m -> (mdOriginal m, m)) ms)
visit (out,visited) m
| m `S.member` visited = (out,visited)
| otherwise = case m `M.lookup` set of
Nothing -> (out, m `S.insert` visited)
Just md -> (md:out', visited')
where
(out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)
checkGtk2hsBuildtools :: [Program] -> IO ()
checkGtk2hsBuildtools programs = do
programInfos <- mapM (\ prog -> do
location <- onDefaultSearchPath programFindLocation prog normal
return (programName prog, location)
) programs
let printError name = do
putStrLn $ "Cannot find " ++ name ++ "\n"
++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)."
exitFailure
forM_ programInfos $ \ (name, location) ->
when (isNothing location) (printError name)
typeGenProgram :: Program
typeGenProgram = simpleProgram "gtk2hsTypeGen"
signalGenProgram :: Program
signalGenProgram = simpleProgram "gtk2hsHookGenerator"
c2hsLocal :: Program
c2hsLocal = (simpleProgram "gtk2hsC2hs") {
programFindVersion = \_ _ -> return . Just $ Version [0,13,13] []
}