haskell-gi 0.23.1 → 0.24.0

raw patch · 23 files changed

+1455/−1324 lines, 23 filesdep ~attoparsecdep ~haskell-gi-basebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: attoparsec, haskell-gi-base

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• DocTests.hs +10/−13
• Setup.hs +6/−3
• haskell-gi.cabal +12/−7
• lib/Data/GI/CodeGen/Callable.hs +36/−29
• lib/Data/GI/CodeGen/Code.hs +7/−4
• lib/Data/GI/CodeGen/CodeGen.hs +126/−147
• lib/Data/GI/CodeGen/Conversions.hs +0/−1059
• lib/Data/GI/CodeGen/Conversions.hsc +1077/−0
• lib/Data/GI/CodeGen/CtoHaskellMap.hs +1/−1
• lib/Data/GI/CodeGen/EnumFlags.hs +18/−4
• lib/Data/GI/CodeGen/Fixups.hs +26/−0
• lib/Data/GI/CodeGen/GObject.hs +2/−0
• lib/Data/GI/CodeGen/Haddock.hs +1/−1
• lib/Data/GI/CodeGen/LibGIRepository.hs +14/−3
• lib/Data/GI/CodeGen/Properties.hs +1/−0
• lib/Data/GI/CodeGen/Signal.hs +2/−2
• lib/Data/GI/CodeGen/Struct.hs +79/−33
• lib/Data/GI/CodeGen/SymbolNaming.hs +19/−18
• lib/Data/GI/CodeGen/Transfer.hs +5/−0
• lib/Data/GI/GIR/BasicTypes.hs +1/−0
• lib/Data/GI/GIR/Object.hs +7/−0
• lib/Data/GI/GIR/Type.hs +1/−0

@@ -1,3 +1,7 @@+### 0.23.2+++ Fix a possible segfault in functions that return an out pointer to a dynamically allocated array, but do not initialize the array if it has zero size. See [#289](https://github.com/haskell-gi/haskell-gi/issues/289) for an example.+ ### 0.23.1  + Check whether symbols exist in the dynamic library before trying to generate bindings for them, in order to avoid linker errors.

@@ -1,20 +1,17 @@-import Test.DocTest+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Test.DocTest (doctest) import System.Process  main :: IO () main = do-  gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0"-  doctest $ [ "-XCPP", "-XOverloadedStrings", "-XRankNTypes", "-XLambdaCase"-            , "-ilib"-            -- For the autogenerated Data.GI.CodeGen.GType (hsc)-            , "-idist/build"-            , "dist/build/lib/c/enumStorage.o"-            ] ++ gobjectIntrospectionLibs ++-            -- The actual modules to test-            [ "Data.GI.CodeGen.GtkDoc"-            , "Data.GI.CodeGen.ModulePath"-            , "Data.GI.CodeGen.SymbolNaming"-            , "Data.GI.CodeGen.Haddock" ]+    gobjectIntrospectionLibs <- pkgConfigLibs "gobject-introspection-1.0"+--    traverse_ putStrLn args -- optionally print arguments+    doctest (gobjectIntrospectionLibs ++ args)+  where+    args = flags ++ pkgs ++ module_sources  pkgConfigLibs :: String -> IO [String] pkgConfigLibs pkg = words <$> readProcess "pkg-config" ["--libs", pkg] ""

@@ -1,3 +1,6 @@-#!/usr/bin/env runhaskell-import Distribution.Simple-main = defaultMain+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctests"

@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.23.1+version:             0.24.0 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.@@ -13,12 +13,18 @@ maintainer:          Iñaki García Etxebarria (inaki@blueleaf.cc) 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, GHC == 8.10.1+build-type:          Custom+tested-with:         GHC == 8.8.1, GHC == 8.10.1 cabal-version:       2.0  extra-source-files: ChangeLog.md +custom-setup+ setup-depends:+   base >= 4 && <5,+   Cabal,+   cabal-doctest >= 1 && <1.1+ source-repository head   type: git   location: git://github.com/haskell-gi/haskell-gi.git@@ -27,7 +33,7 @@   default-language:    Haskell2010   pkgconfig-depends:   gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32   build-depends:       base >= 4.9 && < 5,-                       haskell-gi-base >= 0.23.0 && <0.24,+                       haskell-gi-base >= 0.24.0 && <0.25,                        Cabal >= 1.24,                        attoparsec >= 0.13,                        containers,@@ -51,8 +57,8 @@   ghc-options: -Wcompat    c-sources:           lib/c/enumStorage.c+  build-tool-depends:  hsc2hs:hsc2hs -  build-tools:         hsc2hs   hs-source-dirs:      lib   exposed-modules:     Data.GI.GIR.Alias,                        Data.GI.GIR.Allocation,@@ -118,10 +124,9 @@ test-suite doctests   type:          exitcode-stdio-1.0   default-language: Haskell2010-  ghc-options:   -threaded+  ghc-options:   -threaded -Wall   main-is:       DocTests.hs   build-depends: base                , process                , doctest >= 0.8                , haskell-gi-               , attoparsec

@@ -311,15 +311,16 @@  -- | Callbacks are a fairly special case, we treat them separately. prepareInCallback :: Arg -> Callback -> ExposeClosures -> CodeGen Text-prepareInCallback arg (Callback {cbCallable = cb}) expose = do+prepareInCallback arg callback@(Callback {cbCallable = cb}) expose = do   let name = escapedArgName arg       ptrName = "ptr" <> name       scope = argScope arg    (maker, wrapper, drop) <-       case argType arg of-        TInterface tn@(Name _ n) ->+        TInterface tn ->             do+              let Name _ n = normalizedAPIName (APICallback callback) tn               drop <- if callableHasClosures cb && expose == WithoutClosures                       then Just <$> qualifiedSymbol (callbackDropClosures n) tn                       else return Nothing@@ -388,14 +389,11 @@   ft <- foreignType $ argType arg   allocInfo <- typeAllocInfo (argType arg)   case allocInfo of-    Just (TypeAllocInfo isBoxed n) -> do-         let allocator = if isBoxed-                         then "callocBoxedBytes"-                         else "callocBytes"+    Just (TypeAlloc allocator n) -> do          wrapMaybe arg >>= bool             (do               name'' <- genConversion (prime name') $-                        literal $ M $ allocator <> " " <> tshow n <>+                        literal $ M $ allocator <>                                     " :: " <> typeShow (io ft)               line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n               return name'')@@ -418,17 +416,21 @@   then do     allocInfo <- typeAllocInfo (argType arg)     case allocInfo of-      Just (TypeAllocInfo isBoxed n) -> do-          let allocator = if isBoxed-                          then "callocBoxedBytes"-                          else "callocBytes"-          genConversion name $ literal $ M $ allocator <> " " <> tshow n <>+      Just (TypeAlloc allocator _) -> do+          genConversion name $ literal $ M $ allocator <>                             " :: " <> typeShow (io ft)       Nothing ->           notImplementedError $ ("Don't know how to allocate \""                                  <> argCName arg <> "\" of type "                                  <> tshow (argType arg))-  else genConversion name $ literal $ M $ "allocMem :: " <> typeShow (io $ ptr ft)+  else do+    -- Initialize pointers to NULL to avoid a crash in case the function+    -- does not initialize it.+    isPtr <- typeIsPtr (argType arg)+    let alloc = if isPtr+                then "callocMem"+                else "allocMem"+    genConversion name $ literal $ M $ alloc <> " :: " <> typeShow (io $ ptr ft)  -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object.@@ -439,7 +441,7 @@   if fixed > -1   then do     unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer-    -- Free the memory associated with the array+    -- Free the memory associated with the array.     freeContainerType transfer t aname undefined     return unpacked   else do@@ -453,7 +455,7 @@                                             lname     let lname'' = primeLength lname'     unpacked <- convert aname $ unpackCArray lname'' t transfer-    -- Free the memory associated with the array+    -- Free the memory associated with the array.     freeContainerType transfer t aname lname''     return unpacked @@ -538,21 +540,26 @@                   Nothing -> badIntroError $ "Cannot find closure name!! "                                            <> T.pack (ppShow callable) <> "\n"                                            <> T.pack (ppShow nameMap)-          case argScope cb of-            ScopeTypeInvalid -> badIntroError $ "Invalid scope! "+          -- Check that the given closure is an actual callback type.+          maybeAPI <- findAPI (argType cb)+          case maybeAPI of+            Just (APICallback _) -> do+              case argScope cb of+                ScopeTypeInvalid -> badIntroError $ "Invalid scope! "                                               <> T.pack (ppShow callable)-            ScopeTypeNotified -> do-                line $ "let " <> closureName <> " = castFunPtrToPtr " <> n'-                case argDestroy cb of-                  (-1) -> badIntroError $-                          "ScopeTypeNotified without destructor! "-                           <> T.pack (ppShow callable)-                  k -> let destroyName =-                            escapedArgName $ (args callable)!!k in-                       line $ "let " <> destroyName <> " = safeFreeFunPtrPtr"-            ScopeTypeAsync ->-                line $ "let " <> closureName <> " = nullPtr"-            ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr"+                ScopeTypeNotified -> do+                  line $ "let " <> closureName <> " = castFunPtrToPtr " <> n'+                  case argDestroy cb of+                    (-1) -> badIntroError $+                            "ScopeTypeNotified without destructor! "+                            <> T.pack (ppShow callable)+                    k -> let destroyName =+                               escapedArgName $ (args callable)!!k in+                           line $ "let " <> destroyName <> " = safeFreeFunPtrPtr"+                ScopeTypeAsync ->+                  line $ "let " <> closureName <> " = nullPtr"+                ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr"+            _ -> badIntroError $ "Closure \"" <> n <> "\" is not a callback."  freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen () freeCallCallbacks callable nameMap =

@@ -89,6 +89,8 @@ import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy as LT +import GHC.Stack (HasCallStack)+ import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory) @@ -537,19 +539,19 @@ resetTypeVariableScope =   modify' (\(cgs, s) -> (cgs {cgsNextAvailableTyvar = SingleCharTyvar 'a'}, s)) -findAPI :: Type -> CodeGen (Maybe API)-findAPI TError = Just <$> findAPIByName (Name "GLib" "Error")+-- | Try to find the API associated with a given type, if known.+findAPI :: HasCallStack => Type -> CodeGen (Maybe API) findAPI (TInterface n) = Just <$> findAPIByName n findAPI _ = return Nothing  -- | Find the API associated with a given type. If the API cannot be -- found this raises an `error`.-getAPI :: Type -> CodeGen API+getAPI :: HasCallStack => Type -> CodeGen API getAPI t = findAPI t >>= \case            Just a -> return a            Nothing -> terror ("Could not resolve type \"" <> tshow t <> "\".") -findAPIByName :: Name -> CodeGen API+findAPIByName :: HasCallStack => Name -> CodeGen API findAPIByName n@(Name ns _) = do     apis <- getAPIs     case M.lookup n apis of@@ -922,6 +924,7 @@                 , "import qualified Prelude as P"                 , ""                 , "import qualified Data.GI.Base.Attributes as GI.Attributes"+                , "import qualified Data.GI.Base.BasicTypes as B.Types"                 , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr"                 , "import qualified Data.GI.Base.GClosure as B.GClosure"                 , "import qualified Data.GI.Base.GError as B.GError"

