haskell-gi 0.23.0 → 0.23.1

raw patch · 18 files changed

+367/−171 lines, 18 filesdep +ansi-terminaldep ~attoparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ansi-terminal

Dependency ranges changed: attoparsec

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• haskell-gi.cabal +4/−2
• lib/Data/GI/CodeGen/API.hs +151/−74
• lib/Data/GI/CodeGen/Callable.hs +17/−9
• lib/Data/GI/CodeGen/Code.hs +30/−9
• lib/Data/GI/CodeGen/CodeGen.hs +27/−26
• lib/Data/GI/CodeGen/Constant.hs +4/−1
• lib/Data/GI/CodeGen/CtoHaskellMap.hs +6/−5
• lib/Data/GI/CodeGen/EnumFlags.hs +6/−2
• lib/Data/GI/CodeGen/LibGIRepository.hs +41/−19
• lib/Data/GI/CodeGen/Properties.hs +7/−6
• lib/Data/GI/CodeGen/Signal.hs +11/−9
• lib/Data/GI/CodeGen/Struct.hs +5/−4
• lib/Data/GI/CodeGen/Util.hs +37/−4
• lib/Data/GI/GIR/Callable.hs +14/−1
• lib/Data/GI/GIR/Function.hs +1/−0
• lib/Data/GI/GIR/Method.hs +1/−0
• lib/Data/GI/GIR/Parser.hs +1/−0

@@ -1,3 +1,7 @@+### 0.23.1+++ Check whether symbols exist in the dynamic library before trying to generate bindings for them, in order to avoid linker errors.+ ### 0.23.0  + gobjectType now does not require a proxy argument, it needs to be used with TypeApplications instead.

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.23.0+version:             0.23.1 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.@@ -14,7 +14,7 @@ stability:           Experimental category:            Development build-type:          Simple-tested-with:         GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1+tested-with:         GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.1, GHC == 8.10.1 cabal-version:       2.0  extra-source-files: ChangeLog.md@@ -36,6 +36,7 @@                        mtl >= 2.2,                        transformers >= 0.3,                        pretty-show,+                       ansi-terminal ^>= 0.10,                        process,                        safe,                        bytestring,@@ -123,3 +124,4 @@                , process                , doctest >= 0.8                , haskell-gi+               , attoparsec

