Hello community,
here is the log from the commit of package ghc-haskell-gi for openSUSE:Factory
checked in at 2017-06-22 10:37:36
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-haskell-gi (Old)
and /work/SRC/openSUSE:Factory/.ghc-haskell-gi.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-haskell-gi"
Thu Jun 22 10:37:36 2017 rev:3 rq:504070 version:0.20.2
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-haskell-gi/ghc-haskell-gi.changes
2017-05-03 15:56:08.477110124 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-haskell-gi.new/ghc-haskell-gi.changes
2017-06-22 10:37:37.261070900 +0200
@@ -1,0 +2,5 @@
+Thu Jun 8 11:08:16 UTC 2017 - psim...@suse.com
+
+- Update to version 0.20.2.
+
+-------------------------------------------------------------------
Old:
----
haskell-gi-0.20.1.tar.gz
New:
----
haskell-gi-0.20.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-haskell-gi.spec ++++++
--- /var/tmp/diff_new_pack.AW7ib5/_old 2017-06-22 10:37:37.900980688 +0200
+++ /var/tmp/diff_new_pack.AW7ib5/_new 2017-06-22 10:37:37.900980688 +0200
@@ -19,7 +19,7 @@
%global pkg_name haskell-gi
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.20.1
+Version: 0.20.2
Release: 0
Summary: Generate Haskell bindings for GObject Introspection capable
libraries
License: LGPL-2.1+
++++++ haskell-gi-0.20.1.tar.gz -> haskell-gi-0.20.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/ChangeLog.md
new/haskell-gi-0.20.2/ChangeLog.md
--- old/haskell-gi-0.20.1/ChangeLog.md 2017-03-27 22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/ChangeLog.md 2017-06-03 12:00:54.000000000 +0200
@@ -1,11 +1,15 @@
+### 0.20.2
+
++ Fixes for GHC 8.2.1.
+
### 0.20.1
- + gtk-doc parser and haddock generator: while no means perfect,
- now the autogenerated bindings come with some reasonable
- autogenerated documentation.
++ gtk-doc parser and haddock generator: while by no means perfect,
+now the autogenerated bindings come with some reasonable
+autogenerated documentation.
- + Many bugfixes. A particularly important one is for
- [issue 82](https://github.com/haskell-gi/haskell-gi/issues/82), which
- made compilation of
- [gi-glib](http://hackage.haskell.org/package/gi-glib) fail, for
- the latest version of gobject-introspection.
++ Many bugfixes. A particularly important one is for
+[issue 82](https://github.com/haskell-gi/haskell-gi/issues/82), which
+made compilation of
+[gi-glib](http://hackage.haskell.org/package/gi-glib) fail, for
+the latest version of gobject-introspection.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/cmdline/haskell-gi.hs
new/haskell-gi-0.20.2/cmdline/haskell-gi.hs
--- old/haskell-gi-0.20.1/cmdline/haskell-gi.hs 2017-03-27 22:44:51.000000000
+0200
+++ new/haskell-gi-0.20.2/cmdline/haskell-gi.hs 2017-06-03 12:00:54.000000000
+0200
@@ -5,6 +5,7 @@
#endif
import Control.Monad (forM_, when, (>=>))
import Control.Exception (handle)
+import Control.Applicative ((<|>))
import Data.Char (toLower)
import Data.Bool (bool)
@@ -71,6 +72,17 @@
let (a, '=':b) = break (=='=') s
in (a, b)
+solveNameVersion::Overrides -> Text -> (Text, Maybe Text)
+solveNameVersion ovs name = (nameWithoutVersion, version)
+ where
+ namePieces = T.splitOn "-" name
+ nameWithoutVersion = head namePieces
+ versionInName = if length namePieces == 2
+ then Just (last namePieces)
+ else Nothing
+ versionInOverride = M.lookup nameWithoutVersion (nsChooseVersion ovs)
+ version = versionInOverride <|> versionInName
+
optDescrs :: [OptDescr (Options -> Options)]
optDescrs = [
Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help })
@@ -118,8 +130,8 @@
-- | Load a dependency without further postprocessing.
loadRawAPIs :: Bool -> Overrides -> [FilePath] -> Text -> IO [(Name, API)]
loadRawAPIs verbose ovs extraPaths name = do
- let version = M.lookup name (nsChooseVersion ovs)
- gir <- loadRawGIRInfo verbose name version extraPaths
+ let (nameWithoutVersion, version) = solveNameVersion ovs name
+ gir <- loadRawGIRInfo verbose nameWithoutVersion version extraPaths
return (girAPIs gir)
-- | Set up the flags for the code generator.
@@ -165,18 +177,18 @@
-- for this module.
processMod :: Options -> Overrides -> [FilePath] -> Text -> IO ()
processMod options ovs extraPaths name = do
- let version = M.lookup name (nsChooseVersion ovs)
- cfg = Config {modName = name,
+ let (nameWithoutVersion, version) = solveNameVersion ovs name
+ cfg = Config {modName = nameWithoutVersion,
verbose = optVerbose options,
overrides = ovs,
cgFlags = genFlags options
}
- nm = ucFirst name
+ nm = ucFirst nameWithoutVersion
mp = T.unpack . ("GI." <>)
putStrLn $ "\t* Generating " ++ mp nm
- (gir, girDeps) <- loadGIRInfo (optVerbose options) name version extraPaths
+ (gir, girDeps) <- loadGIRInfo (optVerbose options) nameWithoutVersion
version extraPaths
(girFixups ovs)
let (apis, deps) = filterAPIsAndDeps ovs gir girDeps
allAPIs = M.union apis deps
@@ -193,7 +205,7 @@
++ cabal ++ ".new instead") >>
return (cabal ++ ".new"))
-- The module is not a dep of itself
- let usedDeps = S.delete name modDeps
+ let usedDeps = S.delete nameWithoutVersion modDeps
-- We only list as dependencies in the cabal file the
-- dependencies that we use, disregarding what the .gir file says.
actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps
@@ -216,8 +228,8 @@
dump :: Options -> Overrides -> Text -> IO ()
dump options ovs name = do
- let version = M.lookup name (nsChooseVersion ovs)
- (doc, _) <- loadGIRInfo (optVerbose options) name version (optSearchPaths
options) []
+ let (nameWithoutVersion, version) = solveNameVersion ovs name
+ (doc, _) <- loadGIRInfo (optVerbose options) nameWithoutVersion version
(optSearchPaths options) []
mapM_ (putStrLn . ppShow) (girAPIs doc)
process :: Options -> [Text] -> IO ()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/haskell-gi.cabal
new/haskell-gi-0.20.2/haskell-gi.cabal
--- old/haskell-gi-0.20.1/haskell-gi.cabal 2017-03-27 22:44:51.000000000
+0200
+++ new/haskell-gi-0.20.2/haskell-gi.cabal 2017-06-03 12:00:54.000000000
+0200
@@ -1,5 +1,5 @@
name: haskell-gi
-version: 0.20.1
+version: 0.20.2
synopsis: Generate Haskell bindings for GObject Introspection
capable libraries
description: Generate Haskell bindings for GObject Introspection
capable libraries. This includes most notably
Gtk+, but many other libraries in the GObject ecosystem
provide introspection data too.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/CabalHooks.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/CabalHooks.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/CabalHooks.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/CabalHooks.hs 2017-06-03
12:00:54.000000000 +0200
@@ -8,8 +8,13 @@
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.Simple (UserHooks(..), simpleUserHooks,
- defaultMainWithHooks, OptimisationLevel(..),
- Dependency(..), PackageName(..))
+ defaultMainWithHooks, OptimisationLevel(..))
+#if !MIN_VERSION_Cabal(2,0,0)
+import Distribution.Simple (Dependency(..), PackageName(..), unPackageName)
+#else
+import Distribution.Types.PkgconfigDependency (PkgconfigDependency(..))
+import Distribution.Types.PkgconfigName (unPkgconfigName)
+#endif
import Distribution.PackageDescription
import Data.GI.CodeGen.API (loadGIRInfo)
@@ -37,10 +42,21 @@
type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags
-> IO LocalBuildInfo
+#if !MIN_VERSION_Cabal(2,0,0)
+#define PkgconfigDependency Dependency
+
+unPkgconfigName :: PackageName -> String
+unPkgconfigName = unPackageName
+
+unFlagName :: FlagName -> String
+unFlagName (FlagName n) = n
+#endif
+
-- | Generate the @PkgInfo@ module, listing the build information for
-- the module. We include in particular the versions for the
-- `pkg-config` dependencies of the module.
-genPkgInfo :: [Dependency] -> [(FlagName, Bool)] -> FilePath -> Text -> IO ()
+genPkgInfo :: [PkgconfigDependency] -> [(FlagName, Bool)] -> FilePath -> Text
+ -> IO ()
genPkgInfo deps flags fName modName = do
versions <- mapM findVersion deps
utf8WriteFile fName $ T.unlines
@@ -54,14 +70,14 @@
, "flags :: [(String, Bool)]"
, "flags = " <> tshow flags'
]
- where findVersion :: Dependency -> IO (Text, Text)
- findVersion (Dependency (PackageName n) _) =
- tryPkgConfig (T.pack n) >>= \case
+ where findVersion :: PkgconfigDependency -> IO (Text, Text)
+ findVersion (PkgconfigDependency n _) =
+ tryPkgConfig (T.pack (unPkgconfigName n)) >>= \case
Just v -> return v
- Nothing -> error ("Could not determine version for required
pkg-config module \"" <> n <> "\".")
+ Nothing -> error ("Could not determine version for required
pkg-config module \"" <> (unPkgconfigName n) <> "\".")
flags' :: [(String, Bool)]
- flags' = map (\(FlagName fn, v) -> (fn, v)) flags
+ flags' = map (\(f, v) -> (unFlagName f, v)) flags
-- | Parse the set of flags given to configure into flags for the code
-- generator.
@@ -78,7 +94,7 @@
check s = fromMaybe True (M.lookup s flags)
flags :: M.Map String Bool
- flags = M.fromList (map (\(FlagName fn, v) -> (fn, v)) fs)
+ flags = M.fromList (map (\(f, v) -> (unFlagName f, v)) fs)
-- | A convenience helper for `confHook`, such that bindings for the
-- given module are generated in the @configure@ step of @cabal@.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Callable.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Callable.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Callable.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Callable.hs 2017-06-03
12:00:54.000000000 +0200
@@ -29,7 +29,6 @@
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.Tuple (swap)
-import Data.Typeable (TypeRep, typeOf)
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Text (Text)
@@ -55,9 +54,9 @@
hOutType :: Callable -> [Arg] -> ExcCodeGen TypeRep
hOutType callable outArgs = do
hReturnType <- case returnType callable of
- Nothing -> return $ typeOf ()
+ Nothing -> return $ con0 "()"
Just r -> if skipRetVal callable
- then return $ typeOf ()
+ then return $ con0 "()"
else haskellType r
hOutArgTypes <- forM outArgs $ \outarg ->
wrapMaybe outarg >>= bool
@@ -69,7 +68,7 @@
&& nullableReturnType
then maybeT hReturnType
else hReturnType
- return $ case (outArgs, tshow maybeHReturnType) of
+ return $ case (outArgs, typeShow maybeHReturnType) of
([], _) -> maybeHReturnType
(_, "()") -> "(,)" `con` hOutArgTypes
_ -> "(,)" `con` (maybeHReturnType : hOutArgTypes)
@@ -93,12 +92,12 @@
let ft' = if direction arg == DirectionIn || argCallerAllocates arg
then ft
else ptr ft
- let start = tshow ft' <> " -> "
+ let start = typeShow ft' <> " -> "
return $ padTo 40 start <> "-- " <> (argCName arg)
<> " : " <> tshow (argType arg)
- last = tshow <$> io <$> case returnType callable of
- Nothing -> return $ typeOf ()
- Just r -> foreignType r
+ last = typeShow <$> io <$> case returnType callable of
+ Nothing -> return $ con0 "()"
+ Just r -> foreignType r
-- | Make a wrapper for foreign `FunPtr`s of the given type. Return
-- the name of the resulting dynamic Haskell wrapper.
@@ -332,7 +331,7 @@
_ -> terror $ "prepareInCallback : Not an interface! " <> T.pack
(ppShow arg)
when (scope == ScopeTypeAsync) $ do
- ft <- tshow <$> foreignType (argType arg)
+ ft <- typeShow <$> foreignType (argType arg)
line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))"
wrapMaybe arg >>= bool
@@ -389,7 +388,7 @@
(do
name'' <- genConversion (prime name') $
literal $ M $ allocator <> " " <> tshow n <>
- " :: " <> tshow (io ft)
+ " :: " <> typeShow (io ft)
line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n
return name'')
-- The semantics of this case are somewhat undefined.
@@ -399,7 +398,7 @@
then return name'
else do
name'' <- genConversion (prime name') $
- literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)
+ literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft)
line $ "poke " <> name'' <> " " <> name'
return name''
@@ -416,13 +415,12 @@
then "callocBoxedBytes"
else "callocBytes"
genConversion name $ literal $ M $ allocator <> " " <> tshow n <>
- " :: " <> tshow (io ft)
+ " :: " <> typeShow (io ft)
Nothing ->
notImplementedError $ ("Don't know how to allocate \""
<> argCName arg <> "\" of type "
<> tshow (argType arg))
- else genConversion name $
- literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)
+ else genConversion name $ literal $ M $ "allocMem :: " <> typeShow (io $ ptr
ft)
-- Convert a non-zero terminated out array, stored in a variable
-- named "aname", into the corresponding Haskell object.
@@ -604,7 +602,7 @@
return $ Signature {
signatureCallable = callable,
signatureConstraints = constraints,
- signatureReturnType = tshow ("m" `con` [outType]),
+ signatureReturnType = typeShow ("m" `con` [outType]),
signatureArgTypes = case symbol of
KnownForeignSymbol _ -> zip (map Just hInArgs) types
DynamicForeignSymbol w -> zip (Nothing : map Just hInArgs)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/CodeGen.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/CodeGen.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/CodeGen.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/CodeGen.hs 2017-06-03
12:00:54.000000000 +0200
@@ -22,7 +22,8 @@
import Data.GI.CodeGen.Constant (genConstant)
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.EnumFlags (genEnum, genFlags)
-import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability)
+import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,
+ detectGObject)
import Data.GI.CodeGen.GObject
import Data.GI.CodeGen.Haddock (deprecatedPragma, addModuleDocumentation)
import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList,
@@ -256,7 +257,7 @@
<> name' <> " a) =>"
line $ " " <> className <> " a"
line $ "#endif"
- line $ "instance " <> className <> " " <> name'
+ bline $ "instance " <> className <> " " <> name'
forM_ parents $ \parent -> do
pcls <- classConstraint parent
line $ "instance " <> pcls <> " " <> name'
@@ -265,8 +266,8 @@
group $ do
let safeCast = "to" <> name'
exportDecl safeCast
- line $ safeCast <> " :: " <> className <> " o => o -> IO " <> name'
- line $ safeCast <> " = unsafeCastTo " <> name'
+ line $ safeCast <> " :: (MonadIO m, " <> className <> " o) => o -> m " <>
name'
+ line $ safeCast <> " = liftIO . unsafeCastTo " <> name'
-- Wrap a given Object. We enforce that every Object that we wrap is a
-- GObject. This is the case for everything except the ParamSpec* set
@@ -431,6 +432,9 @@
-- Try to guess nullability of properties when there is no
-- nullability info in the GIR.
$ map guessPropertyNullability
+ -- Not every interface providing signals or properties is
+ -- correctly annotated as descending from GObject, fix this.
+ $ map detectGObject
$ M.toList
$ apis
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Constant.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Constant.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Constant.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Constant.hs 2017-06-03
12:00:54.000000000 +0200
@@ -56,14 +56,14 @@
-- can be assigned to the corresponding Haskell type.
assignValue :: Text -> Type -> Text -> ExcCodeGen ()
assignValue name t@(TBasicType TPtr) value = do
- ht <- tshow <$> haskellType t
+ ht <- typeShow <$> haskellType t
writePattern name (ExplicitSynonym "ptrToIntPtr" "intPtrToPtr" value ht)
assignValue name t@(TBasicType b) value = do
- ht <- tshow <$> haskellType t
+ ht <- typeShow <$> haskellType t
hv <- showBasicType b value
writePattern name (SimpleSynonym hv ht)
assignValue name t@(TInterface _) value = do
- ht <- tshow <$> haskellType t
+ ht <- typeShow <$> haskellType t
api <- findAPI t
case api of
Just (APIEnum _) ->
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Conversions.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Conversions.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Conversions.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Conversions.hs 2017-06-03
12:00:54.000000000 +0200
@@ -41,14 +41,11 @@
import Control.Monad (when)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
-import Data.Int
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)
-import Data.Word
import GHC.Exts (IsString(..))
-import Foreign.C.Types (CInt, CUInt, CLong, CULong)
+import Foreign.C.Types (CInt, CUInt)
import Foreign.Storable (sizeOf)
import Data.GI.CodeGen.API
@@ -282,7 +279,7 @@
return $ M "packStorableArray"
| TCArray{} <- t = notImplementedError $
"Don't know how to pack C array of type " <> tshow t
- | otherwise = case (tshow hType, tshow fType) of
+ | otherwise = case (typeShow hType, typeShow fType) of
("T.Text", "CString") -> return $ M "textToCString"
("[Char]", "CString") -> return $ M "stringToCString"
("Char", "CInt") -> return "(fromIntegral . ord)"
@@ -292,8 +289,8 @@
("GType", "CGType") -> return "gtypeToCGType"
_ -> notImplementedError $
"Don't know how to convert "
- <> tshow hType <> " into "
- <> tshow fType <> ".\n"
+ <> typeShow hType <> " into "
+ <> typeShow fType <> ".\n"
<> "Internal type: "
<> tshow t
@@ -404,7 +401,7 @@
suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor
suForeignPtr isBoxed hType transfer = do
- let constructor = T.pack . tyConName . typeRepTyCon $ hType
+ let constructor = typeConName hType
if isBoxed then
boxedForeignPtr constructor transfer
else return $ M $ parenthesize $
@@ -422,7 +419,7 @@
fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor
fObjectToH t hType transfer = do
- let constructor = T.pack . tyConName . typeRepTyCon $ hType
+ let constructor = typeConName hType
isGO <- isGObject t
return $ M $ parenthesize $
case transfer of
@@ -437,7 +434,7 @@
fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor
fCallbackToH hType TransferNothing = do
- let constructor = T.pack . tyConName . typeRepTyCon $ hType
+ let constructor = typeConName hType
return (P (callbackDynamicWrapper constructor))
fCallbackToH _ transfer =
notImplementedError ("ForeignCallback with unsupported transfer type `"
@@ -491,7 +488,7 @@
"Don't know how to unpack C array of type " <> tshow t
| TByteArray <- t = return $ M "unpackGByteArray"
| TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet"
- | otherwise = case (tshow fType, tshow hType) of
+ | otherwise = case (typeShow fType, typeShow hType) of
("CString", "T.Text") -> return $ M "cstringToText"
("CString", "[Char]") -> return $ M "cstringToString"
("CInt", "Char") -> return "(chr . fromIntegral)"
@@ -501,8 +498,8 @@
("CGType", "GType") -> return "GType"
_ ->
notImplementedError $ "Don't know how to convert "
- <> tshow fType <> " into "
- <> tshow hType <> ".\n"
+ <> typeShow fType <> " into "
+ <> typeShow hType <> ".\n"
<> "Internal type: "
<> tshow t
@@ -623,7 +620,7 @@
return (ls, "[" <> name <> "]", constraints)
argumentType letters@(l:ls) t = do
api <- findAPI t
- s <- tshow <$> haskellType t
+ s <- typeShow <$> haskellType t
case api of
-- Instead of restricting to the actual class,
-- we allow for any object descending from it.
@@ -640,43 +637,44 @@
-- See [Note: Callables that throw]
if callableThrows (cbCallable cb)
then do
- ft <- tshow <$> foreignType t
+ ft <- typeShow <$> foreignType t
return (letters, ft, [])
else
return (letters, s, [])
_ -> return (letters, s, [])
-haskellBasicType TPtr = ptr $ typeOf ()
-haskellBasicType TBoolean = typeOf True
+haskellBasicType :: BasicType -> TypeRep
+haskellBasicType TPtr = ptr $ con0 "()"
+haskellBasicType TBoolean = con0 "Bool"
-- For all the platforms that we support (and those supported by glib)
-- we have gint == gint32. Encoding this assumption in the types saves
-- conversions.
haskellBasicType TInt = case sizeOf (0 :: CInt) of
- 4 -> typeOf (0 :: Int32)
+ 4 -> con0 "Int32"
n -> error ("Unsupported `gint' length: " ++
show n)
haskellBasicType TUInt = case sizeOf (0 :: CUInt) of
- 4 -> typeOf (0 :: Word32)
+ 4 -> con0 "Word32"
n -> error ("Unsupported `guint' length: " ++
show n)
-haskellBasicType TLong = typeOf (0 :: CLong)
-haskellBasicType TULong = typeOf (0 :: CULong)
-haskellBasicType TInt8 = typeOf (0 :: Int8)
-haskellBasicType TUInt8 = typeOf (0 :: Word8)
-haskellBasicType TInt16 = typeOf (0 :: Int16)
-haskellBasicType TUInt16 = typeOf (0 :: Word16)
-haskellBasicType TInt32 = typeOf (0 :: Int32)
-haskellBasicType TUInt32 = typeOf (0 :: Word32)
-haskellBasicType TInt64 = typeOf (0 :: Int64)
-haskellBasicType TUInt64 = typeOf (0 :: Word64)
-haskellBasicType TGType = "GType" `con` []
-haskellBasicType TUTF8 = "T.Text" `con` []
-haskellBasicType TFloat = typeOf (0 :: Float)
-haskellBasicType TDouble = typeOf (0 :: Double)
-haskellBasicType TUniChar = typeOf ('\0' :: Char)
-haskellBasicType TFileName = "[Char]" `con` []
-haskellBasicType TIntPtr = "CIntPtr" `con` []
-haskellBasicType TUIntPtr = "CUIntPtr" `con` []
+haskellBasicType TLong = con0 "CLong"
+haskellBasicType TULong = con0 "CULong"
+haskellBasicType TInt8 = con0 "Int8"
+haskellBasicType TUInt8 = con0 "Word8"
+haskellBasicType TInt16 = con0 "Int16"
+haskellBasicType TUInt16 = con0 "Word16"
+haskellBasicType TInt32 = con0 "Int32"
+haskellBasicType TUInt32 = con0 "Word32"
+haskellBasicType TInt64 = con0 "Int64"
+haskellBasicType TUInt64 = con0 "Word64"
+haskellBasicType TGType = con0 "GType"
+haskellBasicType TUTF8 = con0 "T.Text"
+haskellBasicType TFloat = con0 "Float"
+haskellBasicType TDouble = con0 "Double"
+haskellBasicType TUniChar = con0 "Char"
+haskellBasicType TFileName = con0 "[Char]"
+haskellBasicType TIntPtr = con0 "CIntPtr"
+haskellBasicType TUIntPtr = con0 "CUIntPtr"
-- This translates GI types to the types used for generated Haskell code.
haskellType :: Type -> CodeGen TypeRep
@@ -864,7 +862,7 @@
typePtrType (TBasicType TFileName) = return (Just FFIPtr)
typePtrType t = do
ft <- foreignType t
- case tyConName (typeRepTyCon ft) of
+ case typeConName ft of
"Ptr" -> return (Just FFIPtr)
"FunPtr" -> return (Just FFIFunPtr)
_ -> return Nothing
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Fixups.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Fixups.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Fixups.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Fixups.hs 2017-06-03
12:00:54.000000000 +0200
@@ -2,6 +2,7 @@
module Data.GI.CodeGen.Fixups
( dropMovedItems
, guessPropertyNullability
+ , detectGObject
) where
import Data.Maybe (isNothing, isJust)
@@ -112,7 +113,20 @@
-- | Find the first method with the given name, if any.
findMethod :: [Method] -> T.Text -> Maybe Method
-findMethod methods n =
- case filter ((== n) . name . methodName) methods of
- [m] -> Just m
- _ -> Nothing
+findMethod methods n = case filter ((== n) . name . methodName) methods of
+ [m] -> Just m
+ _ -> Nothing
+
+-- | Not every interface that provides signals/properties is marked as
+-- requiring GObject, but this is necessarily the case, so fix the
+-- introspection data accordingly.
+detectGObject :: (Name, API) -> (Name, API)
+detectGObject (n, APIInterface iface) =
+ if not (null (ifProperties iface) && null (ifSignals iface))
+ then let gobject = Name "GObject" "Object"
+ in if gobject `elem` (ifPrerequisites iface)
+ then (n, APIInterface iface)
+ else (n, APIInterface (iface {ifPrerequisites =
+ gobject : ifPrerequisites iface}))
+ else (n, APIInterface iface)
+detectGObject api = api
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/OverloadedMethods.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/OverloadedMethods.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/OverloadedMethods.hs
2017-03-27 22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/OverloadedMethods.hs
2017-06-03 12:00:54.000000000 +0200
@@ -36,8 +36,12 @@
line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "
<> "O.MethodInfo info " <> n <> " p) => O.IsLabel t ("
<> n <> " -> p) where"
+ line $ "#if MIN_VERSION_base(4,10,0)"
+ indent $ line $ "fromLabel = O.overloadedMethod (O.MethodProxy ::
O.MethodProxy info)"
+ line $ "#else"
indent $ line $ "fromLabel _ = O.overloadedMethod (O.MethodProxy ::
O.MethodProxy info)"
line $ "#endif"
+ line $ "#endif"
-- | Generate the `MethodList` instance given the list of methods for
-- the given named type.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/OverloadedSignals.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/OverloadedSignals.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/OverloadedSignals.hs
2017-03-27 22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/OverloadedSignals.hs
2017-06-03 12:00:54.000000000 +0200
@@ -18,7 +18,7 @@
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Inheritance (fullObjectSignalList,
fullInterfaceSignalList)
import Data.GI.CodeGen.GObject (apiIsGObject)
-import Data.GI.CodeGen.Signal (signalHaskellName)
+import Data.GI.CodeGen.Signal (signalHaskellName, genSignalConnector)
import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase,
qualifiedSymbol)
import Data.GI.CodeGen.Util (lcFirst, ucFirst)
@@ -86,7 +86,8 @@
let signalConnectorName = name <> sn
cbHaskellType = signalConnectorName <> "Callback"
line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType
- line $ "connectSignal _ = " <> "connect" <> name <> sn
+ line $ "connectSignal _ obj cb connectMode = do"
+ indent $ genSignalConnector signal cbHaskellType "connectMode"
exportSignal (lcFirst sn) si
-- | Signal instances for (GObject-derived) objects.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Properties.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Properties.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Properties.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Properties.hs 2017-06-03
12:00:54.000000000 +0200
@@ -122,11 +122,11 @@
<> "\" $ getObjectProperty" <> tStr
else "getObjectProperty" <> tStr
line $ getter <> " :: " <> constraints <>
- " => o -> " <> tshow ("m" `con` [outType])
+ " => o -> " <> typeShow ("m" `con` [outType])
line $ getter <> " obj = liftIO $ " <> getProp
<> " obj \"" <> propName prop <> "\"" <>
if tStr `elem` ["Object", "Boxed"]
- then " " <> tshow constructorType -- These require the constructor.
+ then " " <> typeShow constructorType -- These require the
constructor.
else ""
exportProperty docSection getter
@@ -149,7 +149,7 @@
genPropertyClear :: Text -> Name -> Text -> Property -> CodeGen ()
genPropertyClear clear n docSection prop = group $ do
- nothingType <- tshow . maybeT <$> haskellType (propType prop)
+ nothingType <- typeShow . maybeT <$> haskellType (propType prop)
cls <- classConstraint n
let constraints = ["MonadIO m", cls <> " o"]
tStr <- propTypeStr $ propType prop
@@ -257,8 +257,8 @@
then return "()"
else do
sOutType <- if isNullable && propReadNullable prop /= Just False
- then tshow . maybeT <$> haskellType (propType prop)
- else tshow <$> haskellType (propType prop)
+ then typeShow . maybeT <$> haskellType (propType
prop)
+ else typeShow <$> haskellType (propType prop)
return $ if T.any (== ' ') sOutType
then parenthesize sOutType
else sOutType
@@ -270,7 +270,7 @@
inConstraint <- if writable || constructOnly
then do
inIsGO <- isGObject (propType prop)
- hInType <- tshow <$> haskellType (propType prop)
+ hInType <- typeShow <$> haskellType (propType prop)
if inIsGO
then typeConstraint (propType prop)
else return $ "(~) " <> if T.any (== ' ') hInType
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Signal.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Signal.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Signal.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Signal.hs 2017-06-03
12:00:54.000000000 +0200
@@ -1,5 +1,6 @@
module Data.GI.CodeGen.Signal
( genSignal
+ , genSignalConnector
, genCallback
, signalHaskellName
) where
@@ -11,7 +12,6 @@
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
-import Data.Typeable (typeOf)
import Data.Bool (bool)
import qualified Data.Text as T
import Data.Text (Text)
@@ -49,10 +49,10 @@
forM_ hInArgs $ \arg -> do
ht <- haskellType (argType arg)
wrapMaybe arg >>= bool
- (line $ tshow ht <> " ->")
- (line $ tshow (maybeT ht) <> " ->")
+ (line $ typeShow ht <> " ->")
+ (line $ typeShow (maybeT ht) <> " ->")
ret <- hOutType cb hOutArgs
- line $ tshow $ io ret
+ line $ typeShow $ io ret
blank
@@ -76,14 +76,14 @@
let ht' = if direction arg /= DirectionIn
then ptr ht
else ht
- line $ tshow ht' <> " ->"
+ line $ typeShow ht' <> " ->"
when (callableThrows cb) $
line "Ptr (Ptr GError) ->"
when isSignal $ line $ withComment "Ptr () ->" "user_data"
ret <- io <$> case returnType cb of
- Nothing -> return $ typeOf ()
+ Nothing -> return $ con0 "()"
Just t -> foreignType t
- line $ tshow ret
+ line $ typeShow ret
return ctypeName
-- Generator for wrappers callable from C
@@ -257,14 +257,14 @@
let ht' = if direction arg /= DirectionIn
then ptr ht
else ht
- line $ tshow ht' <> " ->"
+ line $ typeShow ht' <> " ->"
when (callableThrows cb) $
line "Ptr (Ptr GError) ->"
when isSignal $ line "Ptr () ->"
ret <- io <$> case returnType cb of
- Nothing -> return $ typeOf ()
+ Nothing -> return $ con0 "()"
Just t -> foreignType t
- line $ tshow ret
+ line $ typeShow ret
let cArgNames = map escapedArgName (args cb)
allArgs = if isSignal
@@ -360,12 +360,12 @@
in w <> T.concat (map ucFirst ws)
genSignal :: Signal -> Name -> ExcCodeGen ()
-genSignal (Signal { sigName = sn, sigCallable = cb }) on = do
+genSignal s@(Signal { sigName = sn, sigCallable = cb }) on = do
let on' = upperName on
line $ "-- signal " <> on' <> "::" <> sn
- let sn' = signalHaskellName (sn)
+ let sn' = signalHaskellName sn
signalConnectorName = on' <> ucFirst sn'
cbType = signalConnectorName <> "Callback"
@@ -389,30 +389,36 @@
-- ("on...") or after the default handler runs (after...). We
-- provide convenient wrappers for both cases.
group $ do
- let signatureConstraints = "(GObject a, MonadIO m) =>"
+ -- Notice that we do not include GObject here as a constraint,
+ -- since if something provides signals it is necessarily a
+ -- GObject.
+ klass <- classConstraint on
+ let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>"
signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"
signature = " :: " <> signatureConstraints <> " " <> signatureArgs
onName = "on" <> signalConnectorName
afterName = "after" <> signalConnectorName
- line $ onName <> signature
- line $ onName <> " obj cb = liftIO $ connect"
- <> signalConnectorName <> " obj cb SignalConnectBefore"
- line $ afterName <> signature
- line $ afterName <> " obj cb = connect"
- <> signalConnectorName <> " obj cb SignalConnectAfter"
- exportSignal (lcFirst sn') onName
- exportSignal (lcFirst sn') afterName
- group $ do
- let fullName = "connect" <> signalConnectorName
- signatureConstraints = "(GObject a, MonadIO m) =>"
- signatureArgs = "a -> " <> cbType
- <> " -> SignalConnectMode -> m SignalHandlerId"
- line $ fullName <> " :: " <> signatureConstraints
- line $ T.replicate (4 + T.length fullName) " " <> signatureArgs
- line $ fullName <> " obj cb after = liftIO $ do"
- indent $ do
- cb' <- genWrappedCallback cb "cb" cbType True
- let cb'' = prime cb'
- line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb'
- line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " after"
+ group $ do
+ line $ onName <> signature
+ line $ onName <> " obj cb = liftIO $ do"
+ indent $ genSignalConnector s cbType "SignalConnectBefore"
+ exportSignal (lcFirst sn') onName
+
+ group $ do
+ line $ afterName <> signature
+ line $ afterName <> " obj cb = liftIO $ do"
+ indent $ genSignalConnector s cbType "SignalConnectAfter"
+ exportSignal (lcFirst sn') afterName
+
+-- | Generate the code for connecting the given signal. This assumes
+-- that it lives inside a @do@ block.
+genSignalConnector :: Signal
+ -> Text -- ^ Callback type
+ -> Text -- ^ SignalConnectBefore or SignalConnectAfter
+ -> CodeGen ()
+genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when = do
+ cb' <- genWrappedCallback cb "cb" cbType True
+ let cb'' = prime cb'
+ line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb'
+ line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Struct.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Struct.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Struct.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Struct.hs 2017-06-03
12:00:54.000000000 +0200
@@ -112,10 +112,10 @@
nullConvert <- if embedded
then return Nothing
else maybeNullConvert (fieldType field)
- hType <- tshow <$> if isJust nullConvert
- then maybeT <$> isoHaskellType (fieldType field)
- else isoHaskellType (fieldType field)
- fType <- tshow <$> foreignType (fieldType field)
+ hType <- typeShow <$> if isJust nullConvert
+ then maybeT <$> isoHaskellType (fieldType field)
+ else isoHaskellType (fieldType field)
+ fType <- typeShow <$> foreignType (fieldType field)
line $ getter <> " :: MonadIO m => " <> name' <> " -> m " <>
if T.any (== ' ') hType
@@ -154,10 +154,10 @@
isPtr <- typeIsPtr (fieldType field)
- fType <- tshow <$> foreignType (fieldType field)
+ fType <- typeShow <$> foreignType (fieldType field)
hType <- if isPtr
then return fType
- else tshow <$> haskellType (fieldType field)
+ else typeShow <$> haskellType (fieldType field)
line $ setter <> " :: MonadIO m => " <> name' <> " -> "
<> hType <> " -> m ()"
@@ -175,7 +175,7 @@
let name' = upperName n
let clear = fieldClear n field
- fType <- tshow <$> foreignType (fieldType field)
+ fType <- typeShow <$> foreignType (fieldType field)
line $ clear <> " :: MonadIO m => " <> name' <> " -> m ()"
line $ clear <> " s = liftIO $ withManagedPtr s $ \\ptr -> do"
@@ -211,12 +211,12 @@
embedded <- isEmbedded field
isNullable <- typeIsNullable (fieldType field)
- outType <- tshow <$> if not embedded && isNullable
- then maybeT <$> isoHaskellType (fieldType field)
- else isoHaskellType (fieldType field)
+ outType <- typeShow <$> if not embedded && isNullable
+ then maybeT <$> isoHaskellType (fieldType field)
+ else isoHaskellType (fieldType field)
inType <- if isPtr
- then tshow <$> foreignType (fieldType field)
- else tshow <$> haskellType (fieldType field)
+ then typeShow <$> foreignType (fieldType field)
+ else typeShow <$> haskellType (fieldType field)
line $ "data " <> it
line $ "instance AttrInfo " <> it <> " where"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Type.hs
new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Type.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/CodeGen/Type.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/CodeGen/Type.hs 2017-06-03
12:00:54.000000000 +0200
@@ -1,28 +1,72 @@
--- | Type constructors.
+-- | An abstraction for representing type constructors. This is a very
+-- simplified version of `Data.Typeable`, which we don't use directly
+-- to avoid compatibility headaches.
module Data.GI.CodeGen.Type
( Type(..) -- Reexported for convenience.
, BasicType(..)
+ , TypeRep
+
+ , con
+ , con0
+
+ , typeShow
+ , typeConName
+
, io
, ptr
, funptr
- , con
, maybeT
) where
-import Data.Typeable (TypeRep, mkTyConApp, typeOf, typeRepTyCon, mkTyCon3)
+import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text (Text)
import Data.GI.GIR.BasicTypes (Type(..), BasicType(..))
+-- | A fully applied type.
+data TypeRep = TypeRep { typeCon :: TypeCon
+ , typeConArgs :: [TypeRep]
+ } deriving (Eq)
+
+-- | A type constructor. We single out some specific constructors
+-- since they have special syntax in their Haskell representation.
+data TypeCon = TupleCon
+ | ListCon
+ | TextualCon Text
+ deriving (Eq)
+
+-- | Give a valid Haskell source representation of the given
+-- `TypeRep`.
+typeShow :: TypeRep -> Text
+typeShow (TypeRep TupleCon args) =
+ "(" <> T.intercalate ", " (map typeShow args) <> ")"
+typeShow (TypeRep ListCon args) =
+ "[" <> T.intercalate ", " (map typeShow args) <> "]"
+typeShow (TypeRep (TextualCon con) args) =
+ T.intercalate " " (con : map (parenthesize . typeShow) args)
+ where parenthesize :: Text -> Text
+ parenthesize s = if T.any (== ' ') s
+ then "(" <> s <> ")"
+ else s
+
+-- | Return a textual representation of the type constructor for the
+-- given `TypeRep`.
+typeConName :: TypeRep -> Text
+typeConName (TypeRep TupleCon _) = "(,)"
+typeConName (TypeRep ListCon _) = "[,]"
+typeConName (TypeRep (TextualCon s) _) = s
+
-- | Type constructor applied to the given types.
con :: Text -> [TypeRep] -> TypeRep
-con "[]" xs = mkTyConApp listCon xs
- where listCon = typeRepTyCon (typeOf [True])
-con "(,)" xs = mkTyConApp tupleCon xs
- where tupleCon = typeRepTyCon (typeOf (True, True))
-con s xs = mkTyConApp (mkTyCon3 "GI" "GI" (T.unpack s)) xs
+con "[]" xs = TypeRep {typeCon = ListCon, typeConArgs = xs }
+con "(,)" xs = TypeRep {typeCon = TupleCon, typeConArgs = xs }
+con s xs = TypeRep {typeCon = TextualCon s, typeConArgs = xs}
+
+-- | A shorthand for a type constructor taking no arguments.
+con0 :: Text -> TypeRep
+con0 c = con c []
-- | Embed in the `IO` monad.
io :: TypeRep -> TypeRep
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/haskell-gi-0.20.1/lib/Data/GI/GIR/Repository.hs
new/haskell-gi-0.20.2/lib/Data/GI/GIR/Repository.hs
--- old/haskell-gi-0.20.1/lib/Data/GI/GIR/Repository.hs 2017-03-27
22:44:51.000000000 +0200
+++ new/haskell-gi-0.20.2/lib/Data/GI/GIR/Repository.hs 2017-06-03
12:00:54.000000000 +0200
@@ -19,9 +19,6 @@
import System.Environment.XDG.BaseDir (getSystemDataDirs)
import System.FilePath (searchPathSeparator, takeBaseName, (</>), (<.>))
-girDataDirs :: IO [FilePath]
-girDataDirs = getSystemDataDirs "gir-1.0"
-
girFilePath :: String -> String -> FilePath -> FilePath
girFilePath name version path = path </> name ++ "-" ++ version <.> "gir"
@@ -52,21 +49,29 @@
then reverse acc : go ys []
else go ys (y : acc)
--- | Search for an appropriate @.gir@ file in the search path. This is
--- either passed in explicitly, or if that is absent, loaded from the
--- environment variable @HASKELL_GI_GIR_SEARCH_PATH@. In either case
+girDataDirs :: IO [FilePath]
+girDataDirs = getSystemDataDirs "gir-1.0"
+
+-- | Construct the GIR search path, possibly looking into the
+-- @HASKELL_GI_GIR_SEARCH_PATH@ environment variable if no explicit
+-- list of extra paths is given. In either case
-- the system data dirs are also searched if nothing can be found in
-- the explicitly passed paths, or in the contents of
-- @HASKELL_GI_GIR_SEARCH_PATH@.
-girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath)
-girFile name version extraPaths = do
+buildSearchPath :: [FilePath] -> IO [FilePath]
+buildSearchPath extraPaths = do
paths <- case extraPaths of
[] -> lookupEnv "HASKELL_GI_GIR_SEARCH_PATH" >>= \case
- Nothing -> return []
- Just s -> return (splitOn searchPathSeparator s)
+ Nothing -> return []
+ Just s -> return (splitOn searchPathSeparator s)
ps -> return ps
dataDirs <- girDataDirs
- firstJust <$> (mapM (girFile' name version) (paths ++ dataDirs))
+ return (paths ++ dataDirs)
+
+-- | Search for an appropriate @.gir@ file in the search path.
+girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath)
+girFile name version searchPath =
+ firstJust <$> (mapM (girFile' name version) searchPath)
where firstJust = listToMaybe . catMaybes
-- | Try to load the `.gir` file corresponding to the given repository
@@ -75,13 +80,13 @@
-> Maybe Text -- ^ version
-> [FilePath] -- ^ searchPath
-> IO XML.Document
-readGiRepository verbose name version extraPaths =
- girFile name version extraPaths >>= \case
+readGiRepository verbose name version extraPaths = do
+ searchPath <- buildSearchPath extraPaths
+ girFile name version searchPath >>= \case
Just path -> do
when verbose $ putStrLn $ "Loading GI repository: " ++ path
XML.readFile XML.def path
- Nothing -> do
- dataDirs <- girDataDirs
- error $ "Did not find a GI repository for " ++ (T.unpack name)
- ++ maybe "" ("-" ++) (T.unpack <$> version)
- ++ " in " ++ show dataDirs
+ Nothing -> error $ "Did not find a GI repository for "
+ ++ (T.unpack name)
+ ++ maybe "" ("-" ++) (T.unpack <$> version)
+ ++ " in " ++ show searchPath ++ "."