@@ -21,7 +21,7 @@ import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability,                                detectGObject, dropDuplicatedFields,-                               checkClosureDestructors)+                               checkClosureDestructors, fixSymbolNaming) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Haddock (deprecatedPragma, addSectionDocumentation,                                 writeHaddock,@@ -36,16 +36,13 @@ import Data.GI.CodeGen.Signal (genSignal, genCallback) import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct,                   fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion,-                  genWrappedPtr)-import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName,-                                     submoduleLocation, lowerName, qualifiedAPI)+                  genBoxed, genWrappedPtr)+import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint,+                                     submoduleLocation, lowerName, qualifiedAPI,+                                     normalizedAPIName) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) --- | Standard derived instances for newtypes wrapping @ManagedPtr@s.-newtypeDeriving :: CodeGen ()-newtypeDeriving = indent $ line $ "deriving (Eq)"- genFunction :: Name -> Function -> CodeGen () genFunction n (Function symbol fnMovedTo callable) =     -- Only generate the function if it has not been moved.@@ -62,67 +59,35 @@                           export (NamedSubsection MethodSection $ lowerName n) (lowerName n)                         ) --- | Generate the GValue instances for the given GObject.-genBoxedGValueInstance :: Name -> Text -> CodeGen ()-genBoxedGValueInstance n get_type_fn = do-  let name' = upperName n-      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'."--  writeHaddock DocBeforeSymbol doc-+-- | Create the newtype wrapping the ManagedPtr for the given type.+genNewtype :: Text -> CodeGen ()+genNewtype name' = do   group $ do-    bline $ "instance B.GValue.IsGValue " <> name' <> " where"-    indent $ group $ do-      line $ "toGValue o = do"-      indent $ group $ do-        line $ "gtype <- " <> get_type_fn-        line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)"-      line $ "fromGValue gv = do"-      indent $ group $ do-        line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")"-        line $ "B.ManagedPtr.newBoxed " <> name' <> " ptr"--genBoxedObject :: Name -> Text -> CodeGen ()-genBoxedObject n typeInit = do-  let name' = upperName n-      get_type_fn = "c_" <> typeInit+    bline $ "newtype " <> name' <> " = " <> name' <> " (SP.ManagedPtr " <> name' <> ")"+    indent $ line $ "deriving (Eq)"    group $ do-    line $ "foreign import ccall \"" <> typeInit <> "\" " <>-            get_type_fn <> " :: "-    indent $ line "IO GType"-  group $ do-       line $ "instance BoxedObject " <> name' <> " where"-       indent $ line $ "boxedType _ = " <> get_type_fn--  genBoxedGValueInstance n get_type_fn--  hsBoot $ line $ "instance BoxedObject " <> name' <> " where"+    bline $ "instance SP.ManagedPtrNewtype " <> name' <> " where"+    indent $ line $ "toManagedPtr (" <> name' <> " p) = p"  -- | Generate wrapper for structures. genStruct :: Name -> Struct -> CodeGen () genStruct n s = unless (ignoreStruct n s) $ do-   let name' = upperName n+   let Name _ name' = normalizedAPIName (APIStruct s) n     writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")-   let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"-   hsBoot decl-   decl-   newtypeDeriving+   genNewtype name'+   exportDecl (name' <> ("(..)"))     addSectionDocumentation ToplevelSection (structDocumentation s)     if structIsBoxed s-   then genBoxedObject n (fromJust $ structTypeInit s)+   then genBoxed n (fromJust $ structTypeInit s)    else genWrappedPtr n (structAllocationInfo s) (structSize s) -   exportDecl (name' <> ("(..)"))-    -- Generate a builder for a structure filled with zeroes.    genZeroStruct n s -   noName name'-    -- Generate code for fields.    genStructOrUnionFields n (structFields s) @@ -146,27 +111,21 @@ -- | Generated wrapper for unions. genUnion :: Name -> Union -> CodeGen () genUnion n u = do-  let name' = upperName n+  let Name _ name' = normalizedAPIName (APIUnion u) n    writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")-  let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"-  hsBoot decl-  decl-  newtypeDeriving+  genNewtype name'+  exportDecl (name' <> "(..)")    addSectionDocumentation ToplevelSection (unionDocumentation u)    if unionIsBoxed u-  then genBoxedObject n (fromJust $ unionTypeInit u)+  then genBoxed n (fromJust $ unionTypeInit u)   else genWrappedPtr n (unionAllocationInfo u) (unionSize u) -  exportDecl (name' <> "(..)")-   -- Generate a builder for a structure filled with zeroes.   genZeroUnion n u -  noName name'-   -- Generate code for fields.   genStructOrUnionFields n (unionFields u) @@ -285,22 +244,26 @@         line $ "B.ManagedPtr.newObject " <> name' <> " ptr"  -- Type casting with type checking-genGObjectCasts :: Name -> Text -> [Name] -> CodeGen ()-genGObjectCasts n cn_ parents = do+genCasts :: Name -> Text -> [Name] -> CodeGen ()+genCasts n cn_ parents = do+  isGO <- isGObject (TInterface n)   let name' = upperName n       get_type_fn = "c_" <> cn_    group $ do     line $ "foreign import ccall \"" <> cn_ <> "\""-    indent $ line $ get_type_fn <> " :: IO GType"+    indent $ line $ get_type_fn <> " :: IO B.Types.GType"    group $ do-    bline $ "instance GObject " <> name' <> " where"-    indent $ group $ do-            line $ "gobjectType = " <> get_type_fn+    bline $ "instance B.Types.TypedObject " <> name' <> " where"+    indent $ do+      line $ "glibType = " <> get_type_fn -  genGObjectGValueInstance n get_type_fn+  when isGO $ group $ do+      bline $ "instance B.Types.GObject " <> name' +  when isGO $ genGObjectGValueInstance n get_type_fn+   className <- classConstraint n   group $ do     exportDecl className@@ -313,13 +276,16 @@     -- since we sometimes need to refer to @IsX@ itself, without     -- applying it. We instead use the trick of creating a class with     -- a universal instance.-    let constraints = "(GObject o, O.IsDescendantOf " <> name' <> " o)"+    let constraints = if isGO+                      then "(SP.GObject o, O.IsDescendantOf " <> name' <> " o)"+                      else "(SP.BoxedPtr o, SP.TypedObject o, O.IsDescendantOf " <> name' <> " o)"     bline $ "class " <> constraints <> " => " <> className <> " o"     bline $ "instance " <> constraints <> " => " <> className <> " o"      blank -    qualifiedParents <- mapM qualifiedAPI parents+    parentAPIs <- mapM (\n -> getAPI (TInterface n)) parents+    qualifiedParents <- mapM (uncurry qualifiedAPI) (zip parentAPIs parents)     bline $ "instance O.HasParentTypes " <> name'     line $ "type instance O.ParentTypes " <> name' <> " = '["       <> T.intercalate ", " qualifiedParents <> "]"@@ -346,72 +312,66 @@ -- of objects, we deal with these separately. genObject :: Name -> Object -> CodeGen () genObject n o = do-  let name' = upperName n+  let Name _ name' = normalizedAPIName (APIObject o) n   let t = TInterface n   isGO <- isGObject t -  if not isGO-  then line $ "-- APIObject \"" <> name' <>-                "\" does not descend from GObject, it will be ignored."-  else do-    writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")-    bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"-    newtypeDeriving-    exportDecl (name' <> "(..)")--    addSectionDocumentation ToplevelSection (objDocumentation o)+  writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")+  genNewtype name'+  exportDecl (name' <> "(..)") -    -- Type safe casting to parent objects, and implemented interfaces.-    parents <- instanceTree n-    genGObjectCasts n (objTypeInit o) (parents <> objInterfaces o)+  addSectionDocumentation ToplevelSection (objDocumentation o) -    noName name'+  -- Type safe casting to parent objects, and implemented interfaces.+  parents <- instanceTree n+  genCasts n (objTypeInit o) (parents <> objInterfaces o) -    cppIf CPPOverloading $-         fullObjectMethodList n o >>= genMethodList n+  cppIf CPPOverloading $+       fullObjectMethodList n o >>= genMethodList n -    forM_ (objSignals o) $ \s -> genSignal s n+  if isGO+    then do+      forM_ (objSignals o) $ \s -> genSignal s n -    genObjectProperties n o-    cppIf CPPOverloading $-         genNamespacedPropLabels n (objProperties o) (objMethods o)-    cppIf CPPOverloading $-         genObjectSignals n o+      genObjectProperties n o+      cppIf CPPOverloading $+        genNamespacedPropLabels n (objProperties o) (objMethods o)+      cppIf CPPOverloading $+        genObjectSignals n o+    else group $ do+      let allocInfo = AllocationInfo {+            allocCalloc = AllocationOpUnknown,+            allocCopy = case objRefFunc o of+                          Just ref -> AllocationOp ref+                          Nothing -> AllocationOpUnknown,+            allocFree = case objUnrefFunc o of+                          Just unref -> AllocationOp unref+                          Nothing -> AllocationOpUnknown+            }+      genWrappedPtr n allocInfo 0 -    -- Methods-    forM_ (objMethods o) $ \f -> do-      let mn = methodName f-      handleCGExc (\e -> do line ("-- XXX Could not generate method "-                                  <> name' <> "::" <> name mn)-                            printCGError e-                            cppIf CPPOverloading $-                              genUnsupportedMethodInfo n f)-                  (genMethod n f)+  -- Methods+  forM_ (objMethods o) $ \f -> do+    let mn = methodName 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 () genInterface n iface = do-  let name' = upperName n+  let Name _ name' = normalizedAPIName (APIInterface iface) n    line $ "-- interface " <> name' <> " "   writeHaddock DocBeforeSymbol ("Memory-managed wrapper type.")   deprecatedPragma name' $ ifDeprecated iface-  bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")"-  newtypeDeriving+  genNewtype name'   exportDecl (name' <> "(..)")    addSectionDocumentation ToplevelSection (ifDocumentation iface) -  noName name'--  forM_ (ifSignals iface) $ \s -> handleCGExc-     (\e -> do line $ T.concat ["-- XXX Could not generate signal ", name', "::"-                               , sigName s]-               printCGError e)-     (genSignal s n)--  cppIf CPPOverloading $-     genInterfaceSignals n iface-   isGO <- apiIsGObject n (APIInterface iface)   if isGO   then do@@ -419,7 +379,7 @@     gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)     allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p     let uniqueParents = nub (concat allParents)-    genGObjectCasts n cn_ uniqueParents+    genCasts n cn_ uniqueParents      genInterfaceProperties n iface     cppIf CPPOverloading $@@ -462,6 +422,16 @@                        cppIf CPPOverloading (genUnsupportedMethodInfo n f))              (genMethod n f) +  -- Signals+  forM_ (ifSignals iface) $ \s -> handleCGExc+     (\e -> do line $ T.concat ["-- XXX Could not generate signal ", name', "::"+                               , sigName s]+               printCGError e)+     (genSignal s n)++  cppIf CPPOverloading $+     genInterfaceSignals n iface+ -- Some type libraries include spurious interface/struct methods, -- where a method Mod.Foo::func also appears as an ordinary function -- in the list of APIs. If we find a matching function (without the@@ -496,33 +466,22 @@ genModule' :: M.Map Name API -> CodeGen () genModule' apis = do   mapM_ (uncurry genAPIModule)-            -- We provide these ourselves-          $ filter ((`notElem` [ Name "GLib" "Array"-                               , Name "GLib" "Error"-                               , Name "GLib" "HashTable"-                               , Name "GLib" "List"-                               , Name "GLib" "SList"-                               , Name "GLib" "Variant"-                               , Name "GObject" "Value"-                               , Name "GObject" "Closure"]) . fst)-          $ mapMaybe (traverse dropMovedItems)-            -- Some callback types are defined inside structs-          $ map fixAPIStructs-            -- 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-            -- Some APIs contain duplicated fields by mistake, drop-            -- the duplicates.-          $ map dropDuplicatedFields-            -- Make sure that every argument marked as being a-            -- destructor for a user_data argument has an associated-            -- user_data argument.-          $ map checkClosureDestructors-          $ M.toList-          $ apis+    -- We provide these ourselves+    $ filter ((`notElem` [ Name "GLib" "Array"+                         , Name "GLib" "Error"+                         , Name "GLib" "HashTable"+                         , Name "GLib" "List"+                         , Name "GLib" "SList"+                         , Name "GLib" "Variant"+                         , Name "GObject" "Value"+                         , Name "GObject" "Closure"]) . fst)+    -- Some callback types are defined inside structs+    $ map fixAPIStructs+    -- Some APIs contain duplicated fields by mistake, drop+    -- the duplicates.+    $ map dropDuplicatedFields+    $ mapMaybe (traverse dropMovedItems)+    $ M.toList apis    -- Make sure we generate a "Callbacks" module, since it is imported   -- by other modules. It is fine if it ends up empty.@@ -537,9 +496,29 @@    -- Some API symbols are embedded into structures, extract these and   -- inject them into the set of APIs loaded and being generated.-  let embeddedAPIs = (M.fromList+  let embeddedAPIs = (fixAPIs . M.fromList                      . concatMap extractCallbacksInStruct                      . M.toList) apis   allAPIs <- getAPIs-  recurseWithAPIs (M.union allAPIs embeddedAPIs)-       (genModule' (M.union apis embeddedAPIs))+  let contextAPIs = M.union (fixAPIs allAPIs) embeddedAPIs+      targetAPIs = M.union (fixAPIs apis) embeddedAPIs++  recurseWithAPIs contextAPIs (genModule' targetAPIs)++  where+    fixAPIs :: M.Map Name API -> M.Map Name API+    fixAPIs apis = M.fromList+      -- 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+      -- Make sure that every argument marked as being a+      -- destructor for a user_data argument has an associated+      -- user_data argument.+      $ map checkClosureDestructors+      -- Make sure that the symbols to be generated are valid+      -- Haskell identifiers, when necessary.+      $ map fixSymbolNaming+      $ M.toList apis