@@ -58,13 +58,14 @@ import Control.Applicative ((<$>)) #endif -import Control.Monad ((>=>), foldM, forM, forM_)+import Control.Monad ((>=>), foldM, forM, when) import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (mapMaybe, catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif+ import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text)@@ -106,11 +107,12 @@ import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) import Data.GI.Base.Utils (allocMem, freeMem)-import Data.GI.CodeGen.LibGIRepository (girRequire, FieldInfo(..),+import Data.GI.CodeGen.LibGIRepository (girRequire, Typelib, FieldInfo(..),                                         girStructFieldInfo, girUnionFieldInfo,-                                        girLoadGType)+                                        girLoadGType, girIsSymbolResolvable) import Data.GI.CodeGen.GType (gtypeIsBoxed) import Data.GI.CodeGen.Type (Type)+import Data.GI.CodeGen.Util (printWarning, terror, tshow)  data GIRInfo = GIRInfo {       girPCPackages      :: [Text],@@ -158,6 +160,7 @@                                      -- the given selector.              deriving (Show) +-- | An element in the exposed API data API     = APIConst Constant     | APIFunction Function@@ -261,7 +264,7 @@         | S.null requested = return loaded         | otherwise = do   let (name, version) = S.elemAt 0 requested-  doc <- fixupGIRDocument rules <$>+  doc <- overrideGIRDocument rules <$>          readGiRepository verbose name (Just version) extraPaths   let newLoaded = M.insert (name, version) doc loaded       loadedSet = S.fromList (M.keys newLoaded)@@ -274,11 +277,11 @@             -> Text             -- ^ name             -> Maybe Text       -- ^ version             -> [FilePath]       -- ^ extra paths to search-            -> [GIRRule]        -- ^ fixups+            -> [GIRRule]        -- ^ overrides             -> IO (Document,                    M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies) loadGIRFile verbose name version extraPaths rules = do-  doc <- fixupGIRDocument rules <$>+  doc <- overrideGIRDocument rules <$>          readGiRepository verbose name version extraPaths   deps <- loadDependencies verbose (documentListIncludes doc) M.empty           extraPaths rules@@ -313,37 +316,34 @@     Left err -> error . T.unpack $ "Error when raw parsing \"" <> name <> "\": " <> err     Right docGIR -> return docGIR --- | Load and parse a GIR file, including its dependencies.-loadGIRInfo :: Bool             -- ^ verbose-            -> Text             -- ^ name-            -> Maybe Text       -- ^ version-            -> [FilePath]       -- ^ extra paths to search-            -> [GIRRule]        -- ^ fixups-            -> IO (GIRInfo,-                   [GIRInfo])   -- ^ (parsed doc, parsed deps)-loadGIRInfo verbose name version extraPaths rules =  do-  (doc, deps) <- loadGIRFile verbose name version extraPaths rules-  let aliases = M.unions (map documentListAliases (doc : M.elems deps))-      parsedDoc = toGIRInfo (parseGIRDocument aliases doc)-      parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)-  case combineErrors parsedDoc parsedDeps of-    Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err-    Right (docGIR, depsGIR) -> do-      if girNSName docGIR == name-      then do-        forM_ (docGIR : depsGIR) $ \info ->-            girRequire (girNSName info) (girNSVersion info)-        (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR-        return (fixedDoc, fixedDeps)-      else error . T.unpack $ "Got unexpected namespace \""-               <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."-  where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]-                      -> Either Text (GIRInfo, [GIRInfo])-        combineErrors parsedDoc parsedDeps = do-          doc <- parsedDoc-          deps <- sequence parsedDeps-          return (doc, deps)+-- | Fixup parsed GIRInfos: some of the required information is not+-- found in the GIR files themselves, or does not accurately reflect+-- the content in the dynamic library itself, but this can be+-- corrected by checking the typelib.+fixupGIRInfos :: Bool -> M.Map Text Typelib -> GIRInfo -> [GIRInfo]+              -> IO (GIRInfo, [GIRInfo])+fixupGIRInfos verbose typelibMap doc deps =+  (fixup (fixupInterface typelibMap ctypes) >=>+    fixup (fixupStruct typelibMap) >=>+    fixup fixupUnion >=>+    fixup (fixupMissingSymbols verbose typelibMap)+  ) (doc, deps)+  where fixup :: ((Name, API) -> IO (Name, API))+                 -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])+        fixup fixer (doc, deps) = do+          fixedDoc <- fixAPIs fixer doc+          fixedDeps <- mapM (fixAPIs fixer) deps+          return (fixedDoc, fixedDeps) +        fixAPIs :: ((Name, API) -> IO (Name, API))+                -> GIRInfo -> IO GIRInfo+        fixAPIs fixer info = do+          fixedAPIs <- mapM fixer (girAPIs info)+          return $ info {girAPIs = fixedAPIs}++        ctypes :: M.Map Text Name+        ctypes = M.unions (map girCTypes (doc:deps))+ foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType)  -- | List the prerequisites for a 'GType' corresponding to an interface.@@ -360,19 +360,22 @@ -- | The list of prerequisites in GIR files is not always -- accurate. Instead of relying on this, we instantiate the 'GType' -- associated to the interface, and listing the interfaces from there.-fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do+fixupInterface :: M.Map Text Typelib -> M.Map Text Name -> (Name, API)+               -> IO (Name, API)+fixupInterface typelibMap csymbolMap (n@(Name ns _), APIInterface iface) = do   prereqs <- case ifTypeInit iface of                Nothing -> return []                Just ti -> do-                 gtype <- girLoadGType ns ti+                 gtype <- case M.lookup ns typelibMap of+                            Just typelib -> girLoadGType typelib ti+                            Nothing -> error $ "fi: Typelib for " ++ show ns ++ " not loaded."                  prereqGTypes <- gtypeInterfaceListPrereqs gtype                  forM prereqGTypes $ \p -> do                    case M.lookup p csymbolMap of                      Just pn -> return pn                      Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n   return (n, APIInterface (iface {ifPrerequisites = prereqs}))-fixupInterface _ (n, api) = return (n, api)+fixupInterface _ _ (n, api) = return (n, api)  -- | There is not enough info in the GIR files to determine whether a -- struct is boxed. We find out by instantiating the 'GType'@@ -380,23 +383,27 @@ -- descends from the boxed GType. Similarly, the size of the struct -- and offset of the fields is hard to compute from the GIR data, we -- simply reuse the machinery in libgirepository.-fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupStruct _ (n, APIStruct s) = do-  fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s+fixupStruct :: M.Map Text Typelib -> (Name, API)+            -> IO (Name, API)+fixupStruct typelibMap (n, APIStruct s) = do+  fixed <- (fixupStructIsBoxed typelibMap n >=> fixupStructSizeAndOffsets n) s   return (n, APIStruct fixed) fixupStruct _ api = return api  -- | Find out whether the struct is boxed.-fixupStructIsBoxed :: Name -> Struct -> IO Struct+fixupStructIsBoxed :: M.Map Text Typelib -> Name -> Struct -> IO Struct -- The type for "GVariant" is marked as "intern", we wrap -- this one natively.-fixupStructIsBoxed (Name "GLib" "Variant") s =+fixupStructIsBoxed _ (Name "GLib" "Variant") s =     return (s {structIsBoxed = False})-fixupStructIsBoxed (Name ns _) s = do+fixupStructIsBoxed typelibMap (Name ns _) s = do   isBoxed <- case structTypeInit s of                Nothing -> return False                Just ti -> do-                 gtype <- girLoadGType ns ti+                 gtype <- case M.lookup ns typelibMap of+                   Just typelib -> girLoadGType typelib ti+                   Nothing -> error $ "fsib: Typelib for " ++ show ns ++ " not loaded."+                  return (gtypeIsBoxed gtype)   return (s {structIsBoxed = isBoxed}) @@ -409,11 +416,11 @@             , structFields = map (fixupField infoMap) (structFields s)})  -- | Same thing for unions.-fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupUnion _ (n, APIUnion u) = do+fixupUnion :: (Name, API) -> IO (Name, API)+fixupUnion (n, APIUnion u) = do   fixed <- (fixupUnionSizeAndOffsets n) u   return (n, APIUnion fixed)-fixupUnion _ api = return api+fixupUnion api = return api  -- | Like 'fixupStructSizeAndOffset' above. fixupUnionSizeAndOffsets :: Name -> Union -> IO Union@@ -430,38 +437,108 @@                                   ++ show (fieldName f)                        Just o -> fieldInfoOffset o } --- | Fixup parsed GIRInfos: some of the required information is not--- found in the GIR files themselves, but can be obtained by--- instantiating the required GTypes from the installed libraries.-fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])-fixupGIRInfos doc deps = (fixup fixupInterface >=>-                          fixup fixupStruct >=>-                          fixup fixupUnion) (doc, deps)-  where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API))-                 -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])-        fixup fixer (doc, deps) = do-          fixedDoc <- fixAPIs fixer doc-          fixedDeps <- mapM (fixAPIs fixer) deps-          return (fixedDoc, fixedDeps)+-- | Some of the symbols listed in the introspection data are not+-- present in the dynamic library itself. Generating bindings for+-- these will sometimes lead to linker errors, so here we check that+-- every symbol listed in the bindings is actually present.+fixupMissingSymbols :: Bool -> M.Map Text Typelib -> (Name, API)+                    -> IO (Name, API)+fixupMissingSymbols verbose typelibMap (n, APIStruct s) = do+  fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+                                            (structMethods s) verbose+  return (n, APIStruct (s {structMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIUnion u) = do+  fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+                                            (unionMethods u) verbose+  return (n, APIUnion (u {unionMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIObject o) = do+  fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+                                            (objMethods o) verbose+  return (n, APIObject (o {objMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIInterface i) = do+  fixedMethods <- fixupMethodMissingSymbols (resolveTypelib n typelibMap)+                                            (ifMethods i) verbose+  return (n, APIInterface (i {ifMethods = fixedMethods}))+fixupMissingSymbols verbose typelibMap (n, APIFunction f) =+  fixupFunctionSymbols typelibMap (n, f) verbose+fixupMissingSymbols _ _ (n, api) = return (n, api) -        fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo-        fixAPIs fixer info = do-          fixedAPIs <- mapM (fixer ctypes) (girAPIs info)-          return $ info {girAPIs = fixedAPIs}+-- | Resolve the typelib owning the given name, erroring out if the+-- typelib is not known.+resolveTypelib :: Name -> M.Map Text Typelib -> Typelib+resolveTypelib n typelibMap = case M.lookup (namespace n) typelibMap of+  Nothing -> terror $ "Could not find typelib for “" <> namespace n <> "”."+  Just typelib -> typelib -        ctypes :: M.Map Text Name-        ctypes = M.unions (map girCTypes (doc:deps))+-- | Mark whether the methods can be resolved in the given typelib.+fixupMethodMissingSymbols :: Typelib -> [Method] -> Bool -> IO [Method]+fixupMethodMissingSymbols typelib methods verbose = mapM check methods+  where check :: Method -> IO Method+        check method@Method{methodCallable = callable} = do+          resolvable <- girIsSymbolResolvable typelib (methodSymbol method)+          when (verbose && not resolvable) $+            printWarning $ "Could not resolve the callable “"+                           <> methodSymbol method+                           <> "” in the “" <> tshow typelib+                           <> "” typelib, ignoring."+          let callable' = callable{callableResolvable = Just resolvable}+          return $ method{methodCallable = callable'} +-- | Check that the symbol the function refers to is actually present+-- in the dynamic library.+fixupFunctionSymbols :: M.Map Text Typelib -> (Name, Function) -> Bool+                            -> IO (Name, API)+fixupFunctionSymbols typelibMap (n, f) verbose = do+  let typelib = resolveTypelib n typelibMap+  resolvable <- girIsSymbolResolvable typelib (fnSymbol f)+  when (verbose && not resolvable) $+    printWarning $ "Could not resolve the function “" <> fnSymbol f+                    <> "” in the “" <> tshow typelib <> "” typelib, ignoring."+  let callable' = (fnCallable f){callableResolvable = Just resolvable}+  return (n, APIFunction (f {fnCallable = callable'}))++-- | Load and parse a GIR file, including its dependencies.+loadGIRInfo :: Bool             -- ^ verbose+            -> Text             -- ^ name+            -> Maybe Text       -- ^ version+            -> [FilePath]       -- ^ extra paths to search+            -> [GIRRule]        -- ^ fixups+            -> IO (GIRInfo, [GIRInfo])+            -- ^ (parsed doc,  parsed deps)+loadGIRInfo verbose name version extraPaths rules =  do+  (doc, deps) <- loadGIRFile verbose name version extraPaths rules+  let aliases = M.unions (map documentListAliases (doc : M.elems deps))+      parsedDoc = toGIRInfo (parseGIRDocument aliases doc)+      parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)+  case combineErrors parsedDoc parsedDeps of+    Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err+    Right (docGIR, depsGIR) -> do+      if girNSName docGIR == name+      then do+        typelibMap <- M.fromList <$> (forM (docGIR : depsGIR) $ \info -> do+             typelib <- girRequire (girNSName info) (girNSVersion info)+             return (girNSName info, typelib))+        (fixedDoc, fixedDeps) <- fixupGIRInfos verbose typelibMap docGIR depsGIR+        return (fixedDoc, fixedDeps)+      else error . T.unpack $ "Got unexpected namespace \""+               <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."+  where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]+                      -> Either Text (GIRInfo, [GIRInfo])+        combineErrors parsedDoc parsedDeps = do+          doc <- parsedDoc+          deps <- sequence parsedDeps+          return (doc, deps)+ -- | Given a XML document containing GIR data, apply the given overrides.-fixupGIRDocument :: [GIRRule] -> XML.Document -> XML.Document-fixupGIRDocument rules doc =-    doc {XML.documentRoot = fixupGIR rules (XML.documentRoot doc)}+overrideGIRDocument :: [GIRRule] -> XML.Document -> XML.Document+overrideGIRDocument rules doc =+    doc {XML.documentRoot = overrideGIR rules (XML.documentRoot doc)}  -- | Looks for the given path in the given subelements of the given -- element. If the path is empty apply the corresponding rule, -- otherwise return the element ummodified.-fixupGIR :: [GIRRule] -> XML.Element -> XML.Element-fixupGIR rules elem =+overrideGIR :: [GIRRule] -> XML.Element -> XML.Element+overrideGIR rules elem =     elem {XML.elementNodes =           mapMaybe (\e -> foldM applyGIRRule e rules) (XML.elementNodes elem)}     where applyGIRRule :: XML.Node -> GIRRule -> Maybe XML.Node

