haskell-gi 0.20.1 → 0.20.2

raw patch · 16 files changed

+277/−171 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−8
• cmdline/haskell-gi.hs +21/−9
• haskell-gi.cabal +1/−1
• lib/Data/GI/CodeGen/CabalHooks.hs +25/−9
• lib/Data/GI/CodeGen/Callable.hs +13/−15
• lib/Data/GI/CodeGen/CodeGen.hs +8/−4
• lib/Data/GI/CodeGen/Constant.hs +3/−3
• lib/Data/GI/CodeGen/Conversions.hs +36/−38
• lib/Data/GI/CodeGen/Fixups.hs +18/−4
• lib/Data/GI/CodeGen/OverloadedMethods.hs +4/−0
• lib/Data/GI/CodeGen/OverloadedSignals.hs +3/−2
• lib/Data/GI/CodeGen/Properties.hs +6/−6
• lib/Data/GI/CodeGen/Signal.hs +40/−34
• lib/Data/GI/CodeGen/Struct.hs +12/−12
• lib/Data/GI/CodeGen/Type.hs +52/−8
• lib/Data/GI/GIR/Repository.hs +23/−18

@@ -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.

@@ -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 ()

@@ -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.

@@ -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@.

@@ -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)

@@ -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 

@@ -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 _) ->

@@ -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

@@ -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

@@ -36,7 +36,11 @@     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

@@ -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.

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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 ++ "."