@@ -1,1059 +0,0 @@-{-# LANGUAGE PatternGuards, DeriveFunctor #-}--module Data.GI.CodeGen.Conversions-    ( convert-    , genConversion-    , unpackCArray-    , computeArrayLength--    , callableHasClosures--    , hToF-    , fToH-    , transientToH-    , haskellType-    , isoHaskellType-    , foreignType--    , argumentType-    , ExposeClosures(..)-    , elementType-    , elementMap-    , elementTypeAndMap--    , isManaged-    , typeIsNullable-    , typeIsPtr-    , typeIsCallback-    , maybeNullConvert-    , nullPtrForType--    , typeAllocInfo-    , TypeAllocInfo(..)--    , apply-    , mapC-    , literal-    , Constructor(..)-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>), pure, Applicative)-#endif-import Control.Monad (when)-import Data.Maybe (isJust)-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Exts (IsString(..))--import Foreign.C.Types (CInt, CUInt)-import Foreign.Storable (sizeOf)--import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code-import Data.GI.CodeGen.GObject-import Data.GI.CodeGen.SymbolNaming-import Data.GI.CodeGen.Type-import Data.GI.CodeGen.Util---- | The free monad.-data Free f r = Free (f (Free f r)) | Pure r--instance Functor f => Functor (Free f) where-  fmap f = go where-    go (Pure a)  = Pure (f a)-    go (Free fa) = Free (go <$> fa)--instance (Functor f) => Applicative (Free f) where-    pure = Pure-    Pure a <*> Pure b = Pure $ a b-    Pure a <*> Free mb = Free $ fmap a <$> mb-    Free ma <*> b = Free $ (<*> b) <$> ma--instance (Functor f) => Monad (Free f) where-    return = Pure-    (Free x) >>= f = Free (fmap (>>= f) x)-    (Pure r) >>= f = f r---- | Lift some command to the Free monad.-liftF :: (Functor f) => f r -> Free f r-liftF command = Free (fmap Pure command)---- String identifying a constructor in the generated code, which is--- either (by default) a pure function (indicated by the P--- constructor) or a function returning values on a monad (M--- constructor). 'Id' denotes the identity function.-data Constructor = P Text | M Text | Id-                   deriving (Eq,Show)-instance IsString Constructor where-    fromString = P . T.pack--data FExpr next = Apply Constructor next-                | LambdaConvert Text next-                | MapC Map Constructor next-                | Literal Constructor next-                  deriving (Show, Functor)--type Converter = Free FExpr ()---- Different available maps.-data Map = Map | MapFirst | MapSecond-         deriving (Show)---- Naming for the maps.-mapName :: Map -> Text-mapName Map = "map"-mapName MapFirst = "mapFirst"-mapName MapSecond = "mapSecond"---- Naming for the monadic versions of the maps that we use-monadicMapName :: Map -> Text-monadicMapName Map = "mapM"-monadicMapName MapFirst = "mapFirstA"-monadicMapName MapSecond = "mapSecondA"--apply :: Constructor -> Converter-apply f = liftF $ Apply f ()--mapC :: Constructor -> Converter-mapC f = liftF $ MapC Map f ()--mapFirst :: Constructor -> Converter-mapFirst f = liftF $ MapC MapFirst f ()--mapSecond :: Constructor -> Converter-mapSecond f = liftF $ MapC MapSecond f ()--literal :: Constructor -> Converter-literal f = liftF $ Literal f ()--lambdaConvert :: Text -> Converter-lambdaConvert c = liftF $ LambdaConvert c ()--genConversion :: Text -> Converter -> CodeGen Text-genConversion l (Pure ()) = return l-genConversion l (Free k) = do-  let l' = prime l-  case k of-    Apply (P f) next ->-        do line $ "let " <> l' <> " = " <> f <> " " <> l-           genConversion l' next-    Apply (M f) next ->-        do line $ l' <> " <- " <> f <> " " <> l-           genConversion l' next-    Apply Id next -> genConversion l next--    MapC m (P f) next ->-        do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l-           genConversion l' next-    MapC m (M f) next ->-        do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l-           genConversion l' next-    MapC _ Id next -> genConversion l next--    LambdaConvert conv next ->-        do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do"-           increaseIndent-           genConversion l' next--    Literal (P f) next ->-        do line $ "let " <> l <> " = " <> f-           genConversion l next-    Literal (M f) next ->-        do line $ l <> " <- " <> f-           genConversion l next-    Literal Id next -> genConversion l next---- | Given an array, together with its type, return the code for reading--- its length.-computeArrayLength :: Text -> Type -> ExcCodeGen Text-computeArrayLength array (TCArray _ _ _ t) = do-  reader <- findReader-  return $ "fromIntegral $ " <> reader <> " " <> array-    where findReader = case t of-                     TBasicType TUInt8 -> return "B.length"-                     TBasicType _      -> return "length"-                     TInterface _      -> return "length"-                     TCArray{}         -> return "length"-                     _ -> notImplementedError $-                          "Don't know how to compute length of " <> tshow t-computeArrayLength _ t =-    notImplementedError $ "computeArrayLength called on non-CArray type "-                            <> tshow t--convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text-convert l c = do-  c' <- c-  genConversion l c'--hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor-hObjectToF t transfer =-  if transfer == TransferEverything-  then do-    isGO <- isGObject t-    if isGO-    then return $ M "B.ManagedPtr.disownObject"-    else badIntroError "Transferring a non-GObject object"-  -- castPtr since we accept any instance of the class associated with-  -- the GObject, not just the precise type of the GObject, while the-  -- foreign function declaration requires a pointer of the precise-  -- type.-  else return $ M "unsafeManagedPtrCastPtr"--hVariantToF :: Transfer -> CodeGen Constructor-hVariantToF transfer =-  if transfer == TransferEverything-  then return $ M "B.GVariant.disownGVariant"-  else return $ M "unsafeManagedPtrGetPtr"--hParamSpecToF :: Transfer -> CodeGen Constructor-hParamSpecToF transfer =-  if transfer == TransferEverything-  then return $ M "B.GParamSpec.disownGParamSpec"-  else return $ M "unsafeManagedPtrGetPtr"--hClosureToF :: Transfer -> Maybe Type -> CodeGen Constructor--- Untyped closures-hClosureToF transfer Nothing =-  if transfer == TransferEverything-  then return $ M "B.GClosure.disownGClosure"-  -- We cast the point here because the foreign type for untyped-  -- closures is always represented as Ptr (GClosure ()), while the-  -- corresponding Haskell type is the parametric "GClosure a".-  else return $ M "unsafeManagedPtrCastPtr"--- Typed closures-hClosureToF transfer (Just _) =-  if transfer == TransferEverything-  then return $ M "B.GClosure.disownGClosure"-  else return $ M "unsafeManagedPtrGetPtr"--hBoxedToF :: Transfer -> CodeGen Constructor-hBoxedToF transfer =-  if transfer == TransferEverything-  then return $ M "B.ManagedPtr.disownBoxed"-  else return $ M "unsafeManagedPtrGetPtr"--hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor-hStructToF s transfer =-    if transfer /= TransferEverything || structIsBoxed s then-        hBoxedToF transfer-    else do-        when (structSize s == 0) $-             badIntroError "Transferring a non-boxed struct with unknown size!"-        return $ M "unsafeManagedPtrGetPtr"--hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor-hUnionToF u transfer =-    if transfer /= TransferEverything || unionIsBoxed u then-        hBoxedToF transfer-    else do-        when (unionSize u == 0) $-             badIntroError "Transferring a non-boxed union with unknown size!"-        return $ M "unsafeManagedPtrGetPtr"---- Given the Haskell and Foreign types, returns the name of the--- function marshalling between both.-hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer-            -> ExcCodeGen Constructor-hToF' t a hType fType transfer-    | ( hType == fType ) = return Id-    | TError <- t = hBoxedToF transfer-    | TVariant <- t = hVariantToF transfer-    | TParamSpec <- t = hParamSpecToF transfer-    | TGClosure c <- t = hClosureToF transfer c-    | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"-    | Just (APIFlags _) <- a = return "gflagsToWord"-    | Just (APIObject _) <- a = hObjectToF t transfer-    | Just (APIInterface _) <- a = hObjectToF t transfer-    | Just (APIStruct s) <- a = hStructToF s transfer-    | Just (APIUnion u) <- a = hUnionToF u transfer-    -- Converting callback types requires more context, we leave that-    -- as a special case to be implemented by the caller.-    | Just (APICallback _) <- a = error "Cannot handle callback type here!! "-    | TByteArray <- t = return $ M "packGByteArray"-    | TCArray True _ _ (TBasicType TUTF8) <- t =-        return $ M "packZeroTerminatedUTF8CArray"-    | TCArray True _ _ (TBasicType TFileName) <- t =-        return $ M "packZeroTerminatedFileNameArray"-    | TCArray True _ _ (TBasicType TPtr) <- t =-        return $ M "packZeroTerminatedPtrArray"-    | TCArray True _ _ (TBasicType TUInt8) <- t =-        return $ M "packZeroTerminatedByteString"-    | TCArray True _ _ (TBasicType TBoolean) <- t =-        return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))"-    | TCArray True _ _ (TBasicType TGType) <- t =-        return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)"-    | TCArray True _ _ (TBasicType _) <- t =-        return $ M "packZeroTerminatedStorableArray"-    | TCArray False _ _ (TBasicType TUTF8) <- t =-        return $ M "packUTF8CArray"-    | TCArray False _ _ (TBasicType TFileName) <- t =-        return $ M "packFileNameArray"-    | TCArray False _ _ (TBasicType TPtr) <- t =-        return $ M "packPtrArray"-    | TCArray False _ _ (TBasicType TUInt8) <- t =-        return $ M "packByteString"-    | TCArray False _ _ (TBasicType TBoolean) <- t =-        return $ M "(packMapStorableArray (fromIntegral . fromEnum))"-    | TCArray False _ _ (TBasicType TGType) <- t =-        return $ M "(packMapStorableArray gtypeToCGType)"-    | TCArray False _ _ (TBasicType TFloat) <- t =-        return $ M "(packMapStorableArray realToFrac)"-    | TCArray False _ _ (TBasicType TDouble) <- t =-        return $ M "(packMapStorableArray realToFrac)"-    | TCArray False _ _ (TBasicType _) <- t =-        return $ M "packStorableArray"-    | TCArray{}  <- t = notImplementedError $-                   "Don't know how to pack C array of type " <> tshow t-    | otherwise = case (typeShow hType, typeShow fType) of-               ("T.Text", "CString") -> return $ M "textToCString"-               ("[Char]", "CString") -> return $ M "stringToCString"-               ("Char", "CInt")      -> return "(fromIntegral . ord)"-               ("Bool", "CInt")      -> return "(fromIntegral . fromEnum)"-               ("Float", "CFloat")   -> return "realToFrac"-               ("Double", "CDouble") -> return "realToFrac"-               ("GType", "CGType")   -> return "gtypeToCGType"-               _                     -> notImplementedError $-                                        "Don't know how to convert "-                                        <> typeShow hType <> " into "-                                        <> typeShow fType <> ".\n"-                                        <> "Internal type: "-                                        <> tshow t--getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor-getForeignConstructor t transfer = do-  a <- findAPI t-  hType <- haskellType t-  fType <- foreignType t-  hToF' t a hType fType transfer--hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter-hToF_PackedType t packer transfer = do-  innerConstructor <- getForeignConstructor t transfer-  return $ do-    mapC innerConstructor-    apply (M packer)---- | Try to find the `hash` and `equal` functions appropriate for the--- given type, when used as a key in a GHashTable.-hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text)-hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual")-hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual")-hashTableKeyMappings t =-    notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported."---- | `GHashTable` tries to fit every type into a pointer, the--- following function tries to find the appropriate--- (destroy,packer,unpacker) for the given type.-hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text)-hashTablePtrPackers (TBasicType TPtr) =-    return ("Nothing", "ptrPackPtr", "ptrUnpackPtr")-hashTablePtrPackers (TBasicType TUTF8) =-    return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr")-hashTablePtrPackers t =-    notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported."--hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter-hToF_PackGHashTable keys elems = do-  -- We will be adding elements to the Hash list with appropriate-  -- destructors, so we always want a fresh copy.-  keysConstructor <- getForeignConstructor keys TransferEverything-  elemsConstructor <- getForeignConstructor elems TransferEverything-  (keyHash, keyEqual) <- hashTableKeyMappings keys-  (keyDestroy, keyPack, _) <- hashTablePtrPackers keys-  (elemDestroy, elemPack, _) <- hashTablePtrPackers elems-  return $ do-    apply (P "Map.toList")-    mapFirst keysConstructor-    mapSecond elemsConstructor-    mapFirst (P keyPack)-    mapSecond (P elemPack)-    apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual,-                                 keyDestroy, elemDestroy]))--hToF :: Type -> Transfer -> ExcCodeGen Converter-hToF (TGList t) transfer = do-  isPtr <- typeIsPtr t-  when (not isPtr) $-       badIntroError ("'" <> tshow t <>-                      "' is not a pointer type, cannot pack into a GList.")-  hToF_PackedType t "packGList" transfer-hToF (TGSList t) transfer = do-  isPtr <- typeIsPtr t-  when (not isPtr) $-       badIntroError ("'" <> tshow t <>-                      "' is not a pointer type, cannot pack into a GSList.")-  hToF_PackedType t "packGSList" transfer-hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer-hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer-hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb-hToF (TCArray zt _ _ t@(TCArray{})) transfer = do-  let packer = if zt-               then "packZeroTerminated"-               else "pack"-  hToF_PackedType t (packer <> "PtrArray") transfer--hToF (TCArray zt _ _ t@(TInterface _)) transfer = do-  isScalar <- typeIsEnumOrFlag t-  let packer = if zt-               then "packZeroTerminated"-               else "pack"-  if isScalar-  then hToF_PackedType t (packer <> "StorableArray") transfer-  else do-    api <- findAPI t-    let size = case api of-                 Just (APIStruct s) -> structSize s-                 Just (APIUnion u) -> unionSize u-                 _ -> 0-    if size == 0 || zt-    then hToF_PackedType t (packer <> "PtrArray") transfer-    else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer--hToF t transfer = do-  a <- findAPI t-  hType <- haskellType t-  fType <- foreignType t-  constructor <- hToF' t a hType fType transfer-  return $ apply constructor--boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor-boxedForeignPtr constructor transfer = return $-   case transfer of-     TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor-     _ -> M $ parenthesize $ "newBoxed " <> constructor--suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor-suForeignPtr isBoxed hType transfer = do-  let constructor = typeConName hType-  if isBoxed then-      boxedForeignPtr constructor transfer-  else return $ M $ parenthesize $-       case transfer of-         TransferEverything -> "wrapPtr " <> constructor-         _ -> "newPtr " <> constructor--structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor-structForeignPtr s =-    suForeignPtr (structIsBoxed s)--unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor-unionForeignPtr u =-    suForeignPtr (unionIsBoxed u)--fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor-fObjectToH t hType transfer = do-  let constructor = typeConName hType-  isGO <- isGObject t-  return $ M $ parenthesize $-    case transfer of-    TransferEverything ->-        if isGO-        then "wrapObject " <> constructor-        else "wrapPtr " <> constructor-    _ ->-        if isGO-        then "newObject " <> constructor-        else "newPtr " <> constructor--fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor-fCallbackToH hType TransferNothing = do-  let constructor = typeConName hType-  return (P (callbackDynamicWrapper constructor))-fCallbackToH _ transfer =-  notImplementedError ("ForeignCallback with unsupported transfer type `"-                       <> tshow transfer <> "'")--fVariantToH :: Transfer -> CodeGen Constructor-fVariantToH transfer =-  return $ M $ case transfer of-                  TransferEverything -> "B.GVariant.wrapGVariantPtr"-                  _ -> "B.GVariant.newGVariantFromPtr"--fParamSpecToH :: Transfer -> CodeGen Constructor-fParamSpecToH transfer =-  return $ M $ case transfer of-                  TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr"-                  _ -> "B.GParamSpec.newGParamSpecFromPtr"--fClosureToH :: Transfer -> Maybe Type -> CodeGen Constructor--- Untyped closures-fClosureToH transfer Nothing =-  return $ M $ case transfer of-                  TransferEverything ->-                    parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr"-                  _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr"--- Typed closures-fClosureToH transfer (Just _) =-  return $ M $ case transfer of-                  TransferEverything -> "B.GClosure.wrapGClosurePtr"-                  _ -> "B.GClosure.newGClosureFromPtr"--fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer-         -> ExcCodeGen Constructor-fToH' t a hType fType transfer-    | ( hType == fType ) = return Id-    | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)"-    | Just (APIFlags _) <- a = return "wordToGFlags"-    | TError <- t = boxedForeignPtr "GError" transfer-    | TVariant <- t = fVariantToH transfer-    | TParamSpec <- t = fParamSpecToH transfer-    | TGClosure c <- t = fClosureToH transfer c-    | Just (APIStruct s) <- a = structForeignPtr s hType transfer-    | Just (APIUnion u) <- a = unionForeignPtr u hType transfer-    | Just (APIObject _) <- a = fObjectToH t hType transfer-    | Just (APIInterface _) <- a = fObjectToH t hType transfer-    | Just (APICallback _) <- a = fCallbackToH hType transfer-    | TCArray True _ _ (TBasicType TUTF8) <- t =-        return $ M "unpackZeroTerminatedUTF8CArray"-    | TCArray True _ _ (TBasicType TFileName) <- t =-        return $ M "unpackZeroTerminatedFileNameArray"-    | TCArray True _ _ (TBasicType TUInt8) <- t =-        return $ M "unpackZeroTerminatedByteString"-    | TCArray True _ _ (TBasicType TPtr) <- t =-        return $ M "unpackZeroTerminatedPtrArray"-    | TCArray True _ _ (TBasicType TBoolean) <- t =-        return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))"-    | TCArray True _ _ (TBasicType TGType) <- t =-        return $ M "(unpackMapZeroTerminatedStorableArray GType)"-    | TCArray True _ _ (TBasicType TFloat) <- t =-        return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"-    | TCArray True _ _ (TBasicType TDouble) <- t =-        return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"-    | TCArray True _ _ (TBasicType _) <- t =-        return $ M "unpackZeroTerminatedStorableArray"-    | TCArray{}  <- t = notImplementedError $-                   "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 (typeShow fType, typeShow hType) of-               ("CString", "T.Text") -> return $ M "cstringToText"-               ("CString", "[Char]") -> return $ M "cstringToString"-               ("CInt", "Char")      -> return "(chr . fromIntegral)"-               ("CInt", "Bool")      -> return "(/= 0)"-               ("CFloat", "Float")   -> return "realToFrac"-               ("CDouble", "Double") -> return "realToFrac"-               ("CGType", "GType")   -> return "GType"-               _                     ->-                   notImplementedError $ "Don't know how to convert "-                                           <> typeShow fType <> " into "-                                           <> typeShow hType <> ".\n"-                                           <> "Internal type: "-                                           <> tshow t--getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor-getHaskellConstructor t transfer = do-  a <- findAPI t-  hType <- haskellType t-  fType <- foreignType t-  fToH' t a hType fType transfer--fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter-fToH_PackedType t unpacker transfer = do-  innerConstructor <- getHaskellConstructor t transfer-  return $ do-    apply (M unpacker)-    mapC innerConstructor--fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter-fToH_UnpackGHashTable keys elems transfer = do-  keysConstructor <- getHaskellConstructor keys transfer-  (_,_,keysUnpack) <- hashTablePtrPackers keys-  elemsConstructor <- getHaskellConstructor elems transfer-  (_,_,elemsUnpack) <- hashTablePtrPackers elems-  return $ do-    apply (M "unpackGHashTable")-    mapFirst (P keysUnpack)-    mapFirst keysConstructor-    mapSecond (P elemsUnpack)-    mapSecond elemsConstructor-    apply (P "Map.fromList")--fToH :: Type -> Transfer -> ExcCodeGen Converter-fToH (TGList t) transfer = do-  isPtr <- typeIsPtr t-  when (not isPtr) $-       badIntroError ("`" <> tshow t <>-                      "' is not a pointer type, cannot unpack from a GList.")-  fToH_PackedType t "unpackGList" transfer-fToH (TGSList t) transfer = do-  isPtr <- typeIsPtr t-  when (not isPtr) $-       badIntroError ("`" <> tshow t <>-                      "' is not a pointer type, cannot unpack from a GSList.")-  fToH_PackedType t "unpackGSList" transfer-fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer-fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer-fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer--- We cannot unpack arrays without any kind of length info.-fToH t@(TCArray False (-1) (-1) _) _ =-  badIntroError ("`" <> tshow t <>-                  "' is an array type, but contains no length information.")-fToH (TCArray True _ _ t@(TCArray{})) transfer =-  fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer-fToH (TCArray True _ _ t@(TInterface _)) transfer = do-  isScalar <- typeIsEnumOrFlag t-  if isScalar-  then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer-  else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer--fToH t transfer = do-  a <- findAPI t-  hType <- haskellType t-  fType <- foreignType t-  constructor <- fToH' t a hType fType transfer-  return $ apply constructor---- | Somewhat like `fToH`, but with slightly different borrowing--- semantics: in the case of `TransferNothing` we wrap incoming--- pointers to boxed structs into transient `ManagedPtr`s (every other--- case behaves as `fToH`). These are `ManagedPtr`s for which we do--- not make a copy, and which will be disowned when the function--- exists, instead of making a copy that the GC will collect--- eventually.------ This is necessary in order to get the semantics of callbacks and--- signals right: in some cases making a copy of the object does not--- simply increase the refcount, but rather makes a full copy. In this--- cases modification of the original object is not possible, but this--- is sometimes useful, see for example------ https://github.com/haskell-gi/haskell-gi/issues/97------ Another situation where making a copy of incoming arguments is--- problematic is when the underlying library is not thread-safe. When--- running under the threaded GHC runtime it can happen that the GC--- runs on a different OS thread than the thread where the object was--- created, and this leads to rather mysterious bugs, see for example------ https://github.com/haskell-gi/haskell-gi/issues/96------ This case is particularly nasty, since it affects `onWidgetDraw`,--- which is very common.-transientToH :: Type -> Transfer -> ExcCodeGen Converter-transientToH t@(TInterface _) TransferNothing = do-  a <- findAPI t-  case a of-    Just (APIStruct s) -> if structIsBoxed s-                          then wrapTransient t-                          else fToH t TransferNothing-    Just (APIUnion u) -> if unionIsBoxed u-                         then wrapTransient t-                         else fToH t TransferNothing-    _ -> fToH t TransferNothing-transientToH t transfer = fToH t transfer---- | Wrap the given transient.-wrapTransient :: Type -> CodeGen Converter-wrapTransient t = do-  hCon <- typeConName <$> haskellType t-  return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon--unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter-unpackCArray length (TCArray False _ _ t) transfer =-  case t of-    TBasicType TUTF8 -> return $ apply $ M $ parenthesize $-                        "unpackUTF8CArrayWithLength " <> length-    TBasicType TFileName -> return $ apply $ M $ parenthesize $-                            "unpackFileNameArrayWithLength " <> length-    TBasicType TUInt8 -> return $ apply $ M $ parenthesize $-                         "unpackByteStringWithLength " <> length-    TBasicType TPtr -> return $ apply $ M $ parenthesize $-                         "unpackPtrArrayWithLength " <> length-    TBasicType TBoolean -> return $ apply $ M $ parenthesize $-                         "unpackMapStorableArrayWithLength (/= 0) " <> length-    TBasicType TGType -> return $ apply $ M $ parenthesize $-                         "unpackMapStorableArrayWithLength GType " <> length-    TBasicType TFloat -> return $ apply $ M $ parenthesize $-                         "unpackMapStorableArrayWithLength realToFrac " <> length-    TBasicType TDouble -> return $ apply $ M $ parenthesize $-                         "unpackMapStorableArrayWithLength realToFrac " <> length-    TBasicType _ -> return $ apply $ M $ parenthesize $-                         "unpackStorableArrayWithLength " <> length-    TInterface _ -> do-           a <- findAPI t-           isScalar <- typeIsEnumOrFlag t-           hType <- haskellType t-           fType <- foreignType t-           innerConstructor <- fToH' t a hType fType transfer-           let (boxed, size) = case a of-                        Just (APIStruct s) -> (structIsBoxed s, structSize s)-                        Just (APIUnion u) -> (unionIsBoxed u, unionSize u)-                        _ -> (False, 0)-           let unpacker | isScalar    = "unpackStorableArrayWithLength"-                        | (size == 0) = "unpackPtrArrayWithLength"-                        | boxed       = "unpackBoxedArrayWithLength " <> tshow size-                        | otherwise   = "unpackBlockArrayWithLength " <> tshow size-           return $ do-             apply $ M $ parenthesize $ unpacker <> " " <> length-             mapC innerConstructor-    _ -> notImplementedError $-         "unpackCArray : Don't know how to unpack C Array of type " <> tshow t--unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type."---- | Whether to expose closures and the associated destroy notify--- handlers in the Haskell wrapper.-data ExposeClosures = WithClosures-                    | WithoutClosures-  deriving (Eq)---- | Given a type find the typeclasses the type belongs to, and return--- the representation of the type in the function signature and the--- list of typeclass constraints for the type.-argumentType :: Type -> ExposeClosures -> CodeGen (Text, [Text])-argumentType (TGList a) expose = do-  (name, constraints) <- argumentType a expose-  return ("[" <> name <> "]", constraints)-argumentType (TGSList a) expose = do-  (name, constraints) <- argumentType a expose-  return ("[" <> name <> "]", constraints)-argumentType t expose = do-  api <- findAPI t-  s <- typeShow <$> haskellType t-  case api of-    -- Instead of restricting to the actual class,-    -- we allow for any object descending from it.-    Just (APIInterface _) -> do-      cls <- typeConstraint t-      l <- getFreshTypeVariable-      return (l, [cls <> " " <> l])-    Just (APIObject _) -> do-      isGO <- isGObject t-      if isGO-        then do cls <- typeConstraint t-                l <- getFreshTypeVariable-                return (l, [cls <> " " <> l])-        else return (s, [])-    Just (APICallback cb) ->-      -- See [Note: Callables that throw]-      if callableThrows (cbCallable cb)-      then do-        ft <- typeShow <$> foreignType t-        return (ft, [])-      else-        case expose of-          WithClosures -> do-            s_withClosures <- typeShow <$> isoHaskellType t-            return (s_withClosures, [])-          WithoutClosures ->-            return (s, [])-    _ -> return (s, [])--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 -> con0 "Int32"-                               n -> error ("Unsupported `gint' length: " ++-                                           show n)-haskellBasicType TUInt     = case sizeOf (0 :: CUInt) of-                               4 -> con0 "Word32"-                               n -> error ("Unsupported `guint' length: " ++-                                           show n)-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-haskellType (TBasicType bt) = return $ haskellBasicType bt--- There is no great choice in this case, so we simply pass the--- pointer along. This is useful for GdkPixbufNotify, for example.-haskellType t@(TCArray False (-1) (-1) (TBasicType TUInt8)) =-  foreignType t-haskellType (TCArray _ _ _ (TBasicType TUInt8)) =-  return $ "ByteString" `con` []-haskellType (TCArray _ _ _ a) = do-  inner <- haskellType a-  return $ "[]" `con` [inner]-haskellType (TGArray a) = do-  inner <- haskellType a-  return $ "[]" `con` [inner]-haskellType (TPtrArray a) = do-  inner <- haskellType a-  return $ "[]" `con` [inner]-haskellType (TByteArray) = return $ "ByteString" `con` []-haskellType (TGList a) = do-  inner <- haskellType a-  return $ "[]" `con` [inner]-haskellType (TGSList a) = do-  inner <- haskellType a-  return $ "[]" `con` [inner]-haskellType (TGHash a b) = do-  innerA <- haskellType a-  innerB <- haskellType b-  return $ "Map.Map" `con` [innerA, innerB]-haskellType TError = return $ "GError" `con` []-haskellType TVariant = return $ "GVariant" `con` []-haskellType TParamSpec = return $ "GParamSpec" `con` []-haskellType (TGClosure (Just inner@(TInterface n))) = do-  innerAPI <- getAPI inner-  case innerAPI of-    APICallback _ -> do-      tname <- qualifiedSymbol (callbackCType $ name n) n-      return $ "GClosure" `con` [con0 tname]-    -- The given inner type does not make sense, so we treat it as an-    -- untyped closure.-    _ -> haskellType (TGClosure Nothing)-haskellType (TGClosure _) = do-  tyvar <- getFreshTypeVariable-  return $ "GClosure" `con` [con0 tyvar]-haskellType (TInterface (Name "GObject" "Value")) = return $ "GValue" `con` []-haskellType t@(TInterface n) = do-  api <- getAPI t-  tname <- qualifiedAPI n-  return $ case api of-             (APIFlags _) -> "[]" `con` [tname `con` []]-             _ -> tname `con` []---- | Whether the callable has closure arguments (i.e. "user_data"--- style arguments).-callableHasClosures :: Callable -> Bool-callableHasClosures = any (/= -1) . map argClosure . args---- | Check whether the given type corresponds to a callback.-typeIsCallback :: Type -> CodeGen Bool-typeIsCallback t@(TInterface _) = do-  api <- findAPI t-  case api of-    Just (APICallback _) -> return True-    _ -> return False-typeIsCallback _ = return False---- | Basically like `haskellType`, but for types which admit a--- "isomorphic" version of the Haskell type distinct from the usual--- Haskell type.  Generally the Haskell type we expose is isomorphic--- to the foreign type, but in some cases, such as callbacks with--- closure arguments, this does not hold, as we omit the closure--- arguments. This function returns a type which is actually--- isomorphic. There is another case this function deals with: for--- convenience untyped `TGClosure` types have a type variable on the--- Haskell side when they are arguments to functions, but we do not--- want this when they appear as arguments to callbacks/signals, or--- return types of properties, as it would force the type synonym/type--- family to depend on the type variable.-isoHaskellType :: Type -> CodeGen TypeRep-isoHaskellType (TGClosure Nothing) =-  return $ "GClosure" `con` [con0 "()"]-isoHaskellType t@(TInterface n) = do-  api <- findAPI t-  case api of-    Just (APICallback cb) -> do-        tname <- qualifiedAPI n-        if callableHasClosures (cbCallable cb)-        then return ((callbackHTypeWithClosures tname) `con` [])-        else return (tname `con` [])-    _ -> haskellType t-isoHaskellType t = haskellType t---- | Foreign (C) type associated to one of the basic types.-foreignBasicType :: BasicType -> TypeRep-foreignBasicType TBoolean  = "CInt" `con` []-foreignBasicType TUTF8     = "CString" `con` []-foreignBasicType TFileName = "CString" `con` []-foreignBasicType TUniChar  = "CInt" `con` []-foreignBasicType TFloat    = "CFloat" `con` []-foreignBasicType TDouble   = "CDouble" `con` []-foreignBasicType TGType    = "CGType" `con` []-foreignBasicType t         = haskellBasicType t---- This translates GI types to the types used in foreign function calls.-foreignType :: Type -> CodeGen TypeRep-foreignType (TBasicType t) = return $ foreignBasicType t-foreignType (TCArray zt _ _ t) = do-  api <- findAPI t-  let size = case api of-               Just (APIStruct s) -> structSize s-               Just (APIUnion u) -> unionSize u-               _ -> 0-  if size == 0 || zt-  then ptr <$> foreignType t-  else foreignType t-foreignType (TGArray a) = do-  inner <- foreignType a-  return $ ptr ("GArray" `con` [inner])-foreignType (TPtrArray a) = do-  inner <- foreignType a-  return $ ptr ("GPtrArray" `con` [inner])-foreignType (TByteArray) = return $ ptr ("GByteArray" `con` [])-foreignType (TGList a) = do-  inner <- foreignType a-  return $ ptr ("GList" `con` [inner])-foreignType (TGSList a) = do-  inner <- foreignType a-  return $ ptr ("GSList" `con` [inner])-foreignType (TGHash a b) = do-  innerA <- foreignType a-  innerB <- foreignType b-  return $ ptr ("GHashTable" `con` [innerA, innerB])-foreignType t@TError = ptr <$> haskellType t-foreignType t@TVariant = ptr <$> haskellType t-foreignType t@TParamSpec = ptr <$> haskellType t-foreignType (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"])-foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t-foreignType (TInterface (Name "GObject" "Value")) =-  return $ ptr $ "GValue" `con` []-foreignType t@(TInterface n) = do-  api <- getAPI t-  let enumIsSigned e = any (< 0) (map enumMemberValue (enumMembers e))-      ctypeForEnum e = if enumIsSigned e-                       then "CInt"-                       else "CUInt"-  case api of-    APIEnum e -> return $ (ctypeForEnum e) `con` []-    APIFlags (Flags e) -> return $ (ctypeForEnum e) `con` []-    APICallback _ -> do-      tname <- qualifiedSymbol (callbackCType $ name n) n-      return (funptr $ tname `con` [])-    _ -> do-      tname <- qualifiedAPI n-      return (ptr $ tname `con` [])---- | Whether the give type corresponds to an enum or flag.-typeIsEnumOrFlag :: Type -> CodeGen Bool-typeIsEnumOrFlag t = do-  a <- findAPI t-  case a of-    Nothing -> return False-    (Just (APIEnum _)) -> return True-    (Just (APIFlags _)) -> return True-    _ -> return False---- | Information on how to allocate a type.-data TypeAllocInfo = TypeAllocInfo {-      typeAllocInfoIsBoxed :: Bool-    , typeAllocInfoSize    :: Int -- ^ In bytes.-    }---- | Information on how to allocate the given type, if known.-typeAllocInfo :: Type -> CodeGen (Maybe TypeAllocInfo)-typeAllocInfo t = do-  api <- findAPI t-  case api of-    Just (APIStruct s) -> case structSize s of-                            0 -> return Nothing-                            n -> let info = TypeAllocInfo {-                                              typeAllocInfoIsBoxed = structIsBoxed s-                                            , typeAllocInfoSize = n-                                            }-                                 in return (Just info)-    _ -> return Nothing---- | Returns whether the given type corresponds to a `ManagedPtr`--- instance (a thin wrapper over a `ForeignPtr`).-isManaged   :: Type -> CodeGen Bool-isManaged TError = return True-isManaged TVariant = return True-isManaged TParamSpec = return True-isManaged (TGClosure _) = return True-isManaged t@(TInterface _) = do-  a <- findAPI t-  case a of-    Just (APIObject _)    -> return True-    Just (APIInterface _) -> return True-    Just (APIStruct _)    -> return True-    Just (APIUnion _)     -> return True-    _                     -> return False-isManaged _ = return False---- | Returns whether the given type is represented by a pointer on the--- C side.-typeIsPtr :: Type -> CodeGen Bool-typeIsPtr t = isJust <$> typePtrType t---- | Distinct types of foreign pointers.-data FFIPtrType = FFIPtr    -- ^ Ordinary `Ptr`.-                | FFIFunPtr -- ^ `FunPtr`.---- | For those types represented by pointers on the C side, return the--- type of pointer which represents them on the Haskell FFI.-typePtrType :: Type -> CodeGen (Maybe FFIPtrType)-typePtrType (TBasicType TPtr) = return (Just FFIPtr)-typePtrType (TBasicType TUTF8) = return (Just FFIPtr)-typePtrType (TBasicType TFileName) = return (Just FFIPtr)-typePtrType t = do-  ft <- foreignType t-  case typeConName ft of-    "Ptr"    -> return (Just FFIPtr)-    "FunPtr" -> return (Just FFIFunPtr)-    _        -> return Nothing---- | If the passed in type is nullable, return the conversion function--- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the--- corresponding `Maybe` type.-maybeNullConvert :: Type -> CodeGen (Maybe Text)-maybeNullConvert (TBasicType TPtr) = return Nothing-maybeNullConvert (TGList _) = return Nothing-maybeNullConvert (TGSList _) = return Nothing-maybeNullConvert t = do-  pt <- typePtrType t-  case pt of-    Just FFIPtr -> return (Just "SP.convertIfNonNull")-    Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull")-    Nothing -> return Nothing---- | An appropriate NULL value for the given type, for types which are--- represented by pointers on the C side.-nullPtrForType :: Type -> CodeGen (Maybe Text)-nullPtrForType t = do-  pt <- typePtrType t-  case pt of-    Just FFIPtr -> return (Just "FP.nullPtr")-    Just FFIFunPtr -> return (Just "FP.nullFunPtr")-    Nothing -> return Nothing---- | Returns whether the given type should be represented by a--- `Maybe` type on the Haskell side. This applies to all properties--- which have a C representation in terms of pointers, except for--- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers,--- which we just pass through to the Haskell side. Notice that--- introspection annotations can override this.-typeIsNullable :: Type -> CodeGen Bool-typeIsNullable t = isJust <$> maybeNullConvert t---- | If the given type maps to a list in Haskell, return the type of the--- elements, and the function that maps over them.-elementTypeAndMap :: Type -> Text -> Maybe (Type, Text)--- ByteString-elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing-elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray")-elementTypeAndMap (TCArray False (-1) _ t) len =-    Just (t, parenthesize $ "mapCArrayWithLength " <> len)-elementTypeAndMap (TCArray False fixed _ t) _ =-    Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed)-elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray")-elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray")-elementTypeAndMap (TGList t) _ = Just (t, "mapGList")-elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList")--- GHashTable is treated separately, see Transfer.hs-elementTypeAndMap _ _ = Nothing---- Return just the element type.-elementType :: Type -> Maybe Type-elementType t = fst <$> elementTypeAndMap t undefined---- Return just the map.-elementMap :: Type -> Text -> Maybe Text-elementMap t len = snd <$> elementTypeAndMap t len

@@ -0,0 +1,1077 @@+{-# LANGUAGE PatternGuards, DeriveFunctor #-}++module Data.GI.CodeGen.Conversions+    ( convert+    , genConversion+    , unpackCArray+    , computeArrayLength++    , callableHasClosures++    , hToF+    , fToH+    , transientToH+    , haskellType+    , isoHaskellType+    , foreignType++    , argumentType+    , ExposeClosures(..)+    , elementType+    , elementMap+    , elementTypeAndMap++    , isManaged+    , typeIsNullable+    , typeIsPtr+    , typeIsCallback+    , maybeNullConvert+    , nullPtrForType++    , typeAllocInfo+    , TypeAllocInfo(..)++    , apply+    , mapC+    , literal+    , Constructor(..)+    ) where++#include <glib-object.h>++import Control.Monad (when)+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Exts (IsString(..))++import Foreign.C.Types (CInt, CUInt)+import Foreign.Storable (sizeOf)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.GObject+import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util++-- | The free monad.+data Free f r = Free (f (Free f r)) | Pure r++instance Functor f => Functor (Free f) where+  fmap f = go where+    go (Pure a)  = Pure (f a)+    go (Free fa) = Free (go <$> fa)++instance (Functor f) => Applicative (Free f) where+    pure = Pure+    Pure a <*> Pure b = Pure $ a b+    Pure a <*> Free mb = Free $ fmap a <$> mb+    Free ma <*> b = Free $ (<*> b) <$> ma++instance (Functor f) => Monad (Free f) where+    return = Pure+    (Free x) >>= f = Free (fmap (>>= f) x)+    (Pure r) >>= f = f r++-- | Lift some command to the Free monad.+liftF :: (Functor f) => f r -> Free f r+liftF command = Free (fmap Pure command)++-- String identifying a constructor in the generated code, which is+-- either (by default) a pure function (indicated by the P+-- constructor) or a function returning values on a monad (M+-- constructor). 'Id' denotes the identity function.+data Constructor = P Text | M Text | Id+                   deriving (Eq,Show)+instance IsString Constructor where+    fromString = P . T.pack++data FExpr next = Apply Constructor next+                | LambdaConvert Text next+                | MapC Map Constructor next+                | Literal Constructor next+                  deriving (Show, Functor)++type Converter = Free FExpr ()++-- Different available maps.+data Map = Map | MapFirst | MapSecond+         deriving (Show)++-- Naming for the maps.+mapName :: Map -> Text+mapName Map = "map"+mapName MapFirst = "mapFirst"+mapName MapSecond = "mapSecond"++-- Naming for the monadic versions of the maps that we use+monadicMapName :: Map -> Text+monadicMapName Map = "mapM"+monadicMapName MapFirst = "mapFirstA"+monadicMapName MapSecond = "mapSecondA"++apply :: Constructor -> Converter+apply f = liftF $ Apply f ()++mapC :: Constructor -> Converter+mapC f = liftF $ MapC Map f ()++mapFirst :: Constructor -> Converter+mapFirst f = liftF $ MapC MapFirst f ()++mapSecond :: Constructor -> Converter+mapSecond f = liftF $ MapC MapSecond f ()++literal :: Constructor -> Converter+literal f = liftF $ Literal f ()++lambdaConvert :: Text -> Converter+lambdaConvert c = liftF $ LambdaConvert c ()++genConversion :: Text -> Converter -> CodeGen Text+genConversion l (Pure ()) = return l+genConversion l (Free k) = do+  let l' = prime l+  case k of+    Apply (P f) next ->+        do line $ "let " <> l' <> " = " <> f <> " " <> l+           genConversion l' next+    Apply (M f) next ->+        do line $ l' <> " <- " <> f <> " " <> l+           genConversion l' next+    Apply Id next -> genConversion l next++    MapC m (P f) next ->+        do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l+           genConversion l' next+    MapC m (M f) next ->+        do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l+           genConversion l' next+    MapC _ Id next -> genConversion l next++    LambdaConvert conv next ->+        do line $ conv <> " " <> l <> " $ \\" <> l' <> " -> do"+           increaseIndent+           genConversion l' next++    Literal (P f) next ->+        do line $ "let " <> l <> " = " <> f+           genConversion l next+    Literal (M f) next ->+        do line $ l <> " <- " <> f+           genConversion l next+    Literal Id next -> genConversion l next++-- | Given an array, together with its type, return the code for reading+-- its length.+computeArrayLength :: Text -> Type -> ExcCodeGen Text+computeArrayLength array (TCArray _ _ _ t) = do+  reader <- findReader+  return $ "fromIntegral $ " <> reader <> " " <> array+    where findReader = case t of+                     TBasicType TUInt8 -> return "B.length"+                     _ -> return "P.length"+computeArrayLength _ t =+    notImplementedError $ "computeArrayLength called on non-CArray type "+                            <> tshow t++convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text+convert l c = do+  c' <- c+  genConversion l c'++hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor+hObjectToF t transfer =+  if transfer == TransferEverything+  then do+    isGO <- isGObject t+    if isGO+    then return $ M "B.ManagedPtr.disownObject"+    else return $ M "B.ManagedPtr.disownManagedPtr"+  -- castPtr since we accept any instance of the class associated with+  -- the GObject, not just the precise type of the GObject, while the+  -- foreign function declaration requires a pointer of the precise+  -- type.+  else return $ M "unsafeManagedPtrCastPtr"++hVariantToF :: Transfer -> CodeGen Constructor+hVariantToF transfer =+  if transfer == TransferEverything+  then return $ M "B.GVariant.disownGVariant"+  else return $ M "unsafeManagedPtrGetPtr"++hValueToF :: Transfer -> CodeGen Constructor+hValueToF transfer =+  if transfer == TransferEverything+  then return $ M "B.GValue.disownGValue"+  else return $ M "unsafeManagedPtrGetPtr"++hParamSpecToF :: Transfer -> CodeGen Constructor+hParamSpecToF transfer =+  if transfer == TransferEverything+  then return $ M "B.GParamSpec.disownGParamSpec"+  else return $ M "unsafeManagedPtrGetPtr"++hClosureToF :: Transfer -> Maybe Type -> CodeGen Constructor+-- Untyped closures+hClosureToF transfer Nothing =+  if transfer == TransferEverything+  then return $ M "B.GClosure.disownGClosure"+  -- We cast the point here because the foreign type for untyped+  -- closures is always represented as Ptr (GClosure ()), while the+  -- corresponding Haskell type is the parametric "GClosure a".+  else return $ M "unsafeManagedPtrCastPtr"+-- Typed closures+hClosureToF transfer (Just _) =+  if transfer == TransferEverything+  then return $ M "B.GClosure.disownGClosure"+  else return $ M "unsafeManagedPtrGetPtr"++hBoxedToF :: Transfer -> CodeGen Constructor+hBoxedToF transfer =+  if transfer == TransferEverything+  then return $ M "B.ManagedPtr.disownBoxed"+  else return $ M "unsafeManagedPtrGetPtr"++hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor+hStructToF s transfer =+    if transfer /= TransferEverything || structIsBoxed s then+        hBoxedToF transfer+    else do+        when (structSize s == 0) $+             badIntroError "Transferring a non-boxed struct with unknown size!"+        return $ M "unsafeManagedPtrGetPtr"++hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor+hUnionToF u transfer =+    if transfer /= TransferEverything || unionIsBoxed u then+        hBoxedToF transfer+    else do+        when (unionSize u == 0) $+             badIntroError "Transferring a non-boxed union with unknown size!"+        return $ M "unsafeManagedPtrGetPtr"++-- Given the Haskell and Foreign types, returns the name of the+-- function marshalling between both.+hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer+            -> ExcCodeGen Constructor+hToF' t a hType fType transfer+    | ( hType == fType ) = return Id+    | TError <- t = hBoxedToF transfer+    | TVariant <- t = hVariantToF transfer+    | TGValue <- t = hValueToF transfer+    | TParamSpec <- t = hParamSpecToF transfer+    | TGClosure c <- t = hClosureToF transfer c+    | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"+    | Just (APIFlags _) <- a = return "gflagsToWord"+    | Just (APIObject _) <- a = hObjectToF t transfer+    | Just (APIInterface _) <- a = hObjectToF t transfer+    | Just (APIStruct s) <- a = hStructToF s transfer+    | Just (APIUnion u) <- a = hUnionToF u transfer+    -- Converting callback types requires more context, we leave that+    -- as a special case to be implemented by the caller.+    | Just (APICallback _) <- a = error "Cannot handle callback type here!! "+    | TByteArray <- t = return $ M "packGByteArray"+    | TCArray True _ _ (TBasicType TUTF8) <- t =+        return $ M "packZeroTerminatedUTF8CArray"+    | TCArray True _ _ (TBasicType TFileName) <- t =+        return $ M "packZeroTerminatedFileNameArray"+    | TCArray True _ _ (TBasicType TPtr) <- t =+        return $ M "packZeroTerminatedPtrArray"+    | TCArray True _ _ (TBasicType TUInt8) <- t =+        return $ M "packZeroTerminatedByteString"+    | TCArray True _ _ (TBasicType TBoolean) <- t =+        return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))"+    | TCArray True _ _ (TBasicType TGType) <- t =+        return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)"+    | TCArray True _ _ (TBasicType _) <- t =+        return $ M "packZeroTerminatedStorableArray"+    | TCArray False _ _ (TBasicType TUTF8) <- t =+        return $ M "packUTF8CArray"+    | TCArray False _ _ (TBasicType TFileName) <- t =+        return $ M "packFileNameArray"+    | TCArray False _ _ (TBasicType TPtr) <- t =+        return $ M "packPtrArray"+    | TCArray False _ _ (TBasicType TUInt8) <- t =+        return $ M "packByteString"+    | TCArray False _ _ (TBasicType TBoolean) <- t =+        return $ M "(packMapStorableArray (fromIntegral . fromEnum))"+    | TCArray False _ _ (TBasicType TGType) <- t =+        return $ M "(packMapStorableArray gtypeToCGType)"+    | TCArray False _ _ (TBasicType TFloat) <- t =+        return $ M "(packMapStorableArray realToFrac)"+    | TCArray False _ _ (TBasicType TDouble) <- t =+        return $ M "(packMapStorableArray realToFrac)"+    | TCArray False _ _ (TBasicType _) <- t =+        return $ M "packStorableArray"+    | TCArray False _ _ TGValue <- t =+        return $ M "B.GValue.packGValueArray"+    | TCArray{}  <- t = notImplementedError $+                   "Don't know how to pack C array of type " <> tshow t+    | otherwise = case (typeShow hType, typeShow fType) of+               ("T.Text", "CString") -> return $ M "textToCString"+               ("[Char]", "CString") -> return $ M "stringToCString"+               ("Char", "CInt")      -> return "(fromIntegral . ord)"+               ("Bool", "CInt")      -> return "(fromIntegral . fromEnum)"+               ("Float", "CFloat")   -> return "realToFrac"+               ("Double", "CDouble") -> return "realToFrac"+               ("GType", "CGType")   -> return "gtypeToCGType"+               _                     -> notImplementedError $+                                        "Don't know how to convert "+                                        <> typeShow hType <> " into "+                                        <> typeShow fType <> ".\n"+                                        <> "Internal type: "+                                        <> tshow t++getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor+getForeignConstructor t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  hToF' t a hType fType transfer++hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter+hToF_PackedType t packer transfer = do+  innerConstructor <- getForeignConstructor t transfer+  return $ do+    mapC innerConstructor+    apply (M packer)++-- | Try to find the `hash` and `equal` functions appropriate for the+-- given type, when used as a key in a GHashTable.+hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text)+hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual")+hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual")+hashTableKeyMappings t =+    notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported."++-- | `GHashTable` tries to fit every type into a pointer, the+-- following function tries to find the appropriate+-- (destroy,packer,unpacker) for the given type.+hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text)+hashTablePtrPackers (TBasicType TPtr) =+    return ("Nothing", "ptrPackPtr", "ptrUnpackPtr")+hashTablePtrPackers (TBasicType TUTF8) =+    return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr")+hashTablePtrPackers t =+    notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported."++hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter+hToF_PackGHashTable keys elems = do+  -- We will be adding elements to the Hash list with appropriate+  -- destructors, so we always want a fresh copy.+  keysConstructor <- getForeignConstructor keys TransferEverything+  elemsConstructor <- getForeignConstructor elems TransferEverything+  (keyHash, keyEqual) <- hashTableKeyMappings keys+  (keyDestroy, keyPack, _) <- hashTablePtrPackers keys+  (elemDestroy, elemPack, _) <- hashTablePtrPackers elems+  return $ do+    apply (P "Map.toList")+    mapFirst keysConstructor+    mapSecond elemsConstructor+    mapFirst (P keyPack)+    mapSecond (P elemPack)+    apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual,+                                 keyDestroy, elemDestroy]))++hToF :: Type -> Transfer -> ExcCodeGen Converter+hToF (TGList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("'" <> tshow t <>+                      "' is not a pointer type, cannot pack into a GList.")+  hToF_PackedType t "packGList" transfer+hToF (TGSList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("'" <> tshow t <>+                      "' is not a pointer type, cannot pack into a GSList.")+  hToF_PackedType t "packGSList" transfer+hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer+hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer+hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb+hToF (TCArray zt _ _ t@(TCArray{})) transfer = do+  let packer = if zt+               then "packZeroTerminated"+               else "pack"+  hToF_PackedType t (packer <> "PtrArray") transfer+hToF (TCArray zt _ _ t@(TInterface _)) transfer = do+  isScalar <- typeIsEnumOrFlag t+  let packer = if zt+               then "packZeroTerminated"+               else "pack"+  if isScalar+  then hToF_PackedType t (packer <> "StorableArray") transfer+  else do+    api <- findAPI t+    let size = case api of+                 Just (APIStruct s) -> structSize s+                 Just (APIUnion u) -> unionSize u+                 _ -> 0+    if size == 0 || zt+    then hToF_PackedType t (packer <> "PtrArray") transfer+    else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer++hToF t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  constructor <- hToF' t a hType fType transfer+  return $ apply constructor++boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor+boxedForeignPtr constructor transfer = return $+   case transfer of+     TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor+     _ -> M $ parenthesize $ "newBoxed " <> constructor++suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor+suForeignPtr isBoxed hType transfer = do+  let constructor = typeConName hType+  if isBoxed then+      boxedForeignPtr constructor transfer+  else return $ M $ parenthesize $+       case transfer of+         TransferEverything -> "wrapPtr " <> constructor+         _ -> "newPtr " <> constructor++structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor+structForeignPtr s =+    suForeignPtr (structIsBoxed s)++unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor+unionForeignPtr u =+    suForeignPtr (unionIsBoxed u)++fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor+fObjectToH t hType transfer = do+  let constructor = typeConName hType+  isGO <- isGObject t+  return $ M $ parenthesize $+    case transfer of+    TransferEverything ->+        if isGO+        then "wrapObject " <> constructor+        else "wrapPtr " <> constructor+    _ ->+        if isGO+        then "newObject " <> constructor+        else "newPtr " <> constructor++fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor+fCallbackToH hType TransferNothing = do+  let constructor = typeConName hType+  return (P (callbackDynamicWrapper constructor))+fCallbackToH _ transfer =+  notImplementedError ("ForeignCallback with unsupported transfer type `"+                       <> tshow transfer <> "'")++fVariantToH :: Transfer -> CodeGen Constructor+fVariantToH transfer =+  return $ M $ case transfer of+                  TransferEverything -> "B.GVariant.wrapGVariantPtr"+                  _ -> "B.GVariant.newGVariantFromPtr"++fValueToH :: Transfer -> CodeGen Constructor+fValueToH transfer =+  return $ M $ case transfer of+                  TransferEverything -> "B.GValue.wrapGValuePtr"+                  _ -> "B.GValue.newGValueFromPtr"++fParamSpecToH :: Transfer -> CodeGen Constructor+fParamSpecToH transfer =+  return $ M $ case transfer of+                  TransferEverything -> "B.GParamSpec.wrapGParamSpecPtr"+                  _ -> "B.GParamSpec.newGParamSpecFromPtr"++fClosureToH :: Transfer -> Maybe Type -> CodeGen Constructor+-- Untyped closures+fClosureToH transfer Nothing =+  return $ M $ case transfer of+                  TransferEverything ->+                    parenthesize $ "B.GClosure.wrapGClosurePtr . FP.castPtr"+                  _ -> parenthesize $ "B.GClosure.newGClosureFromPtr . FP.castPtr"+-- Typed closures+fClosureToH transfer (Just _) =+  return $ M $ case transfer of+                  TransferEverything -> "B.GClosure.wrapGClosurePtr"+                  _ -> "B.GClosure.newGClosureFromPtr"++fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer+         -> ExcCodeGen Constructor+fToH' t a hType fType transfer+    | ( hType == fType ) = return Id+    | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)"+    | Just (APIFlags _) <- a = return "wordToGFlags"+    | TError <- t = boxedForeignPtr "GError" transfer+    | TVariant <- t = fVariantToH transfer+    | TGValue <- t = fValueToH transfer+    | TParamSpec <- t = fParamSpecToH transfer+    | TGClosure c <- t = fClosureToH transfer c+    | Just (APIStruct s) <- a = structForeignPtr s hType transfer+    | Just (APIUnion u) <- a = unionForeignPtr u hType transfer+    | Just (APIObject _) <- a = fObjectToH t hType transfer+    | Just (APIInterface _) <- a = fObjectToH t hType transfer+    | Just (APICallback _) <- a = fCallbackToH hType transfer+    | TCArray True _ _ (TBasicType TUTF8) <- t =+        return $ M "unpackZeroTerminatedUTF8CArray"+    | TCArray True _ _ (TBasicType TFileName) <- t =+        return $ M "unpackZeroTerminatedFileNameArray"+    | TCArray True _ _ (TBasicType TUInt8) <- t =+        return $ M "unpackZeroTerminatedByteString"+    | TCArray True _ _ (TBasicType TPtr) <- t =+        return $ M "unpackZeroTerminatedPtrArray"+    | TCArray True _ _ (TBasicType TBoolean) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))"+    | TCArray True _ _ (TBasicType TGType) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray GType)"+    | TCArray True _ _ (TBasicType TFloat) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"+    | TCArray True _ _ (TBasicType TDouble) <- t =+        return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"+    | TCArray True _ _ (TBasicType _) <- t =+        return $ M "unpackZeroTerminatedStorableArray"+    | TCArray{}  <- t = notImplementedError $+                   "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 (typeShow fType, typeShow hType) of+               ("CString", "T.Text") -> return $ M "cstringToText"+               ("CString", "[Char]") -> return $ M "cstringToString"+               ("CInt", "Char")      -> return "(chr . fromIntegral)"+               ("CInt", "Bool")      -> return "(/= 0)"+               ("CFloat", "Float")   -> return "realToFrac"+               ("CDouble", "Double") -> return "realToFrac"+               ("CGType", "GType")   -> return "GType"+               _                     ->+                   notImplementedError $ "Don't know how to convert "+                                           <> typeShow fType <> " into "+                                           <> typeShow hType <> ".\n"+                                           <> "Internal type: "+                                           <> tshow t++getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor+getHaskellConstructor t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  fToH' t a hType fType transfer++fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter+fToH_PackedType t unpacker transfer = do+  innerConstructor <- getHaskellConstructor t transfer+  return $ do+    apply (M unpacker)+    mapC innerConstructor++fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter+fToH_UnpackGHashTable keys elems transfer = do+  keysConstructor <- getHaskellConstructor keys transfer+  (_,_,keysUnpack) <- hashTablePtrPackers keys+  elemsConstructor <- getHaskellConstructor elems transfer+  (_,_,elemsUnpack) <- hashTablePtrPackers elems+  return $ do+    apply (M "unpackGHashTable")+    mapFirst (P keysUnpack)+    mapFirst keysConstructor+    mapSecond (P elemsUnpack)+    mapSecond elemsConstructor+    apply (P "Map.fromList")++fToH :: Type -> Transfer -> ExcCodeGen Converter+fToH (TGList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("`" <> tshow t <>+                      "' is not a pointer type, cannot unpack from a GList.")+  fToH_PackedType t "unpackGList" transfer+fToH (TGSList t) transfer = do+  isPtr <- typeIsPtr t+  when (not isPtr) $+       badIntroError ("`" <> tshow t <>+                      "' is not a pointer type, cannot unpack from a GSList.")+  fToH_PackedType t "unpackGSList" transfer+fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer+fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer+fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer+-- We cannot unpack arrays without any kind of length info.+fToH t@(TCArray False (-1) (-1) _) _ =+  badIntroError ("`" <> tshow t <>+                  "' is an array type, but contains no length information.")+fToH (TCArray True _ _ t@(TCArray{})) transfer =+  fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer+fToH (TCArray True _ _ t@(TInterface _)) transfer = do+  isScalar <- typeIsEnumOrFlag t+  if isScalar+  then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer+  else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer++fToH t transfer = do+  a <- findAPI t+  hType <- haskellType t+  fType <- foreignType t+  constructor <- fToH' t a hType fType transfer+  return $ apply constructor++-- | Somewhat like `fToH`, but with slightly different borrowing+-- semantics: in the case of `TransferNothing` we wrap incoming+-- pointers to boxed structs into transient `ManagedPtr`s (every other+-- case behaves as `fToH`). These are `ManagedPtr`s for which we do+-- not make a copy, and which will be disowned when the function+-- exists, instead of making a copy that the GC will collect+-- eventually.+--+-- This is necessary in order to get the semantics of callbacks and+-- signals right: in some cases making a copy of the object does not+-- simply increase the refcount, but rather makes a full copy. In this+-- cases modification of the original object is not possible, but this+-- is sometimes useful, see for example+--+-- https://github.com/haskell-gi/haskell-gi/issues/97+--+-- Another situation where making a copy of incoming arguments is+-- problematic is when the underlying library is not thread-safe. When+-- running under the threaded GHC runtime it can happen that the GC+-- runs on a different OS thread than the thread where the object was+-- created, and this leads to rather mysterious bugs, see for example+--+-- https://github.com/haskell-gi/haskell-gi/issues/96+--+-- This case is particularly nasty, since it affects `onWidgetDraw`,+-- which is very common.+transientToH :: Type -> Transfer -> ExcCodeGen Converter+transientToH t@(TInterface _) TransferNothing = do+  a <- findAPI t+  case a of+    Just (APIStruct s) -> if structIsBoxed s+                          then wrapTransient t+                          else fToH t TransferNothing+    Just (APIUnion u) -> if unionIsBoxed u+                         then wrapTransient t+                         else fToH t TransferNothing+    _ -> fToH t TransferNothing+transientToH t transfer = fToH t transfer++-- | Wrap the given transient.+wrapTransient :: Type -> CodeGen Converter+wrapTransient t = do+  hCon <- typeConName <$> haskellType t+  return $ lambdaConvert $ "B.ManagedPtr.withTransient " <> hCon++unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter+unpackCArray length (TCArray False _ _ t) transfer =+  case t of+    TBasicType TUTF8 -> return $ apply $ M $ parenthesize $+                        "unpackUTF8CArrayWithLength " <> length+    TBasicType TFileName -> return $ apply $ M $ parenthesize $+                            "unpackFileNameArrayWithLength " <> length+    TBasicType TUInt8 -> return $ apply $ M $ parenthesize $+                         "unpackByteStringWithLength " <> length+    TBasicType TPtr -> return $ apply $ M $ parenthesize $+                         "unpackPtrArrayWithLength " <> length+    TBasicType TBoolean -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength (/= 0) " <> length+    TBasicType TGType -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength GType " <> length+    TBasicType TFloat -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength realToFrac " <> length+    TBasicType TDouble -> return $ apply $ M $ parenthesize $+                         "unpackMapStorableArrayWithLength realToFrac " <> length+    TBasicType _ -> return $ apply $ M $ parenthesize $+                         "unpackStorableArrayWithLength " <> length+    TGValue -> return $ apply $ M $ parenthesize $+               "B.GValue.unpackGValueArrayWithLength " <> length+    TInterface _ -> do+           a <- findAPI t+           isScalar <- typeIsEnumOrFlag t+           hType <- haskellType t+           fType <- foreignType t+           let (boxed, size) = case a of+                        Just (APIStruct s) -> (structIsBoxed s, structSize s)+                        Just (APIUnion u) -> (unionIsBoxed u, unionSize u)+                        _ -> (False, 0)+           let unpacker | isScalar    = "unpackStorableArrayWithLength"+                        | (size == 0) = "unpackPtrArrayWithLength"+                        | boxed       = "unpackBoxedArrayWithLength " <> tshow size+                        | otherwise   = "unpackBlockArrayWithLength " <> tshow size+               -- We always make a copy of the elements when unpacking+               -- boxed types.+           let transfer' | boxed      = if transfer == TransferContainer+                                        then TransferEverything+                                        else transfer+                         | otherwise  = transfer+           innerConstructor <- fToH' t a hType fType transfer'+           return $ do+             apply $ M $ parenthesize $ unpacker <> " " <> length+             mapC innerConstructor+    _ -> notImplementedError $+         "unpackCArray : Don't know how to unpack C Array of type " <> tshow t++unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type."++-- | Whether to expose closures and the associated destroy notify+-- handlers in the Haskell wrapper.+data ExposeClosures = WithClosures+                    | WithoutClosures+  deriving (Eq)++-- | Given a type find the typeclasses the type belongs to, and return+-- the representation of the type in the function signature and the+-- list of typeclass constraints for the type.+argumentType :: Type -> ExposeClosures -> CodeGen (Text, [Text])+argumentType (TGList a) expose = do+  (name, constraints) <- argumentType a expose+  return ("[" <> name <> "]", constraints)+argumentType (TGSList a) expose = do+  (name, constraints) <- argumentType a expose+  return ("[" <> name <> "]", constraints)+argumentType t expose = do+  api <- findAPI t+  s <- typeShow <$> haskellType t+  case api of+    -- Instead of restricting to the actual class,+    -- we allow for any object descending from it.+    Just (APIInterface _) -> do+      cls <- typeConstraint t+      l <- getFreshTypeVariable+      return (l, [cls <> " " <> l])+    Just (APIObject _) -> do+      cls <- typeConstraint t+      l <- getFreshTypeVariable+      return (l, [cls <> " " <> l])+    Just (APICallback cb) ->+      -- See [Note: Callables that throw]+      if callableThrows (cbCallable cb)+      then do+        ft <- typeShow <$> foreignType t+        return (ft, [])+      else+        case expose of+          WithClosures -> do+            s_withClosures <- typeShow <$> isoHaskellType t+            return (s_withClosures, [])+          WithoutClosures ->+            return (s, [])+    _ -> return (s, [])++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 -> con0 "Int32"+                               n -> error ("Unsupported `gint' length: " +++                                           show n)+haskellBasicType TUInt     = case sizeOf (0 :: CUInt) of+                               4 -> con0 "Word32"+                               n -> error ("Unsupported `guint' length: " +++                                           show n)+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+haskellType (TBasicType bt) = return $ haskellBasicType bt+-- There is no great choice in this case, so we simply pass the+-- pointer along. This is useful for GdkPixbufNotify, for example.+haskellType t@(TCArray False (-1) (-1) (TBasicType TUInt8)) =+  foreignType t+haskellType (TCArray _ _ _ (TBasicType TUInt8)) =+  return $ "ByteString" `con` []+haskellType (TCArray _ _ _ a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TGArray a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TPtrArray a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TByteArray) = return $ "ByteString" `con` []+haskellType (TGList a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TGSList a) = do+  inner <- haskellType a+  return $ "[]" `con` [inner]+haskellType (TGHash a b) = do+  innerA <- haskellType a+  innerB <- haskellType b+  return $ "Map.Map" `con` [innerA, innerB]+haskellType TError = return $ "GError" `con` []+haskellType TVariant = return $ "GVariant" `con` []+haskellType TParamSpec = return $ "GParamSpec" `con` []+haskellType (TGClosure (Just inner@(TInterface n))) = do+  innerAPI <- getAPI inner+  case innerAPI of+    APICallback _ -> do+      let n' = normalizedAPIName innerAPI n+      tname <- qualifiedSymbol (callbackCType $ name n') n+      return $ "GClosure" `con` [con0 tname]+    -- The given inner type does not make sense, so we treat it as an+    -- untyped closure.+    _ -> haskellType (TGClosure Nothing)+haskellType (TGClosure _) = do+  tyvar <- getFreshTypeVariable+  return $ "GClosure" `con` [con0 tyvar]+haskellType TGValue = return $ "GValue" `con` []+haskellType t@(TInterface n) = do+  api <- getAPI t+  tname <- qualifiedAPI api n+  return $ case api of+             (APIFlags _) -> "[]" `con` [tname `con` []]+             _ -> tname `con` []++-- | Whether the callable has closure arguments (i.e. "user_data"+-- style arguments).+callableHasClosures :: Callable -> Bool+callableHasClosures = any (/= -1) . map argClosure . args++-- | Check whether the given type corresponds to a callback.+typeIsCallback :: Type -> CodeGen Bool+typeIsCallback t@(TInterface _) = do+  api <- findAPI t+  case api of+    Just (APICallback _) -> return True+    _ -> return False+typeIsCallback _ = return False++-- | Basically like `haskellType`, but for types which admit a+-- "isomorphic" version of the Haskell type distinct from the usual+-- Haskell type.  Generally the Haskell type we expose is isomorphic+-- to the foreign type, but in some cases, such as callbacks with+-- closure arguments, this does not hold, as we omit the closure+-- arguments. This function returns a type which is actually+-- isomorphic. There is another case this function deals with: for+-- convenience untyped `TGClosure` types have a type variable on the+-- Haskell side when they are arguments to functions, but we do not+-- want this when they appear as arguments to callbacks/signals, or+-- return types of properties, as it would force the type synonym/type+-- family to depend on the type variable.+isoHaskellType :: Type -> CodeGen TypeRep+isoHaskellType (TGClosure Nothing) =+  return $ "GClosure" `con` [con0 "()"]+isoHaskellType t@(TInterface n) = do+  api <- findAPI t+  case api of+    Just apiCB@(APICallback cb) -> do+        tname <- qualifiedAPI apiCB n+        if callableHasClosures (cbCallable cb)+        then return ((callbackHTypeWithClosures tname) `con` [])+        else return (tname `con` [])+    _ -> haskellType t+isoHaskellType t = haskellType t++-- | Foreign (C) type associated to one of the basic types.+foreignBasicType :: BasicType -> TypeRep+foreignBasicType TBoolean  = "CInt" `con` []+foreignBasicType TUTF8     = "CString" `con` []+foreignBasicType TFileName = "CString" `con` []+foreignBasicType TUniChar  = "CInt" `con` []+foreignBasicType TFloat    = "CFloat" `con` []+foreignBasicType TDouble   = "CDouble" `con` []+foreignBasicType TGType    = "CGType" `con` []+foreignBasicType t         = haskellBasicType t++-- This translates GI types to the types used in foreign function calls.+foreignType :: Type -> CodeGen TypeRep+foreignType (TBasicType t) = return $ foreignBasicType t+foreignType (TCArray _ _ _ TGValue) = return $ ptr ("B.GValue.GValue" `con` [])+foreignType (TCArray zt _ _ t) = do+  api <- findAPI t+  let size = case api of+               Just (APIStruct s) -> structSize s+               Just (APIUnion u) -> unionSize u+               _ -> 0+  if size == 0 || zt+  then ptr <$> foreignType t+  else foreignType t+foreignType (TGArray a) = do+  inner <- foreignType a+  return $ ptr ("GArray" `con` [inner])+foreignType (TPtrArray a) = do+  inner <- foreignType a+  return $ ptr ("GPtrArray" `con` [inner])+foreignType (TByteArray) = return $ ptr ("GByteArray" `con` [])+foreignType (TGList a) = do+  inner <- foreignType a+  return $ ptr ("GList" `con` [inner])+foreignType (TGSList a) = do+  inner <- foreignType a+  return $ ptr ("GSList" `con` [inner])+foreignType (TGHash a b) = do+  innerA <- foreignType a+  innerB <- foreignType b+  return $ ptr ("GHashTable" `con` [innerA, innerB])+foreignType t@TError = ptr <$> haskellType t+foreignType t@TVariant = ptr <$> haskellType t+foreignType t@TParamSpec = ptr <$> haskellType t+foreignType (TGClosure Nothing) = return $ ptr ("GClosure" `con` [con0 "()"])+foreignType t@(TGClosure (Just _)) = ptr <$> haskellType t+foreignType t@(TGValue) = ptr <$> haskellType t+foreignType t@(TInterface n) = do+  api <- getAPI t+  let enumIsSigned e = any (< 0) (map enumMemberValue (enumMembers e))+      ctypeForEnum e = if enumIsSigned e+                       then "CInt"+                       else "CUInt"+  case api of+    APIEnum e -> return $ (ctypeForEnum e) `con` []+    APIFlags (Flags e) -> return $ (ctypeForEnum e) `con` []+    APICallback _ -> do+      let n' = normalizedAPIName api n+      tname <- qualifiedSymbol (callbackCType $ name n') n+      return (funptr $ tname `con` [])+    _ -> do+      tname <- qualifiedAPI api n+      return (ptr $ tname `con` [])++-- | Whether the give type corresponds to an enum or flag.+typeIsEnumOrFlag :: Type -> CodeGen Bool+typeIsEnumOrFlag t = do+  a <- findAPI t+  case a of+    Nothing -> return False+    (Just (APIEnum _)) -> return True+    (Just (APIFlags _)) -> return True+    _ -> return False++-- | Information on how to allocate a type: allocator function and+-- size of the struct.+data TypeAllocInfo = TypeAlloc Text Int++-- | Information on how to allocate the given type, if known.+typeAllocInfo :: Type -> CodeGen (Maybe TypeAllocInfo)+typeAllocInfo TGValue =+  let n = #{size GValue}+  in return $ Just $ TypeAlloc ("SP.callocBytes " <> tshow n) n+typeAllocInfo t = do+  api <- findAPI t+  case api of+    Just (APIStruct s) ->+      case structSize s of+        0 -> return Nothing+        n -> let allocator = if structIsBoxed s+                             then "SP.callocBoxedBytes"+                             else "SP.callocBytes"+             in return $ Just $ TypeAlloc (allocator <> " " <> tshow n) n+    _ -> return Nothing++-- | Returns whether the given type corresponds to a `ManagedPtr`+-- instance (a thin wrapper over a `ForeignPtr`).+isManaged   :: Type -> CodeGen Bool+isManaged TError = return True+isManaged TVariant = return True+isManaged TGValue = return True+isManaged TParamSpec = return True+isManaged (TGClosure _) = return True+isManaged t@(TInterface _) = do+  a <- findAPI t+  case a of+    Just (APIObject _)    -> return True+    Just (APIInterface _) -> return True+    Just (APIStruct _)    -> return True+    Just (APIUnion _)     -> return True+    _                     -> return False+isManaged _ = return False++-- | Returns whether the given type is represented by a pointer on the+-- C side.+typeIsPtr :: Type -> CodeGen Bool+typeIsPtr t = isJust <$> typePtrType t++-- | Distinct types of foreign pointers.+data FFIPtrType = FFIPtr    -- ^ Ordinary `Ptr`.+                | FFIFunPtr -- ^ `FunPtr`.++-- | For those types represented by pointers on the C side, return the+-- type of pointer which represents them on the Haskell FFI.+typePtrType :: Type -> CodeGen (Maybe FFIPtrType)+typePtrType (TBasicType TPtr) = return (Just FFIPtr)+typePtrType (TBasicType TUTF8) = return (Just FFIPtr)+typePtrType (TBasicType TFileName) = return (Just FFIPtr)+typePtrType t = do+  ft <- foreignType t+  case typeConName ft of+    "Ptr"    -> return (Just FFIPtr)+    "FunPtr" -> return (Just FFIFunPtr)+    _        -> return Nothing++-- | If the passed in type is nullable, return the conversion function+-- between the FFI pointer type (may be a `Ptr` or a `FunPtr`) and the+-- corresponding `Maybe` type.+maybeNullConvert :: Type -> CodeGen (Maybe Text)+maybeNullConvert (TBasicType TPtr) = return Nothing+maybeNullConvert (TGList _) = return Nothing+maybeNullConvert (TGSList _) = return Nothing+maybeNullConvert t = do+  pt <- typePtrType t+  case pt of+    Just FFIPtr -> return (Just "SP.convertIfNonNull")+    Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull")+    Nothing -> return Nothing++-- | An appropriate NULL value for the given type, for types which are+-- represented by pointers on the C side.+nullPtrForType :: Type -> CodeGen (Maybe Text)+nullPtrForType t = do+  pt <- typePtrType t+  case pt of+    Just FFIPtr -> return (Just "FP.nullPtr")+    Just FFIFunPtr -> return (Just "FP.nullFunPtr")+    Nothing -> return Nothing++-- | Returns whether the given type should be represented by a+-- `Maybe` type on the Haskell side. This applies to all properties+-- which have a C representation in terms of pointers, except for+-- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers,+-- which we just pass through to the Haskell side. Notice that+-- introspection annotations can override this.+typeIsNullable :: Type -> CodeGen Bool+typeIsNullable t = isJust <$> maybeNullConvert t++-- | If the given type maps to a list in Haskell, return the type of the+-- elements, and the function that maps over them.+elementTypeAndMap :: Type -> Text -> Maybe (Type, Text)+-- ByteString+elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing+elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray")+elementTypeAndMap (TCArray _ _ _ TGValue) len =+  Just (TGValue, parenthesize $ "B.GValue.mapGValueArrayWithLength " <> len)+elementTypeAndMap (TCArray False (-1) _ t) len =+  Just (t, parenthesize $ "mapCArrayWithLength " <> len)+elementTypeAndMap (TCArray False fixed _ t) _ =+  Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed)+elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray")+elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray")+elementTypeAndMap (TGList t) _ = Just (t, "mapGList")+elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList")+-- GHashTable is treated separately, see Transfer.hs+elementTypeAndMap _ _ = Nothing++-- Return just the element type.+elementType :: Type -> Maybe Type+elementType t = fst <$> elementTypeAndMap t undefined++-- Return just the map.+elementMap :: Type -> Text -> Maybe Text+elementMap t len = snd <$> elementTypeAndMap t len

@@ -125,7 +125,7 @@                 Nothing -> let Name ns owner = n                            in ucFirst ns <> owner           in (SignalRef ownerCName sn,-              ModuleLinkWithAnchor (Just sn') mod ("signal:" <> sn'))+              ModuleLinkWithAnchor (Just sn') mod ("g:signal:" <> sn'))  -- | Given an optional C type and the API constructor construct the -- list of associated refs.

@@ -92,13 +92,20 @@   let name' = upperName n    group $ do+    line $ "type instance O.ParentTypes " <> name' <> " = '[]"+    bline $ "instance O.HasParentTypes " <> name'++  group $ do     line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>             typeInit <> " :: "     indent $ line "IO GType"   group $ do-       bline $ "instance BoxedEnum " <> name' <> " where"-       indent $ line $ "boxedEnumType _ = c_" <> typeInit+       bline $ "instance B.Types.TypedObject " <> name' <> " where"+       indent $ line $ "glibType = c_" <> typeInit +  group $ do+    bline $ "instance B.Types.BoxedEnum " <> name'+ genEnum :: Name -> Enumeration -> CodeGen () genEnum n@(Name _ name) enum = do   line $ "-- Enum " <> name@@ -117,12 +124,19 @@   let name' = upperName n    group $ do+    line $ "type instance O.ParentTypes " <> name' <> " = '[]"+    bline $ "instance O.HasParentTypes " <> name'++  group $ do     line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>             typeInit <> " :: "     indent $ line "IO GType"   group $ do-       bline $ "instance BoxedFlags " <> name' <> " where"-       indent $ line $ "boxedFlagsType _ = c_" <> typeInit+       bline $ "instance B.Types.TypedObject " <> name' <> " where"+       indent $ line $ "glibType = c_" <> typeInit++  group $ do+    bline $ "instance B.Types.BoxedFlags " <> name'  -- | Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass.

@@ -5,8 +5,10 @@     , detectGObject     , dropDuplicatedFields     , checkClosureDestructors+    , fixSymbolNaming     ) where +import Data.Char (generalCategory, GeneralCategory(UppercaseLetter)) import Data.Maybe (isNothing, isJust) #if !MIN_VERSION_base(4,13,0) import Data.Monoid ((<>))@@ -185,3 +187,27 @@         checkArg arg = if argDestroy arg >= 0 && argClosure arg == -1                        then arg {argDestroy = -1}                        else arg++-- | Some symbols have names that are not valid Haskell identifiers,+-- fix that here.+fixSymbolNaming :: (Name, API) -> (Name, API)+fixSymbolNaming (n, APIConst c) = (fixConstantName n, APIConst c)+fixSymbolNaming (n, api) = (n, api)++-- | Make sure that the given name is a valid Haskell identifier in+-- patterns.+--+-- === __Examples__+-- >>> fixConstantName (Name "IBus" "0")+-- Name {namespace = "IBus", name = "C'0"}+--+-- >>> fixConstantName (Name "IBus" "a")+-- Name {namespace = "IBus", name = "C'a"}+--+-- >>> fixConstantName (Name "IBus" "A")+-- Name {namespace = "IBus", name = "A"}+fixConstantName :: Name -> Name+fixConstantName (Name ns n)+  | not (T.null n) && generalCategory (T.head n) /= UppercaseLetter+  = Name ns ("C'" <> n)+  | otherwise = Name ns n