@@ -912,19 +912,27 @@  -- | Generate a wrapper for a known C symbol. genCCallableWrapper :: Name -> Text -> Callable -> ExcCodeGen ()-genCCallableWrapper n cSymbol callable = do-  genCallableDebugInfo callable+genCCallableWrapper n cSymbol callable+  | callableResolvable callable == Nothing =+      -- If we reach this point there is some internal error.+      terror ("Resolvability of “" <> cSymbol <> "” unkown.")+  | callableResolvable callable == Just False =+      badIntroError ("Could not resolve the symbol “" <> cSymbol+                     <> "” in the “" <> namespace n+                     <> "” namespace, ignoring.")+  | otherwise = do+      genCallableDebugInfo callable -  let callable' = fixupCallerAllocates callable+      let callable' = fixupCallerAllocates callable -  hSymbol <- mkForeignImport cSymbol callable'+      hSymbol <- mkForeignImport cSymbol callable' -  blank+      blank -  deprecatedPragma (lowerName n) (callableDeprecated callable)-  writeDocumentation DocBeforeSymbol (callableDocumentation callable)-  void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'-         WithoutClosures)+      deprecatedPragma (lowerName n) (callableDeprecated callable)+      writeDocumentation DocBeforeSymbol (callableDocumentation callable)+      void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'+            WithoutClosures)  -- | For callbacks we do not need to keep track of which arguments are -- closures.

