diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ViewPatterns #-} #ifndef CABAL_VERSION_CHECK #error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file @@ -29,7 +29,7 @@ emptyBuildInfo, allBuildInfo, Library(..), libModules, hasLibs) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms), InstallDirs(..), componentPackageDeps, absoluteInstallDirs) @@ -56,13 +56,26 @@ import Distribution.Verbosity import Control.Monad (when, unless, filterM, liftM, forM, forM_) import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList ) -import Data.List (isPrefixOf, isSuffixOf, nub) -import Data.Char (isAlpha) +import Data.List (isPrefixOf, isSuffixOf, stripPrefix, nub) +import Data.Char (isAlpha, isNumber) import qualified Data.Map as M import qualified Data.Set as S +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Compiler (compilerVersion) import Control.Applicative ((<$>)) +#if CABAL_VERSION_CHECK(1,17,0) +import Distribution.Simple.Program.Find ( defaultProgramSearchPath ) +onDefaultSearchPath f a b = f a b defaultProgramSearchPath +libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of + [clbi] -> Just clbi + _ -> Nothing +#else +onDefaultSearchPath = id +libraryConfig = LBI.libraryConfig +#endif + -- the name of the c2hs pre-compiled header file precompFile = "precompchs.bin" @@ -99,10 +112,16 @@ fixLibs :: [FilePath] -> [String] -> [String] fixLibs dlls = concatMap $ \ lib -> - case filter (("lib" ++ lib) `isPrefixOf`) dlls of + case filter (isLib lib) dlls of dll:_ -> [dropExtension dll] _ -> if lib == "z" then [] else [lib] - + where + isLib lib dll = + case stripPrefix ("lib"++lib) dll of + Just ('.':_) -> True + Just ('-':n:_) | isNumber n -> True + _ -> False + -- The following code is a big copy-and-paste job from the sources of -- Cabal 1.8 just to be able to fix a field in the package file. Yuck. @@ -135,8 +154,8 @@ register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () -register pkg@PackageDescription { library = Just lib } - lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags +register pkg@(library -> Just lib ) + lbi@(libraryConfig -> Just clbi) regFlags = do installedPkgInfoRaw <- generateRegistrationInfo @@ -228,6 +247,10 @@ = nub $ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ [opt | opt@('-':c:_) <- PD.cppOptions bi ++ PD.ccOptions bi, c `elem` "DIU"] + ++ ["-D__GLASGOW_HASKELL__="++show (ghcDefine . versionBranch . compilerVersion $ LBI.compiler lbi)] + where + ghcDefine (v1:v2:_) = v1 * 100 + v2 + ghcDefine _ = __GLASGOW_HASKELL__ installCHI :: PackageDescription -- ^information from the .cabal file -> LocalBuildInfo -- ^information from the configure step @@ -417,7 +440,7 @@ checkGtk2hsBuildtools :: [Program] -> IO () checkGtk2hsBuildtools programs = do programInfos <- mapM (\ prog -> do - location <- programFindLocation prog normal + location <- onDefaultSearchPath programFindLocation prog normal return (programName prog, location) ) programs let printError name = do diff --git a/SetupWrapper.hs b/SetupWrapper.hs --- a/SetupWrapper.hs +++ b/SetupWrapper.hs @@ -29,6 +29,24 @@ import Control.Monad +-- moreRecentFile is implemented in Distribution.Simple.Utils, but only in +-- Cabal >= 1.18. For backwards-compatibility, we implement a copy with a new +-- name here. Some desirable alternate strategies don't work: +-- * We can't use CPP to check which version of Cabal we're up against because +-- this is the file that's generating the macros for doing that. +-- * We can't use the name moreRecentFiles and use +-- import D.S.U hiding (moreRecentFiles) +-- because on old GHC's (and according to the Report) hiding a name that +-- doesn't exist is an error. +moreRecentFile' :: FilePath -> FilePath -> IO Bool +moreRecentFile' a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + setupWrapper :: FilePath -> IO () setupWrapper setupHsFile = do args <- getArgs @@ -91,8 +109,8 @@ -- Currently this is GHC only. It should really be generalised. -- compileSetupExecutable = do - setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile - cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + setupHsNewer <- setupHsFile `moreRecentFile'` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile'` setupProgFile let outOfDate = setupHsNewer || cabalVersionNewer when outOfDate $ do debug verbosity "Setup script is out of date, compiling..." @@ -144,12 +162,3 @@ Nothing Nothing Nothing exitCode <- waitForProcess process unless (exitCode == ExitSuccess) $ exitWith exitCode - -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) diff --git a/System/Glib/UTFString.hs b/System/Glib/UTFString.hs --- a/System/Glib/UTFString.hs +++ b/System/Glib/UTFString.hs @@ -46,7 +46,8 @@ ofsFromUTF ) where -import Control.Monad (liftM) +import Codec.Binary.UTF8.String +import Control.Monad (liftM) import Data.Char (ord, chr) import Data.Maybe (maybe) @@ -55,38 +56,38 @@ -- | Like 'withCString' but using the UTF-8 encoding. -- withUTFString :: String -> (CString -> IO a) -> IO a -withUTFString hsStr = withCAString (toUTF hsStr) +withUTFString = withCAString . encodeString -- | Like 'withCStringLen' but using the UTF-8 encoding. -- withUTFStringLen :: String -> (CStringLen -> IO a) -> IO a -withUTFStringLen hsStr = withCAStringLen (toUTF hsStr) +withUTFStringLen = withCAStringLen . encodeString -- | Like 'newCString' but using the UTF-8 encoding. -- newUTFString :: String -> IO CString -newUTFString = newCAString . toUTF +newUTFString = newCAString . encodeString -- | Like Define newUTFStringLen to emit UTF-8. -- newUTFStringLen :: String -> IO CStringLen -newUTFStringLen = newCAStringLen . toUTF +newUTFStringLen = newCAStringLen . encodeString -- | Like 'peekCString' but using the UTF-8 encoding. -- peekUTFString :: CString -> IO String -peekUTFString strPtr = liftM fromUTF $ peekCAString strPtr +peekUTFString = liftM decodeString . peekCAString -- | Like 'maybePeek' 'peekCString' but using the UTF-8 encoding to retrieve -- UTF-8 from a 'CString' which may be the 'nullPtr'. -- maybePeekUTFString :: CString -> IO (Maybe String) -maybePeekUTFString strPtr = liftM (maybe Nothing (Just . fromUTF)) $ maybePeek peekCAString strPtr +maybePeekUTFString = liftM (maybe Nothing (Just . decodeString)) . maybePeek peekCAString -- | Like 'peekCStringLen' but using the UTF-8 encoding. -- peekUTFStringLen :: CStringLen -> IO String -peekUTFStringLen strPtr = liftM fromUTF $ peekCAStringLen strPtr +peekUTFStringLen = liftM decodeString . peekCAStringLen -- | Like like 'peekUTFString' but then frees the string using g_free -- @@ -163,44 +164,6 @@ foreign import ccall unsafe "g_strfreev" g_strfreev :: Ptr a -> IO () --- | Encode a Haskell Unicode String as UTF-8 --- --- You should think of this as it it had type @String -> [Word8]@ --- -toUTF :: String -> String -toUTF [] = [] -toUTF (x:xs) | ord x<=0x007F = x:toUTF xs - | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)): - chr (0x80 .|. (ord x .&. 0x3F)): - toUTF xs - | otherwise = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)): - chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)): - chr (0x80 .|. (ord x .&. 0x3F)): - toUTF xs - --- | Decode a UTF-8 string into a Haskell Unicode String. --- --- You should think of this as it it had type @[Word8] -> String@ --- -fromUTF :: String -> String -fromUTF [] = [] -fromUTF (all@(x:xs)) | ord x<=0x7F = x:fromUTF xs - | ord x<=0xBF = err - | ord x<=0xDF = twoBytes all - | ord x<=0xEF = threeBytes all - | otherwise = err - where - twoBytes (x1:x2:xs) = chr (((ord x1 .&. 0x1F) `shift` 6) .|. - (ord x2 .&. 0x3F)):fromUTF xs - twoBytes _ = error "fromUTF: illegal two byte sequence" - - threeBytes (x1:x2:x3:xs) = chr (((ord x1 .&. 0x0F) `shift` 12) .|. - ((ord x2 .&. 0x3F) `shift` 6) .|. - (ord x3 .&. 0x3F)):fromUTF xs - threeBytes _ = error "fromUTF: illegal three byte sequence" - - err = error "fromUTF: illegal UTF-8 character" - -- | Offset correction for String to UTF8 mapping. -- newtype UTFCorrection = UTFCorrection [Int] deriving Show @@ -213,7 +176,8 @@ gUO n [] = [] gUO n (x:xs) | ord x<=0x007F = gUO (n+1) xs | ord x<=0x07FF = n:gUO (n+1) xs - | otherwise = n:n:gUO (n+1) xs + | ord x<=0xFFFF = n:n:gUO (n+1) xs + | otherwise = n:n:n:gUO (n+1) xs ofsToUTF :: Int -> UTFCorrection -> Int ofsToUTF n (UTFCorrection oc) = oTU oc diff --git a/glib.cabal b/glib.cabal --- a/glib.cabal +++ b/glib.cabal @@ -1,5 +1,5 @@ Name: glib -Version: 0.12.4 +Version: 0.12.5.0 License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team @@ -23,8 +23,8 @@ System/Glib/hsgclosure.h Source-Repository head - type: darcs - location: http://code.haskell.org/gtk2hs/ + type: git + location: https://github.com/gtk2hs/gtk2hs subdir: glib Flag closure_signals @@ -33,8 +33,9 @@ Library build-depends: base >= 4 && < 5, + utf8-string >= 0.2 && < 0.4, containers - build-tools: gtk2hsC2hs >= 0.13.5 + build-tools: gtk2hsC2hs >= 0.13.8 if flag(closure_signals) cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL c-sources: System/Glib/hsgclosure.c