@@ -32,6 +32,7 @@            or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs       _ -> return False +-- | Check whether the given type descends from GObject. isGObject :: Type -> CodeGen Bool isGObject = typeDoParentSearch $ Name "GObject" "Object" @@ -39,5 +40,6 @@ nameIsGObject :: Name -> CodeGen Bool nameIsGObject n = findAPIByName n >>= apiIsGObject n +-- | Check whether the given API descends from GObject. apiIsGObject :: Name -> API -> CodeGen Bool apiIsGObject = apiDoParentSearch $ Name "GObject" "Object"

@@ -81,7 +81,7 @@ formatUnknownCRef _ (ParamRef p) = "/@" <> lowerSymbol p <> "@/" formatUnknownCRef _ (LocalSignalRef s) =   let sn = signalHaskellName s-  in "[" <> sn <> "](#signal:" <> sn <> ")"+  in "[" <> sn <> "](#g:signal:" <> sn <> ")" formatUnknownCRef c2h (SignalRef owner signal) =   case M.lookup (TypeRef owner) c2h of     Nothing -> formatCRef $ owner <> "::" <> signal

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies, DataKinds #-} -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository     ( girRequire@@ -29,9 +30,11 @@ import System.FilePath (searchPathSeparator)  import Data.GI.Base.BasicConversions (withTextCString, cstringToText)-import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType, ManagedPtr)+import Data.GI.Base.BasicTypes (TypedObject(..), GBoxed,+                                GType(..), CGType, ManagedPtr) import Data.GI.Base.GError (GError, checkGError) import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)+import Data.GI.Base.Overloading (HasParentTypes, ParentTypes) import Data.GI.Base.Utils (allocMem, freeMem) import Data.GI.CodeGen.Util (splitOn) @@ -55,10 +58,18 @@       fieldInfoOffset    :: Int     } +-- | The (empty) set of parent types for `BaseInfo` visible to the+-- Haskell type system.+instance HasParentTypes BaseInfo+type instance ParentTypes BaseInfo = '[]+ foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType -instance BoxedObject BaseInfo where-    boxedType _ = c_g_base_info_gtype_get_type+instance TypedObject BaseInfo where+  glibType = c_g_base_info_gtype_get_type++-- | `BaseInfo`s are registered as boxed in the GLib type system.+instance GBoxed BaseInfo  foreign import ccall "g_irepository_prepend_search_path" g_irepository_prepend_search_path :: CString -> IO () 