@@ -24,7 +24,7 @@     , recurseWithAPIs      , handleCGExc-    , describeCGError+    , printCGError     , notImplementedError     , badIntroError     , missingInfoError@@ -35,6 +35,7 @@     , line     , blank     , group+    , comment     , cppIf     , CPPGuard(..)     , hsBoot@@ -126,6 +127,7 @@     = Line Text           -- ^ A single line, indented to current indentation.     | Indent Code         -- ^ Indented region.     | Group Code          -- ^ A grouped set of lines+    | Comment [Text]      -- ^ A (possibly multi line) comment     | IncreaseIndent      -- ^ Increase the indentation for the rest                           -- of the lines in the group.     | CPPBlock CPPConditional Code -- ^ A block of code guarded by the@@ -495,12 +497,14 @@     maximum (moduleMinBase minfo             : map minBaseVersion (M.elems $ submodules minfo)) --- | Give a friendly textual description of the error for presenting--- to the user.-describeCGError :: CGError -> Text-describeCGError (CGErrorNotImplemented e) = "Not implemented: " <> tshow e-describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " <> tshow e-describeCGError (CGErrorMissingInfo e) = "Missing info: " <> tshow e+-- | Print, as a comment, a friendly textual description of the error.+printCGError :: CGError -> CodeGen ()+printCGError (CGErrorNotImplemented e) = do+  comment $ "Not implemented: " <> e+printCGError (CGErrorBadIntrospectionInfo e) =+  comment $ "Bad introspection data: " <> e+printCGError (CGErrorMissingInfo e) =+  comment $ "Missing info: " <> e  notImplementedError :: Text -> ExcCodeGen a notImplementedError s = throwError $ CGErrorNotImplemented s@@ -571,6 +575,10 @@ blank :: CodeGen () blank = line "" +-- | A (possibly multi line) comment, separated by newlines+comment :: Text -> CodeGen ()+comment = tellCode . Comment . T.lines+ -- | Increase the indent level for code generation. indent :: BaseCodeGen e a -> BaseCodeGen e a indent cg = do@@ -687,17 +695,29 @@                                       genCode n (viewl rest)         genCode n (Group (Code seq) :< rest) = genCode n (viewl seq) <>                                                genCode n (viewl rest)+        genCode n (Comment [] :< rest) = genCode n (viewl rest)+        genCode n (Comment [s] :< rest) =+          B.fromText (paddedLine n ("-- " <> s)) <> genCode n (viewl rest)+        genCode n (Comment (l:ls):< rest) =+          B.fromText ("{-  " <> l <> "\n" <>+                      paddedLines (n+1) ls <> "-}\n") <> genCode n (viewl rest)         genCode n (CPPBlock cond (Code seq) :< rest) =           let (condBegin, condEnd) = cppCondFormat cond           in B.fromText condBegin <> genCode n (viewl seq) <>              B.fromText condEnd <> genCode n (viewl rest)         genCode n (IncreaseIndent :< rest) = genCode (n+1) (viewl rest) --- | Pad a line to the given number of leading spaces, and add a--- newline at the end.+-- | Pad a line to the given number of leading tabs (with one tab+-- equal to four spaces), and add a newline at the end. paddedLine :: Int -> Text -> Text paddedLine n s = T.replicate (n * 4) " " <> s <> "\n" +-- | Pad a set of lines to the given number of leading tabs (with one+-- tab equal to four spaces), and add a newline at the end of each+-- line.+paddedLines :: Int -> [Text] -> Text+paddedLines n ls = mconcat $ map (paddedLine n) ls+ -- | Put a (padded) comma at the end of the text. comma :: Text -> Text comma s = padTo 40 s <> ","@@ -911,6 +931,7 @@                 , "import qualified Data.GI.Base.CallStack as B.CallStack"                 , "import qualified Data.GI.Base.Properties as B.Properties"                 , "import qualified Data.GI.Base.Signals as B.Signals"+                , "import qualified Control.Monad.IO.Class as MIO"                 , "import qualified Data.Text as T"                 , "import qualified Data.ByteString.Char8 as B"                 , "import qualified Data.Map as Map"

@@ -51,10 +51,12 @@     -- Only generate the function if it has not been moved.     when (Nothing == fnMovedTo) $       group $ do-        line $ "-- function " <> symbol-        handleCGExc (\e -> line ("-- XXX Could not generate function "-                           <> symbol-                           <> "\n-- Error was : " <> describeCGError e))+        line $ "-- function " <> name n+        handleCGExc (\e -> do+                        line ("-- XXX Could not generate function "+                              <> name n+                              <> "\n")+                        printCGError e)                         (do                           genCCallableWrapper n symbol callable                           export (NamedSubsection MethodSection $ lowerName n) (lowerName n)@@ -130,10 +132,10 @@        isFunction <- symbolFromFunction (methodSymbol f)        if not isFunction        then handleCGExc-               (\e -> line ("-- XXX Could not generate method "-                            <> name' <> "::" <> name mn <> "\n"-                            <> "-- Error was : " <> describeCGError e) >>-                return Nothing)+               (\e -> do line ("-- XXX Could not generate method "+                               <> name' <> "::" <> name mn)+                         printCGError e+                         return Nothing)                (genMethod n f >> return (Just (n, f)))        else return Nothing @@ -174,10 +176,10 @@       isFunction <- symbolFromFunction (methodSymbol f)       if not isFunction       then handleCGExc-                (\e -> line ("-- XXX Could not generate method "-                             <> name' <> "::" <> name mn <> "\n"-                             <> "-- Error was : " <> describeCGError e)-                >> return Nothing)+                (\e -> do line ("-- XXX Could not generate method "+                                <> name' <> "::" <> name mn)+                          printCGError e+                          return Nothing)                 (genMethod n f >> return (Just (n, f)))       else return Nothing @@ -379,11 +381,11 @@     -- Methods     forM_ (objMethods o) $ \f -> do       let mn = methodName f-      handleCGExc (\e -> line ("-- XXX Could not generate method "-                              <> name' <> "::" <> name mn <> "\n"-                              <> "-- Error was : " <> describeCGError e)-                  >> (cppIf CPPOverloading $-                           genUnsupportedMethodInfo n f))+      handleCGExc (\e -> do line ("-- XXX Could not generate method "+                                  <> name' <> "::" <> name mn)+                            printCGError e+                            cppIf CPPOverloading $+                              genUnsupportedMethodInfo n f)                   (genMethod n f)  genInterface :: Name -> Interface -> CodeGen ()@@ -402,9 +404,9 @@   noName name'    forM_ (ifSignals iface) $ \s -> handleCGExc-     (line . (T.concat ["-- XXX Could not generate signal ", name', "::"-                     , sigName s-                     , "\n", "-- Error was : "] <>) . describeCGError)+     (\e -> do line $ T.concat ["-- XXX Could not generate signal ", name', "::"+                               , sigName s]+               printCGError e)      (genSignal s n)    cppIf CPPOverloading $@@ -443,7 +445,7 @@     genWrappedPtr n (ifAllocationInfo iface) 0      when (not . null . ifProperties $ iface) $ group $ do-       line $ "-- XXX Skipping property generation for non-GObject interface"+       comment $ "XXX Skipping property generation for non-GObject interface"    -- Methods   cppIf CPPOverloading $@@ -454,11 +456,10 @@       isFunction <- symbolFromFunction (methodSymbol f)       unless isFunction $              handleCGExc-             (\e -> line ("-- XXX Could not generate method "-                          <> name' <> "::" <> name mn <> "\n"-                          <> "-- Error was : " <> describeCGError e)-             >> (cppIf CPPOverloading $-                      genUnsupportedMethodInfo n f))+             (\e -> do comment ("XXX Could not generate method "+                                <> name' <> "::" <> name mn)+                       printCGError e+                       cppIf CPPOverloading (genUnsupportedMethodInfo n f))              (genMethod n f)  -- Some type libraries include spurious interface/struct methods,

@@ -45,7 +45,10 @@   setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"]   deprecatedPragma name (constantDeprecated c) -  handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)+  handleCGExc (\e -> do+                  line $ "-- XXX: Could not generate constant"+                  printCGError e+              )     (do writeDocumentation DocBeforeSymbol (constantDocumentation c)         assignValue name (constantType c) (constantValue c)         export ToplevelSection ("pattern " <> ucFirst name))

@@ -6,6 +6,7 @@   ) where  import qualified Data.Map as M+import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif@@ -104,13 +105,13 @@  -- | Refs to the methods for a given owner. methodRefs :: Name -> API -> [Method] -> [(CRef, Hyperlink)]-methodRefs n api methods = map methodRef methods-  where methodRef :: Method -> (CRef, Hyperlink)-        methodRef m@(Method {methodName = mn}) =+methodRefs n api methods = catMaybes $ map methodRef methods+  where methodRef :: Method -> Maybe (CRef, Hyperlink)+        methodRef Method{methodSymbol = symbol, methodName = mn} =           -- Method name namespaced by the owner.           let mn' = mn {name = name n <> "_" <> name mn}-          in (FunctionRef (methodSymbol m),-              fullyQualifiedValue n api $ lowerName mn')+          in Just (FunctionRef symbol,+                   fullyQualifiedValue n api $ lowerName mn')  -- | Refs to the signals for a given owner. signalRefs :: Name -> API -> Maybe Text -> [Signal] -> [(CRef, Hyperlink)]

@@ -104,7 +104,9 @@   line $ "-- Enum " <> name    let docSection = NamedSubsection EnumSection (upperName n)-  handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)+  handleCGExc (\e -> do+                  line $ "-- XXX Code Generation error"+                  printCGError e)               (do genEnumOrFlags docSection n enum                   case enumTypeInit enum of                     Nothing -> return ()@@ -129,7 +131,9 @@   line $ "-- Flags " <> name    let docSection = NamedSubsection FlagSection (upperName n)-  handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)+  handleCGExc (\e -> do+                  line "-- XXX Code generation error"+                  printCGError e)               (do                 genEnumOrFlags docSection n enum 

@@ -2,19 +2,22 @@ -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository     ( girRequire+    , Typelib     , setupTypelibSearchPath     , FieldInfo(..)     , girStructFieldInfo     , girUnionFieldInfo     , girLoadGType+    , girIsSymbolResolvable     ) where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad (forM, when, (>=>))+import Control.Monad (forM, (>=>)) import qualified Data.Map as M+import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T @@ -35,9 +38,16 @@ -- | Wrapper for 'GIBaseInfo' newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo) --- | Wrapper for 'GITypelib'-newtype Typelib = Typelib (Ptr Typelib)+-- | Wrapper for 'GITypelib', remembering the originating namespace+-- and version.+data Typelib = Typelib { typelibNamespace       :: Text+                       , typelibVersion         :: Text+                       , _typelibPtr            :: Ptr Typelib+                       } +instance Show Typelib where+  show t = T.unpack (typelibNamespace t) ++ "-" ++ T.unpack (typelibVersion t)+ -- | Extra info about a field in a struct or union which is not easily -- determined from the GIR file. (And which we determine by using -- libgirepository.)@@ -86,7 +96,7 @@                                            ++ show ns ++ " version "                                            ++ show version ++ ".\n"                                            ++ "Error was: " ++ show gerror)-        return (Typelib typelib)+        return (Typelib ns version typelib)  foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name ::     Ptr () -> CString -> CString -> IO (Ptr BaseInfo)@@ -155,28 +165,40 @@ foreign import ccall "g_typelib_symbol" g_typelib_symbol ::     Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt --- | Load a symbol from the dynamic library associated to the given namespace.-girSymbol :: forall a. Text -> Text -> IO (FunPtr a)-girSymbol ns symbol = do-  typelib <- withTextCString ns $ \cns ->-                    checkGError (g_irepository_require nullPtr cns nullPtr 0)-                                (error $ "Could not load typelib " ++ show ns)+-- | Try to load a symbol from the dynamic library associated to the+-- given typelib.+girLookupSymbol :: forall a. Typelib -> Text -> IO (Maybe (FunPtr a))+girLookupSymbol (Typelib _ _ typelib) symbol = do   funPtrPtr <- allocMem :: IO (Ptr (FunPtr a))   result <- withTextCString symbol $ \csymbol ->                       g_typelib_symbol typelib csymbol funPtrPtr-  when (result /= 1) $-       error ("Could not resolve symbol " ++ show symbol ++ " in namespace "-              ++ show ns)   funPtr <- peek funPtrPtr   freeMem funPtrPtr-  return funPtr+  if result /= 1+    then return Nothing+    else return (Just funPtr) +-- | Load a symbol from the dynamic library associated to the given+-- typelib. If the symbol does not exist this will raise an error.+girSymbol :: Typelib -> Text -> IO (FunPtr a)+girSymbol typelib@(Typelib ns version _) symbol = do+  maybeSymbol <- girLookupSymbol typelib symbol+  case maybeSymbol of+    Just funPtr -> return funPtr+    Nothing -> error ("Could not resolve symbol " ++ show symbol ++ " in namespace "+              ++ show (ns <> "-" <> version))+ type GTypeInit = IO CGType foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit --- | Load a GType given the namespace where it lives and the type init+-- | Load a GType given the `Typelib` where it lives and the type init -- function.-girLoadGType :: Text -> Text -> IO GType-girLoadGType ns typeInit = do-  funPtr <- girSymbol ns typeInit-  GType <$> gtypeInit funPtr+girLoadGType :: Typelib -> Text -> IO GType+girLoadGType typelib typeInit =+  GType <$> (girSymbol typelib typeInit >>= gtypeInit)++-- | Check whether a symbol is present in the dynamical liberary.+girIsSymbolResolvable :: Typelib -> Text -> IO Bool+girIsSymbolResolvable typelib symbol = do+  maybeSymbol <- girLookupSymbol typelib symbol+  return (isJust maybeSymbol)