@@ -44,6 +44,7 @@    TParamSpec -> return "ParamSpec"    TGClosure _ -> return "Closure"    TError -> return "GError"+   TGValue -> return "GValue"    TBasicType TInt -> case sizeOf (0 :: CInt) of                         4 -> return "Int32"                         n -> error ("Unsupported `gint' type length: " ++

@@ -331,8 +331,8 @@                line $ "return " <> result'  genCallback :: Name -> Callback -> CodeGen ()-genCallback n (Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do-  let name' = upperName n+genCallback n callback@(Callback {cbCallable = cb, cbDocumentation = cbDoc }) = do+  let Name _ name' = normalizedAPIName (APICallback callback) n       cb' = fixupCallerAllocates cb    line $ "-- callback " <> name'

@@ -5,6 +5,7 @@                               , extractCallbacksInStruct                               , fixAPIStructs                               , ignoreStruct+                              , genBoxed                               , genWrappedPtr                               ) where @@ -455,7 +456,7 @@       line $ builder <> " = liftIO $ " <>            if isBoxed            then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name-           else "wrappedPtrCalloc >>= wrapPtr " <> name+           else "boxedPtrCalloc >>= wrapPtr " <> name       exportDecl builder        blank@@ -491,57 +492,102 @@            <> " :: " <> prototype   return (prefix <> symbol) --- | Same as `prefixedForeignImport`, but import a `FunPtr` to the symbol.-prefixedFunPtrImport :: Text -> Text -> Text -> CodeGen Text-prefixedFunPtrImport prefix symbol prototype = group $ do-  line $ "foreign import ccall \"&" <> symbol <> "\" " <> prefix <> symbol-           <> " :: FunPtr (" <> prototype <> ")"-  return (prefix <> symbol)+-- | Generate a GValue instance for @GBoxed@ objects.+genBoxedGValueInstance :: Name -> Text -> CodeGen ()+genBoxedGValueInstance n get_type_fn = do+  let name' = upperName n+      doc = "Convert '" <> name' <> "' to and from 'Data.GI.Base.GValue.GValue' with 'Data.GI.Base.GValue.toGValue' and 'Data.GI.Base.GValue.fromGValue'." +  writeHaddock DocBeforeSymbol doc++  group $ do+    bline $ "instance B.GValue.IsGValue " <> name' <> " where"+    indent $ group $ do+      line $ "toGValue o = do"+      indent $ group $ do+        line $ "gtype <- " <> get_type_fn+        line $ "B.ManagedPtr.withManagedPtr o (B.GValue.buildGValue gtype B.GValue.set_boxed)"+      line $ "fromGValue gv = do"+      indent $ group $ do+        line $ "ptr <- B.GValue.get_boxed gv :: IO (Ptr " <> name' <> ")"+        line $ "B.ManagedPtr.newBoxed " <> name' <> " ptr"++-- | Allocation and deallocation for types registered as `GBoxed` in+-- the GLib type system.+genBoxed :: Name -> Text -> CodeGen ()+genBoxed n typeInit = do+  let name' = upperName n+      get_type_fn = "c_" <> typeInit++  group $ do+    line $ "foreign import ccall \"" <> typeInit <> "\" " <>+            get_type_fn <> " :: "+    indent $ line "IO GType"++  group $ do+    line $ "type instance O.ParentTypes " <> name' <> " = '[]"+    bline $ "instance O.HasParentTypes " <> name'++  group $ do+    bline $ "instance B.Types.TypedObject " <> name' <> " where"+    indent $ line $ "glibType = " <> get_type_fn++  group $ do+    bline $ "instance B.Types.GBoxed " <> name'++  genBoxedGValueInstance n get_type_fn+ -- | Generate the typeclass with information for how to--- allocate/deallocate a given type.+-- allocate/deallocate a given type which is not a `GBoxed`. genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen () genWrappedPtr n info size = group $ do-  let name' = upperName n-   let prefix = \op -> "_" <> name' <> "_" <> op <> "_"    when (size == 0 && allocFree info == AllocationOpUnknown) $        line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?" -  calloc <- case allocCalloc info of-              AllocationOp "none" ->-                  return ("error \"calloc not permitted for " <> name' <> "\"")-              AllocationOp op ->-                  prefixedForeignImport (prefix "calloc") op "IO (Ptr a)"-              AllocationOpUnknown ->-                  if size > 0-                  then return ("callocBytes " <> tshow size)-                  else return "return nullPtr"-   copy <- case allocCopy info of             AllocationOp op -> do                 copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)"-                return ("\\p -> withManagedPtr p (" <> copy <>-                        " >=> wrapPtr " <> name' <> ")")+                return ("\\p -> B.ManagedPtr.withManagedPtr p (" <> copy <>+                        " >=> B.ManagedPtr.wrapPtr " <> name' <> ")")             AllocationOpUnknown ->                 if size > 0-                then return ("\\p -> withManagedPtr p (copyBytes "-                              <> tshow size <> " >=> wrapPtr " <> name' <> ")")+                then return ("\\p -> B.ManagedPtr.withManagedPtr p (copyBytes "+                              <> tshow size <>+                              " >=> B.ManagedPtr.wrapPtr " <> name' <> ")")                 else return "return"    free <- case allocFree info of-            AllocationOp op -> ("Just " <>) <$>-                prefixedFunPtrImport (prefix "free") op "Ptr a -> IO ()"+            AllocationOp op -> do+              free <- prefixedForeignImport (prefix "free") op "Ptr a -> IO ()"+              return $ "\\p -> B.ManagedPtr.withManagedPtr p " <> free             AllocationOpUnknown ->                 if size > 0-                then return "Just ptr_to_g_free"-                else return "Nothing"+                then return "\\x -> SP.withManagedPtr x SP.freeMem"+                else return "\\_x -> return ()" -  line $ "instance WrappedPtr " <> name' <> " where"+  bline $ "instance BoxedPtr " <> name' <> " where"   indent $ do-      line $ "wrappedPtrCalloc = " <> calloc-      line $ "wrappedPtrCopy = " <> copy-      line $ "wrappedPtrFree = " <> free+      line $ "boxedPtrCopy = " <> copy+      line $ "boxedPtrFree = " <> free -  hsBoot $ line $ "instance WrappedPtr " <> name' <> " where"+  case allocCalloc info of+    AllocationOp "none" -> return ()+    AllocationOp op -> do+      calloc <- prefixedForeignImport (prefix "calloc") op "IO (Ptr a)"+      callocInstance calloc+    AllocationOpUnknown ->+      if size > 0+      then do+        let calloc = "callocBytes " <> tshow size+        callocInstance calloc+      else return ()++  where name' = upperName n++        callocInstance :: Text -> CodeGen()+        callocInstance calloc = group $ do+          bline $ "instance CallocPtr " <> name' <> " where"+          indent $ do+            line $ "boxedPtrCalloc = " <> calloc

@@ -3,7 +3,6 @@     ( lowerName     , lowerSymbol     , upperName-    , noName     , escapedArgName      , classConstraint@@ -27,6 +26,7 @@     , submoduleLocation     , qualifiedAPI     , qualifiedSymbol+    , normalizedAPIName     ) where  #if !MIN_VERSION_base(4,11,0)@@ -36,8 +36,7 @@ import qualified Data.Text as T  import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code (CodeGen, group, line, exportDecl,-                             qualified, getAPI)+import Data.GI.CodeGen.Code (CodeGen, qualified, getAPI) import Data.GI.CodeGen.ModulePath (ModulePath, (/.), toModulePath) import Data.GI.CodeGen.Type (Type(TInterface)) import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified)@@ -147,29 +146,31 @@ submoduleLocation n (APIStruct _) = "Structs" /. upperName n submoduleLocation n (APIUnion _) = "Unions" /. upperName n +-- | Construct the Haskell version of the name associated to the given+-- API.+normalizedAPIName :: API -> Name -> Name+normalizedAPIName (APIConst _) (Name ns name) = Name ns (ucFirst name)+normalizedAPIName (APIFunction _) n = n+normalizedAPIName (APICallback _) n@(Name ns _) = Name ns (upperName n)+normalizedAPIName (APIEnum _) n@(Name ns _) = Name ns (upperName n)+normalizedAPIName (APIFlags _) n@(Name ns _) = Name ns (upperName n)+normalizedAPIName (APIInterface _) n@(Name ns _) = Name ns (upperName n)+normalizedAPIName (APIObject _) n@(Name ns _) = Name ns (upperName n)+normalizedAPIName (APIStruct _) n@(Name ns _) = Name ns (upperName n)+normalizedAPIName (APIUnion _) n@(Name ns _) = Name ns (upperName n)+ -- | Return an identifier for the given interface type valid in the current -- module.-qualifiedAPI :: Name -> CodeGen Text-qualifiedAPI n@(Name ns _) = do-  api <- getAPI (TInterface n)-  qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) n+qualifiedAPI :: API -> Name -> CodeGen Text+qualifiedAPI api n@(Name ns _) =+  let normalized = normalizedAPIName api n+  in qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) normalized  -- | Construct an identifier for the given symbol in the given API. qualifiedSymbol :: Text -> Name -> CodeGen Text qualifiedSymbol s n@(Name ns _) = do   api <- getAPI (TInterface n)   qualified (toModulePath (ucFirst ns) <> submoduleLocation n api) (Name ns s)---- | Save a bit of typing for optional arguments in the case that we--- want to pass Nothing.-noName :: Text -> CodeGen ()-noName name' = group $ do-  -- We should use `writeHaddock` here, but it would give rise to a-  -- cyclic import.-  line $ "-- | A convenience alias for `Nothing` :: `Maybe` `" <> name' <> "`."-  line $ "no" <> name' <> " :: Maybe " <> name'-  line $ "no" <> name' <> " = Nothing"-  exportDecl ("no" <> name')  -- | Turn a hyphen-separated identifier into camel case. --