@@ -254,15 +254,15 @@   isNullable <- typeIsNullable (propType prop)   isCallback <- typeIsCallback (propType prop)   cls <- classConstraint n-  let constraints' = (cls <> " o") : constraints+  let constraints' = (cls <> " o") : "MIO.MonadIO m" : constraints       pconstraints = parenthesize (T.intercalate ", " constraints') <> " => "   writeHaddock DocBeforeSymbol (constructorDoc prop)   line $ constructor <> " :: " <> pconstraints-           <> t <> " -> IO (GValueConstruct o)"-  line $ constructor <> " val = B.Properties.constructObjectProperty" <> tStr+           <> t <> " -> m (GValueConstruct o)"+  line $ constructor <> " val = MIO.liftIO $ B.Properties.constructObjectProperty" <> tStr            <> " \"" <> propName prop            <> if isNullable && (not isCallback)-              then "\" (Just val)"+              then "\" (P.Just val)"               else "\" val"   export docSection constructor @@ -456,7 +456,7 @@   let cName = (hyphensToCamelCase . propName) prop       docSection = NamedSubsection PropertySection (lcFirst cName)   export docSection it-  line $ "data " <> it+  bline $ "data " <> it   line $ "instance AttrInfo " <> it <> " where"   indent $ do     line $ "type AttrAllowedOps " <> it <> " = '[]"@@ -481,7 +481,8 @@       handleCGExc (\err -> do                      line $ "-- XXX Generation of property \""                               <> propName prop <> "\" of object \""-                              <> name <> "\" failed: " <> describeCGError err+                              <> name <> "\" failed."+                     printCGError err                      cppIf CPPOverloading (genPlaceholderProperty n prop))                   (genOneProperty n prop) 

@@ -333,20 +333,21 @@ genCallback :: Name -> Callback -> CodeGen () genCallback n (Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do   let name' = upperName n+      cb' = fixupCallerAllocates cb+   line $ "-- callback " <> name'-  line $ "--          -> " <> tshow (fixupCallerAllocates cb)+  line $ "{- " <> T.pack (ppShow cb') <> "\n-}"    if skipReturn cb   then group $ do     line $ "-- XXX Skipping callback " <> name'-    line $ "-- Callbacks skipping return unsupported :\n"-             <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb)+    line $ "{- Callbacks skipping return unsupported :\n"+             <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb') <> "-}"   else do-    let cb' = fixupCallerAllocates cb--    handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "-                             <> name' <>-                             "\n-- Error was : " <> describeCGError e)) $ do+    handleCGExc (\e -> do+                   line $ "-- XXX Could not generate callback wrapper for "+                          <> name'+                   printCGError e) $ do       typeSynonym <- genCCallbackPrototype name' cb' name' False       dynamic <- genDynamicCallableWrapper n typeSynonym cb       export (NamedSubsection SignalSection name') dynamic@@ -405,7 +406,8 @@       sn = (ucFirst . signalHaskellName . sigName) signal   line $ T.concat ["-- XXX Could not generate signal "                   , qualifiedSignalName-                  , "\n", "-- Error was : ", describeCGError err]+                  , "\n", "-- Error was : "]+  printCGError err    -- Generate a placeholder SignalInfo instance that raises a type   -- error when one attempts to use it.

@@ -424,10 +424,11 @@   let name' = upperName n    attrs <- forM fields $ \field ->-      handleCGExc (\e -> line ("-- XXX Skipped attribute for \"" <> name' <>-                               ":" <> fieldName field <> "\" :: " <>-                               describeCGError e) >>-                   return Nothing)+      handleCGExc (\e -> do+                      line ("-- XXX Skipped attribute for \"" <> name' <>+                             ":" <> fieldName field <> "\"")+                      printCGError e+                      return Nothing)                   (buildFieldAttributes n field)    blank

@@ -17,8 +17,12 @@   , utf8WriteFile    , splitOn++  , printWarning   ) where +import GHC.Stack (HasCallStack)+ #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>)) #endif@@ -28,7 +32,11 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as TIO +import qualified System.Console.ANSI as A+import System.IO (stderr, hFlush)+ padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " " @@ -45,10 +53,6 @@ tshow :: Show a => a -> Text tshow = T.pack . show --- | Throw an error with the given `Text`.-terror :: Text -> a-terror = error . T.unpack- -- | Capitalize the first character of the given string. ucFirst :: Text -> Text ucFirst "" = ""@@ -91,3 +95,32 @@ -- | Write the given `Text` into an UTF-8 encoded file. utf8WriteFile :: FilePath -> T.Text -> IO () utf8WriteFile fname text = B.writeFile fname (TE.encodeUtf8 text)++-- | Print a (colored) warning message to stderr+printWarning :: Text -> IO ()+printWarning warning = do+  inColour <- A.hSupportsANSIColor stderr+  if not inColour+    then TIO.hPutStrLn stderr warning+    else do+      A.hSetSGR stderr [A.SetConsoleIntensity A.BoldIntensity,+                        A.SetColor A.Foreground A.Vivid A.Yellow]+      TIO.hPutStr stderr "Warning: "+      A.hSetSGR stderr [A.SetColor A.Foreground A.Vivid A.White]+      TIO.hPutStrLn stderr warning+      A.hSetSGR stderr [A.Reset]+      hFlush stderr++-- | Throw an error with the given `Text`.+terror :: HasCallStack => Text -> a+terror errMsg =+  let fmt = A.setSGRCode [A.SetConsoleIntensity A.BoldIntensity,+                          A.SetColor A.Foreground A.Vivid A.Red]+            ++ "ERROR: "+            ++ A.setSGRCode [A.SetColor A.Foreground A.Vivid A.White]+            ++ T.unpack errMsg+            ++ A.setSGRCode [A.SetConsoleIntensity A.NormalIntensity,+                             A.SetColor A.Foreground A.Vivid A.Blue]+            ++ "\nPlease report this at https://github.com/haskell-gi/haskell-gi/issues"+            ++ A.setSGRCode [A.Reset]+  in error fmt

@@ -17,7 +17,12 @@         skipReturn :: Bool,         callableThrows :: Bool,         callableDeprecated :: Maybe DeprecationInfo,-        callableDocumentation :: Documentation+        callableDocumentation :: Documentation,+        -- | Whether the symbol for this callable can be resolved in+        -- the dynamical library associated with the current+        -- introspection data. 'Nothing' means that we have not+        -- checked yet.+        callableResolvable :: Maybe Bool     } deriving (Show, Eq)  parseArgs :: Parser [Arg]@@ -64,4 +69,12 @@                 , callableThrows = throws                 , callableDeprecated = deprecated                 , callableDocumentation = docs+                  -- Some symbols are present in the @.gir@ file, but+                  -- they are absent from the library+                  -- itself. Generating bindings for such symbols+                  -- could then lead to linker errors, so later on we+                  -- check whether the callables are actually+                  -- resolvable, and adjust the callable info+                  -- appropriately.+                , callableResolvable = Nothing                 }

@@ -9,6 +9,7 @@ import Data.GI.GIR.Parser  data Function = Function {+  -- | The symbol in the dynlib that this function refers to.       fnSymbol   :: Text     , fnMovedTo  :: Maybe Text     , fnCallable :: Callable

@@ -18,6 +18,7 @@  data Method = Method {       methodName        :: Name,+      -- | The symbol in the dynlib that this method refers to.       methodSymbol      :: Text,       methodType        :: MethodType,       methodMovedTo     :: Maybe Text,

@@ -1,6 +1,7 @@ -- | The Parser monad. module Data.GI.GIR.Parser     ( Parser+    , ParseContext(..)     , ParseError     , parseError