@@ -43,6 +43,7 @@ basicFreeFn (TGHash _ _) = Just "unrefGHashTable" basicFreeFn (TError) = Nothing basicFreeFn (TVariant) = Nothing+basicFreeFn (TGValue) = Just "B.GValue.unsetGValue" basicFreeFn (TParamSpec) = Nothing basicFreeFn (TGClosure _) = Nothing @@ -61,6 +62,10 @@ basicFreeFnOnError TParamSpec transfer =     return $ if transfer == TransferEverything              then Just "unrefGParamSpec"+             else Nothing+basicFreeFnOnError TGValue transfer =+    return $ if transfer == TransferEverything+             then Just "SP.freeMem"              else Nothing basicFreeFnOnError (TGClosure _) transfer =     return $ if transfer == TransferEverything

@@ -54,6 +54,7 @@     = TBasicType BasicType     | TError           -- ^ GError     | TVariant         -- ^ GVariant+    | TGValue          -- ^ GValue     | TParamSpec       -- ^ GParamSpec     | TCArray Bool Int Int Type  -- ^ Zero terminated, Array Fixed                                  -- Size, Array Length, Element Type

@@ -17,6 +17,8 @@     objTypeInit :: Text,     objTypeName :: Text,     objCType :: Maybe Text,+    objRefFunc :: Maybe Text,+    objUnrefFunc :: Maybe Text,     objInterfaces :: [Name],     objDeprecated :: Maybe DeprecationInfo,     objDocumentation :: Documentation,@@ -39,12 +41,17 @@   typeInit <- getAttrWithNamespace GLibGIRNS "get-type"   typeName <- getAttrWithNamespace GLibGIRNS "type-name"   signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal+  refFunc <- queryAttrWithNamespace GLibGIRNS "ref-func"+  unrefFunc <- queryAttrWithNamespace GLibGIRNS "unref-func"+   ctype <- queryCType   return (name,          Object {             objParent = parent           , objTypeInit = typeInit           , objCType = ctype+          , objRefFunc = refFunc+          , objUnrefFunc = unrefFunc           , objTypeName = typeName           , objInterfaces = interfaces           , objDeprecated = deprecated

@@ -120,6 +120,7 @@ parseFundamentalType "GLib" "Error" = return TError parseFundamentalType "GLib" "Variant" = return TVariant parseFundamentalType "GObject" "ParamSpec" = return TParamSpec+parseFundamentalType "GObject" "Value" = return TGValue parseFundamentalType "GObject" "Closure" = parseClosure -- A TInterface type (basically, everything that is not of a known type). parseFundamentalType ns n = resolveQualifiedTypeName (Name ns n)