packages feed

haskell-gi 0.9 → 0.10

raw patch · 12 files changed

+787/−88 lines, 12 filesdep ~haskell-gi-base

Dependency ranges changed: haskell-gi-base

Files

LICENSE view
@@ -454,49 +454,3 @@ FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.--                     END OF TERMS AND CONDITIONS--           How to Apply These Terms to Your New Libraries--  If you develop a new library, and you want it to be of the greatest-possible use to the public, we recommend making it free software that-everyone can redistribute and change.  You can do so by permitting-redistribution under these terms (or, alternatively, under the terms of the-ordinary General Public License).--  To apply these terms, attach the following notices to the library.  It is-safest to attach them to the start of each source file to most effectively-convey the exclusion of warranty; and each file should have at least the-"copyright" line and a pointer to where the full notice is found.--    <one line to give the library's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    This library is free software; you can redistribute it and/or-    modify it under the terms of the GNU Lesser General Public-    License as published by the Free Software Foundation; either-    version 2.1 of the License, or (at your option) any later version.--    This library is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU-    Lesser General Public License for more details.--    You should have received a copy of the GNU Lesser General Public-    License along with this library; if not, write to the Free Software-    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA--Also add information on how to contact you by electronic and paper mail.--You should also get your employer (if you work as a programmer) or your-school, if any, to sign a "copyright disclaimer" for the library, if-necessary.  Here is a sample; alter the names:--  Yoyodyne, Inc., hereby disclaims all copyright interest in the-  library `Frob' (a library for tweaking knobs) written by James Random Hacker.--  <signature of Ty Coon>, 1 April 1990-  Ty Coon, President of Vice--That's all there is to it!
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name:                haskell-gi-version:             0.9+version:             0.10 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.@@ -36,20 +36,24 @@                        bytestring,                        xdg-basedir,                        xml-conduit >= 1.3.0,-                       haskell-gi-base == 0.9,+                       haskell-gi-base == 0.10,                        text >= 1.0,                        free    build-tools:         hsc2hs, c2hs   hs-source-dirs:      src   other-modules:       GI.GIR.Alias,+                       GI.GIR.Arg,                        GI.GIR.BasicTypes,+                       GI.GIR.Callable,                        GI.GIR.Callback,                        GI.GIR.Constant,                        GI.GIR.Deprecation,                        GI.GIR.Enum,                        GI.GIR.Field,                        GI.GIR.Flags,+                       GI.GIR.Function,+                       GI.GIR.Interface,                        GI.GIR.Method,                        GI.GIR.Object,                        GI.GIR.Parser,@@ -64,18 +68,19 @@                        GI.Cabal,                        GI.Callable,                        GI.Code,+                       GI.CodeGen,                        GI.Config,                        GI.Constant,                        GI.Conversions,                        GI.GObject,                        GI.GType,                        GI.Inheritance,+                       GI.LibGIRepository,                        GI.OverloadedSignals,                        GI.Overrides,                        GI.PkgConfig,                        GI.ProjectInfo,                        GI.Properties,-                       GI.LibGIRepository,                        GI.Signal,                        GI.Struct,                        GI.SymbolNaming,
src/GI/Cabal.hs view
@@ -12,10 +12,7 @@ import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))-import Data.Version (Version(..),  showVersion)-#if MIN_VERSION_base(4,8,0)-import Data.Version (makeVersion)-#endif+import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text)@@ -44,22 +41,25 @@ haskellGIAPIVersion :: Int haskellGIAPIVersion = (head . versionBranch) version -#if !MIN_VERSION_base(4,8,0)--- Create a version without tags, which we ignore anyway. The--- versionTags constructor field is deprecated in base 4.8.0.-makeVersion :: [Int] -> Version-makeVersion branch = Version branch []-#endif+-- | Obtain the minor version. That is, if the given version numbers+-- are x.y.z, so branch is [x,y,z], we return y.+minorVersion :: [Int] -> Int+minorVersion (_:y:_) = y+minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "." -haskellGIRevision :: String-haskellGIRevision =-    showVersion $ makeVersion (tail (versionBranch version))+-- | Obtain the haskell-gi minor version. Notice that we only append+-- the minor version here, ignoring revisions. (So if the version is+-- x.y.z, we drop the "z" part.) This gives us a mechanism for+-- releasing bug-fix releases of haskell-gi without increasing the+-- necessary dependency on haskell-gi-base, which only depends on x.y.+haskellGIMinor :: Int+haskellGIMinor = minorVersion (versionBranch version)  {- | -If the haskell-gi version is of the form x.y and the pkgconfig version-of the package being wrapped is a.b.c, this gives something of the-form x.a.b.y.+If the haskell-gi version is of the form x.y[.z] and the pkgconfig+version of the package being wrapped is a.b.c, this gives something of+the form x.a.b.y.  This strange seeming-rule is so that the packages that we produce follow the PVP, assuming that the package being wrapped follows the@@ -84,7 +84,7 @@ giModuleVersion :: Int -> Int -> Text giModuleVersion major minor = T.pack $     show haskellGIAPIVersion ++ "." ++ show major ++ "."-             ++ show minor ++ "." ++ haskellGIRevision+             ++ show minor ++ "." ++ show haskellGIMinor  -- | Smallest version not backwards compatible with the current -- version (according to PVP).@@ -157,10 +157,11 @@                intercalate ", " [base, base ++ "Attributes", base ++ "Signals"]         line $ padTo 20 "pkgconfig-depends:" ++ T.unpack pcName ++ " >= "                  ++ show major ++ "." ++ show minor-        line $ padTo 20 "build-depends: base >= 4.6 && <4.9,"+        line $ padTo 20 "build-depends: base >= 4.7 && <5,"         indent $ do-          line $ "haskell-gi-base >= " ++ showVersion version-                 ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ ","+          line $ "haskell-gi-base >= "+                   ++ show haskellGIAPIVersion ++ "." ++ show haskellGIMinor+                   ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ ","           forM_ deps $ \dep -> do               let depName = girNSName dep                   depVersion = girNSVersion dep
src/GI/Callable.hs view
@@ -17,7 +17,7 @@ import Data.Bool (bool) import Data.List (intercalate, nub, (\\)) import Data.Maybe (isJust)-import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)+import Data.Typeable (TypeRep, typeOf) import qualified Data.Map as Map import qualified Data.Text as T import Data.Text (Text)@@ -90,9 +90,13 @@            -- type.            TGList _ -> return False            TGSList _ -> return False-           _ -> if isNullable (argType arg)-                then return True-                else badIntroError $ "argument \"" ++ T.unpack (argName arg) ++ "\" is not of nullable type, but it is marked as such."+           _ -> do+             nullable <- isNullable (argType arg)+             if nullable+             then return True+             else badIntroError $ "argument \"" ++ T.unpack (argName arg)+                      ++ "\" is not of nullable type (" ++ show (argType arg)+                      ++ "), but it is marked as such."     else return False  -- Given the list of arguments returns the list of constraints and the@@ -299,10 +303,10 @@                                         prefix ++ lcFirst n ++ "Wrapper")                         _ -> error $ "prepareInCallback : Not an interface! " ++ ppShow arg -  fC <- tyConName <$> typeRepTyCon <$> foreignType (argType arg)+  when (scope == ScopeTypeAsync) $ do+   ft <- show <$> foreignType (argType arg)+   line $ ptrName ++ " <- callocMem :: IO (Ptr (" ++ ft ++ "))" -  when (scope == ScopeTypeAsync) $-       line $ ptrName ++ " <- callocBytes $ sizeOf (undefined :: " ++ fC ++ ")"   wrapMaybe arg >>= bool             (do               let name' = prime name@@ -609,7 +613,7 @@     convertResult :: Map.Map String String -> ExcCodeGen String     convertResult nameMap =         if ignoreReturn || returnType callable == TBasicType TVoid-        then return undefined+        then return (error "convertResult: unreachable code reached, bug!")         else do             if returnMayBeNull callable             then do@@ -618,7 +622,12 @@                     converted <- unwrappedConvertResult "result'"                     line $ "return " ++ converted                 return "maybeResult"-            else unwrappedConvertResult "result"+            else do+              nullable <- isNullable (returnType callable)+              when nullable $+                 line $ "checkUnexpectedReturnNULL \"" ++ T.unpack symbol+                          ++ "\" result"+              unwrappedConvertResult "result"          where         unwrappedConvertResult rname = case returnType callable of
+ src/GI/CodeGen.hs view
@@ -0,0 +1,518 @@+module GI.CodeGen+    ( genConstant+    , genFunction+    , genPrelude+    , genModule+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Traversable (traverse)+#endif+import Control.Monad (forM, forM_, when, unless, filterM)+import Control.Monad.Writer (tell)+import Data.List (intercalate, nub)+import Data.Tuple (swap)+import Data.Maybe (fromJust, fromMaybe)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)++import Foreign.Storable (sizeOf)+import Foreign.C (CUInt)++import GI.API+import GI.Callable (genCallable)+import GI.Constant (genConstant)+import GI.Code+import GI.GObject+import GI.Inheritance (instanceTree)+import GI.Signal (genSignal, genCallback)+import GI.Struct (genStructOrUnionFields, extractCallbacksInStruct,+                  fixAPIStructs, ignoreStruct)+import GI.SymbolNaming (upperName, ucFirst, classConstraint, noName)+import GI.Type++genFunction :: Name -> Function -> CodeGen ()+genFunction n (Function symbol throws callable) = do+  line $ "-- function " ++ T.unpack symbol+  handleCGExc (\e -> line ("-- XXX Could not generate function "+                           ++ T.unpack symbol+                           ++ "\n-- Error was : " ++ describeCGError e))+              (genCallable n symbol callable throws)++genBoxedObject :: Name -> Text -> CodeGen ()+genBoxedObject n typeInit = do+  name' <- upperName n++  group $ do+    line $ "foreign import ccall \"" ++ T.unpack typeInit ++ "\" c_" +++            T.unpack typeInit ++ " :: "+    indent $ line "IO GType"+  group $ do+       line $ "instance BoxedObject " ++ name' ++ " where"+       indent $ line $ "boxedType _ = c_" ++ T.unpack typeInit++genBoxedEnum :: Name -> Text -> CodeGen ()+genBoxedEnum n typeInit = do+  name' <- upperName n++  group $ do+    line $ "foreign import ccall \"" ++ T.unpack typeInit ++ "\" c_" +++            T.unpack typeInit ++ " :: "+    indent $ line "IO GType"+  group $ do+       line $ "instance BoxedEnum " ++ name' ++ " where"+       indent $ line $ "boxedEnumType _ = c_" ++ T.unpack typeInit++genEnumOrFlags :: Name -> Enumeration -> ExcCodeGen ()+genEnumOrFlags n@(Name ns name) (Enumeration fields eDomain maybeTypeInit storageBytes isDeprecated) = do+  -- Conversion functions expect enums and flags to map to CUInt,+  -- which we assume to be of 32 bits. Fail early, instead of giving+  -- strange errors at runtime.+  when (sizeOf (0 :: CUInt) /= 4) $+       notImplementedError $ "Unsupported CUInt size: " ++ show (sizeOf (0 :: CUInt))+  when (storageBytes /= 4) $+       notImplementedError $ "Storage of size /= 4 not supported : " ++ show storageBytes++  name' <- upperName n+  fields' <- forM fields $ \(fieldName, value) -> do+      n <- upperName $ Name ns (name ++ "_" ++ T.unpack fieldName)+      return (n, value)++  line $ deprecatedPragma name' isDeprecated++  group $ do+    line $ "data " ++ name' ++ " = "+    indent $+      case fields' of+        ((fieldName, _value):fs) -> do+          line $ "  " ++ fieldName+          forM_ fs $ \(n, _) -> line $ "| " ++ n+          line $ "| Another" ++ name' ++ " Int"+          line "deriving (Show, Eq)"+        _ -> return ()+  group $ do+    line $ "instance Enum " ++ name' ++ " where"+    indent $ do+            forM_ fields' $ \(n, v) ->+                line $ "fromEnum " ++ n ++ " = " ++ show v+            line $ "fromEnum (Another" ++ name' ++ " k) = k"+    let valueNames = M.toList . M.fromListWith (curry snd) $ map swap fields'+    blank+    indent $ do+            forM_ valueNames $ \(v, n) ->+                line $ "toEnum " ++ show v ++ " = " ++ n+            line $ "toEnum k = Another" ++ name' ++ " k"+  maybe (return ()) (genErrorDomain name') eDomain+  maybe (return ()) (genBoxedEnum n) maybeTypeInit++genEnum :: Name -> Enumeration -> CodeGen ()+genEnum n@(Name _ name) enum = do+  line $ "-- Enum " ++ name++  handleCGExc (\e -> line $ "-- XXX Could not generate: " ++ describeCGError e)+              (genEnumOrFlags n enum)++-- Very similar to enums, but we also declare ourselves as members of+-- the IsGFlag typeclass.+genFlags :: Name -> Flags -> CodeGen ()+genFlags n@(Name _ name) (Flags enum) = do+  line $ "-- Flags " ++ name++  handleCGExc (\e -> line $ "-- XXX Could not generate: " ++ describeCGError e)+              (do+                genEnumOrFlags n enum++                name' <- upperName n+                group $ line $ "instance IsGFlag " ++ name')++genErrorDomain :: String -> Text -> CodeGen ()+genErrorDomain name' domain = do+  group $ do+    line $ "instance GErrorClass " ++ name' ++ " where"+    indent $ line $+               "gerrorClassDomain _ = \"" ++ T.unpack domain ++ "\""+  -- Generate type specific error handling (saves a bit of typing, and+  -- it's clearer to read).+  group $ do+    let catcher = "catch" ++ name'+    line $ catcher ++ " ::"+    indent $ do+            line   "IO a ->"+            line $ "(" ++ name' ++ " -> GErrorMessage -> IO a) ->"+            line   "IO a"+    line $ catcher ++ " = catchGErrorJustDomain"+  group $ do+    let handler = "handle" ++ name'+    line $ handler ++ " ::"+    indent $ do+            line $ "(" ++ name' ++ " -> GErrorMessage -> IO a) ->"+            line   "IO a ->"+            line   "IO a"+    line $ handler ++ " = handleGErrorJustDomain"++genStruct :: Name -> Struct -> CodeGen ()+genStruct n s = unless (ignoreStruct n s) $ do+      name' <- upperName n+      line $ "-- struct " ++ name'++      line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"++      noName name'++      when (structIsBoxed s) $+           genBoxedObject n (fromJust $ structTypeInit s)++      -- Generate code for fields.+      genStructOrUnionFields n (structFields s)++      -- Methods+      forM_ (structMethods s) $ \(mn, f) ->+          do isFunction <- symbolFromFunction (methodSymbol f)+             unless isFunction $+                  handleCGExc+                  (\e -> line ("-- XXX Could not generate method "+                               ++ name' ++ "::" ++ name mn ++ "\n"+                               ++ "-- Error was : " ++ describeCGError e))+                  (genMethod n mn f)++genUnion :: Name -> Union -> CodeGen ()+genUnion n u = do+  name' <- upperName n++  line $ "-- union " ++ name' ++ " "++  line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"++  noName name'++  when (unionIsBoxed u) $+    genBoxedObject n (fromJust $ unionTypeInit u)++  -- Generate code for fields.+  genStructOrUnionFields n (unionFields u)++  -- Methods+  forM_ (unionMethods u) $ \(mn, f) ->+      do isFunction <- symbolFromFunction (methodSymbol f)+         unless isFunction $+              handleCGExc+              (\e -> line ("-- XXX Could not generate method "+                           ++ name' ++ "::" ++ name mn ++ "\n"+                           ++ "-- Error was : " ++ describeCGError e))+              (genMethod n mn f)++-- Add the implicit object argument to methods of an object.  Since we+-- are prepending an argument we need to adjust the offset of the+-- length arguments of CArrays, and closure and destroyer offsets.+fixMethodArgs :: Name -> Callable -> Callable+fixMethodArgs cn c = c {  args = args' , returnType = returnType' }+    where+      returnType' = fixCArrayLength $ returnType c+      args' = objArg : map (fixDestroyers . fixClosures . fixLengthArg) (args c)++      fixLengthArg :: Arg -> Arg+      fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)}++      fixCArrayLength :: Type -> Type+      fixCArrayLength (TCArray zt fixed length t) =+          if length > -1+          then TCArray zt fixed (length+1) t+          else TCArray zt fixed length t+      fixCArrayLength t = t++      fixDestroyers :: Arg -> Arg+      fixDestroyers arg = let destroy = argDestroy arg in+                          if destroy > -1+                          then arg {argDestroy = destroy + 1}+                          else arg++      fixClosures :: Arg -> Arg+      fixClosures arg = let closure = argClosure arg in+                        if closure > -1+                        then arg {argClosure = closure + 1}+                        else arg++      objArg = Arg {+                 argName = "_obj",+                 argType = TInterface (namespace cn) (name cn),+                 direction = DirectionIn,+                 mayBeNull = False,+                 argScope = ScopeTypeInvalid,+                 argClosure = -1,+                 argDestroy = -1,+                 transfer = TransferNothing }++-- For constructors we want to return the actual type of the object,+-- rather than a generic superclass (so Gtk.labelNew returns a+-- Gtk.Label, rather than a Gtk.Widget)+fixConstructorReturnType :: Bool -> Name -> Callable -> Callable+fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' }+    where+      returnType' = if returnsGObject then+                        TInterface (namespace cn) (name cn)+                    else+                        returnType c++genMethod :: Name -> Name -> Method -> ExcCodeGen ()+genMethod cn mn (Method {+                    methodSymbol = sym,+                    methodCallable = c,+                    methodType = t,+                    methodThrows = throws+                 }) = do+    name' <- upperName cn+    returnsGObject <- isGObject (returnType c)+    line $ "-- method " ++ name' ++ "::" ++ name mn+    line $ "-- method type : " ++ show t+    let -- Mangle the name to namespace it to the class.+        mn' = mn { name = name cn ++ "_" ++ name mn }+    let c'  = if Constructor == t+              then fixConstructorReturnType returnsGObject cn c+              else c+        c'' = if OrdinaryMethod == t+              then fixMethodArgs cn c'+              else c'+    genCallable mn' sym c'' throws++-- Type casting with type checking+genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen ()+genGObjectCasts isIU n cn_ parents = do+  name' <- upperName n+  qualifiedParents <- traverse upperName parents++  group $ do+    line $ "foreign import ccall \"" ++ T.unpack cn_ ++ "\""+    indent $ line $ "c_" ++ T.unpack cn_ ++ " :: IO GType"++  group $ do+    line $ "type instance ParentTypes " ++ name' ++ " = '[" +++         intercalate ", " qualifiedParents ++ "]"++  group $ do+    line $ "instance GObject " ++ name' ++ " where"+    indent $ group $ do+            line $ "gobjectIsInitiallyUnowned _ = " ++ show isIU+            line $ "gobjectType _ = c_" ++ T.unpack cn_++  let className = classConstraint name'+  group $ do+    line $ "class GObject o => " ++ className ++ " o"+    line $ "instance (GObject o, IsDescendantOf " ++ name' ++ " o) => "+             ++ className ++ " o"++  -- Safe downcasting.+  group $ do+    let safeCast = "to" ++ name'+    line $ safeCast ++ " :: " ++ className ++ " o => o -> IO " ++ name'+    line $ safeCast ++ " = unsafeCastTo " ++ name'++-- Wrap a given Object. We enforce that every Object that we wrap is a+-- GObject. This is the case for everything expect the ParamSpec* set+-- of objects, we deal with these separately. Notice that in the case+-- that a non-GObject Object is passed, it is simply ignored silently+-- by the handler in handleCGExc below.+genObject :: Name -> Object -> CodeGen ()+genObject n o = handleCGExc (\_ -> return ()) $ do+  name' <- upperName n++  line $ "-- object " ++ name' ++ " "++  let t = (\(Name ns' n') -> TInterface ns' n') n+  isGO <- isGObject t+  unless isGO $ notImplementedError $ "APIObject \"" ++ name' +++           "\" does not descend from GObject, it will be ignored."++  line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"++  noName name'++  -- Type safe casting to parent objects, and implemented interfaces.+  isIU <- isInitiallyUnowned t+  parents <- instanceTree n+  genGObjectCasts isIU n (objTypeInit o) (parents ++ objInterfaces o)++  -- Methods+  forM_ (objMethods o) $ \(mn, f) ->+         handleCGExc+         (\e -> line ("-- XXX Could not generate method "+                      ++ name' ++ "::" ++ name mn ++ "\n"+                      ++ "-- Error was : " ++ describeCGError e))+         (genMethod n mn f)++  -- And finally signals+  forM_ (objSignals o) $ \s ->+      handleCGExc+      (line . (concat ["-- XXX Could not generate signal ", name', "::"+                      , (T.unpack . sigName) s+                      , "\n", "-- Error was : "] ++) . describeCGError)+      (genSignal s n)++genInterface :: Name -> Interface -> CodeGen ()+genInterface n iface = do+  -- For each interface, we generate a class IFoo and a data structure+  -- Foo. We only really need a separate Foo so that we can return+  -- them from bound functions. In principle we might be able to do+  -- something more elegant with existential types.++  name' <- upperName n+  line $ "-- interface " ++ name' ++ " "+  line $ deprecatedPragma name' $ ifDeprecated iface+  line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"++  noName name'++  isGO <- apiIsGObject n (APIInterface iface)+  if isGO+  then do+    let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)+    isIU <- apiIsInitiallyUnowned n (APIInterface iface)+    gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)+    allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p+    let uniqueParents = nub (concat allParents)+    genGObjectCasts isIU n cn_ uniqueParents+  else group $ do+    let cls = classConstraint name'+    line $ "class ForeignPtrNewtype a => " ++ cls ++ " a"+    line $ "instance (ForeignPtrNewtype o, IsDescendantOf " ++ name' ++ " o) => " ++ cls ++ " o"+    line $ "type instance ParentTypes " ++ name' ++ " = '[]"++  -- Methods+  forM_ (ifMethods iface) $ \(mn, f) -> do+    isFunction <- symbolFromFunction (methodSymbol f)+    unless isFunction $+         handleCGExc+         (\e -> line ("-- XXX Could not generate method "+                      ++ name' ++ "::" ++ name mn ++ "\n"+                      ++ "-- Error was : " ++ describeCGError e))+         (genMethod n mn f)++  -- And finally signals+  forM_ (ifSignals iface) $ \s -> handleCGExc+        (line . (concat ["-- XXX Could not generate signal ", name', "::"+                        , (T.unpack . sigName) s+                        , "\n", "-- Error was : "] ++) . describeCGError)+        (genSignal s n)++-- 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, we don't+-- generate the method.+--+-- It may be more expedient to keep a map of symbol -> function.+--+-- XXX Maybe the GIR helps here? Sometimes such functions are+-- annotated with the "moved-to".+symbolFromFunction :: Text -> CodeGen Bool+symbolFromFunction sym = do+    apis <- getAPIs+    return $ any (hasSymbol sym . snd) $ M.toList apis+    where+        hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2 })) = sym1 == sym2+        hasSymbol _ _ = False++genAPI :: Name -> API -> CodeGen ()+genAPI n (APIConst c) = genConstant n c+genAPI n (APIFunction f) = genFunction n f+genAPI n (APIEnum e) = genEnum n e+genAPI n (APIFlags f) = genFlags n f+genAPI n (APICallback c) = genCallback n c+genAPI n (APIStruct s) = genStruct n s+genAPI n (APIUnion u) = genUnion n u+genAPI n (APIObject o) = genObject n o+genAPI n (APIInterface i) = genInterface n i++genPrelude :: String -> String -> CodeGen ()+genPrelude name modulePrefix = do+    let mp = (modulePrefix ++)++    line "-- Generated code."+    blank+    line "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"+    blank+    line "{-# LANGUAGE ForeignFunctionInterface, ConstraintKinds,"+    line "    TypeFamilies, MultiParamTypeClasses, KindSignatures,"+    line "    FlexibleInstances, UndecidableInstances, DataKinds,"+    line "    OverloadedStrings, NegativeLiterals, FlexibleContexts #-}"+    blank+    -- XXX: Generate export list.+    line $ "module " ++ mp name ++ " where"+    blank+    -- The Prelude functions often clash with variable names or+    -- functions defined in the bindings, so we only import the+    -- necessary minimum into our namespace.+    line "import Prelude ()"+    line "import Data.GI.Base.ShortPrelude"+    line "import Data.Char"+    line "import Data.Int"+    line "import Data.Word"+    line "import qualified Data.ByteString.Char8 as B"+    line "import Data.ByteString.Char8 (ByteString)"+    line "import qualified Data.Map as Map"+    line "import Foreign.C"+    line "import Foreign.Ptr"+    line "import Foreign.ForeignPtr"+    line "import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)"+    line "import Foreign.Storable (peek, poke, sizeOf)"+    line "import Control.Applicative ((<$>))"+    line "import Control.Exception (onException)"+    line "import Control.Monad.IO.Class"+    line "import qualified Data.Text as T"+    blank+    line "import Data.GI.Base.Attributes hiding (get, set)"+    line "import Data.GI.Base.BasicTypes"+    line "import Data.GI.Base.BasicConversions"+    line "import Data.GI.Base.Closure"+    line "import Data.GI.Base.GError"+    line "import Data.GI.Base.GHashTable"+    line "import Data.GI.Base.GParamSpec"+    line "import Data.GI.Base.GVariant"+    line "import Data.GI.Base.GValue"+    line "import Data.GI.Base.ManagedPtr"+    line "import Data.GI.Base.Overloading"+    line "import Data.GI.Base.Properties hiding (new)"+    line "import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId)"+    line "import Data.GI.Base.Utils"+    blank++genModule :: String -> [(Name, API)] -> String -> CodeGen ()+genModule name apis modulePrefix = do+  let mp = (modulePrefix ++)+      name' = ucFirst name++  -- Any module depends on itself, load the information onto the state+  -- of the monad. This has to be done early, so symbolFromFunction+  -- above has access to it. It would probably be better to prune the+  -- duplicated method/functions in advance, and get rid of+  -- symbolFromFunction and this loadDependency altogether.+  loadDependency name++  -- Some API symbols are embedded into structures, extract these and+  -- inject them into the set of APIs loaded and being generated.+  let embeddedAPIs = concatMap extractCallbacksInStruct apis+  injectAPIs embeddedAPIs++  code <- recurse' $ mapM_ (uncurry genAPI) $+          -- 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 $ (++ embeddedAPIs) apis++  genPrelude name' modulePrefix+  deps <- S.toList <$> getDeps+  forM_ deps $ \i -> when (i /= name) $ do+    line $ "import qualified " ++ mp (ucFirst i) ++ " as " ++ ucFirst i+    line $ "import qualified " ++ mp (ucFirst i) ++ "Attributes as "+             ++ ucFirst i ++ "A"+  blank++  tell code
src/GI/Conversions.hs view
@@ -698,8 +698,8 @@     api <- findAPI t     prefix <- qualify ns     return $ case api of-               Just (APICallback _) -> T.pack ("FunPtr " ++ prefix ++ n ++ "C")-                                       `con` []+               Just (APICallback _) ->+                   funptr $ T.pack (prefix ++ n ++ "C") `con` []                _ -> ptr $ T.pack (prefix ++ n) `con` []  getIsScalar :: Type -> CodeGen Bool@@ -737,12 +737,13 @@  -- Returns whether the given type is nullable in the C sense, -- i.e. whether it can be set to NULL.-isNullable :: Type -> Bool-isNullable (TBasicType TVoid) = True-isNullable (TBasicType TUTF8) = True-isNullable (TBasicType TFileName) = True-isNullable (TBasicType _) = False-isNullable _ = True+isNullable :: Type -> CodeGen Bool+isNullable (TBasicType TVoid) = return True+isNullable (TBasicType TUTF8) = return True+isNullable (TBasicType TFileName) = return True+isNullable t = do+  ft <- foreignType t+  return (tyConName (typeRepTyCon ft) `elem` ["Ptr", "FunPtr"])  -- If the given type maps to a list in Haskell, return the type of the -- elements, and the function that maps over them.
+ src/GI/GIR/Arg.hs view
@@ -0,0 +1,76 @@+module GI.GIR.Arg+    ( Arg(..)+    , Direction(..)+    , Scope(..)+    , parseArg+    , parseTransfer+    ) where++import Data.Monoid ((<>))+import Data.Text (Text)++import GI.GIR.BasicTypes (Transfer(..))+import GI.GIR.Parser+import GI.GIR.Type (parseType)+import GI.Type (Type)++data Direction = DirectionIn+               | DirectionOut+               | DirectionInout+                 deriving (Show, Eq, Ord)++data Scope = ScopeTypeInvalid+           | ScopeTypeCall+           | ScopeTypeAsync+           | ScopeTypeNotified+             deriving (Show, Eq, Ord)++data Arg = Arg {+        argName :: Text,+        argType :: Type,+        direction :: Direction,+        mayBeNull :: Bool,+        argScope :: Scope,+        argClosure :: Int,+        argDestroy :: Int,+        transfer :: Transfer+    } deriving (Show, Eq, Ord)++parseTransfer :: Parser Transfer+parseTransfer = getAttr "transfer-ownership" >>= \case+                "none" -> return TransferNothing+                "container" -> return TransferContainer+                "full" -> return TransferEverything+                t -> parseError $ "Unknown transfer type \"" <> t <> "\""++parseScope :: Text -> Parser Scope+parseScope "call" = return ScopeTypeCall+parseScope "async" = return ScopeTypeAsync+parseScope "notified" = return ScopeTypeNotified+parseScope s = parseError $ "Unknown scope type \"" <> s <> "\""++parseDirection :: Text -> Parser Direction+parseDirection "in" = return DirectionIn+parseDirection "out" = return DirectionOut+parseDirection "inout" = return DirectionInout+parseDirection d = parseError $ "Unknown direction \"" <> d <> "\""++parseArg :: Parser Arg+parseArg = do+  name <- getAttr "name"+  ownership <- parseTransfer+  scope <- optionalAttr "scope" ScopeTypeInvalid parseScope+  d <- optionalAttr "direction" DirectionIn parseDirection+  closure <- optionalAttr "closure" (-1) parseIntegral+  destroy <- optionalAttr "destroy" (-1) parseIntegral+  nullable <- optionalAttr "nullable" False parseBool+  t <- parseType+  return $ Arg { argName = name+               , argType = t+               , direction = d+               , mayBeNull = nullable+               , argScope = scope+               , argClosure = closure+               , argDestroy = destroy+               , transfer = ownership+               }
+ src/GI/GIR/Callable.hs view
@@ -0,0 +1,58 @@+module GI.GIR.Callable+    ( Callable(..)+    , parseCallable+    ) where++import GI.Type (Type)+import GI.GIR.Arg (Arg(..), parseArg, parseTransfer)+import GI.GIR.BasicTypes (Transfer(..))+import GI.GIR.Parser+import GI.GIR.Type (parseType)++data Callable = Callable {+        returnType :: Type,+        returnMayBeNull :: Bool,+        returnTransfer :: Transfer,+        args :: [Arg],+        skipReturn :: Bool,+        callableDeprecated :: Maybe DeprecationInfo+    } deriving (Show, Eq)++parseArgs :: Parser [Arg]+parseArgs = do+  paramSets <- parseChildrenWithLocalName "parameters" parseArgSet+  case paramSets of+    [] -> return []+    (ps:[]) -> return ps+    _ -> parseError $ "Unexpected multiple \"parameters\" tag"+  where parseArgSet = parseChildrenWithLocalName "parameter" parseArg++parseOneReturn :: Parser (Type, Bool, Transfer, Bool)+parseOneReturn = do+  returnType <- parseType+  mayBeNull <- optionalAttr "allow-none" False parseBool+  transfer <- parseTransfer+  skip <- optionalAttr "skip" False parseBool+  return (returnType, mayBeNull, transfer, skip)++parseReturn :: Parser (Type, Bool, Transfer, Bool)+parseReturn = do+  returnSets <- parseChildrenWithLocalName "return-value" parseOneReturn+  case returnSets of+    (r:[]) -> return r+    [] -> parseError $ "No return information found"+    _ -> parseError $ "Multiple return values found"++parseCallable :: Parser Callable+parseCallable = do+  args <- parseArgs+  (returnType, mayBeNull, transfer, skip) <- parseReturn+  deprecated <- parseDeprecation+  return $ Callable {+                  returnType = returnType+                , returnMayBeNull = mayBeNull+                , returnTransfer = transfer+                , args = args+                , skipReturn = skip+                , callableDeprecated = deprecated+                }
+ src/GI/GIR/Function.hs view
@@ -0,0 +1,33 @@+module GI.GIR.Function+    ( Function(..)+    , parseFunction+    ) where++import Data.Text (Text)+import qualified Data.Text as T++import GI.GIR.Callable (Callable(..), parseCallable)+import GI.GIR.Parser++data Function = Function {+        fnSymbol :: Text,+        fnThrows :: Bool,+        fnCallable :: Callable+    } deriving Show++parseFunction :: Parser (Name, Function)+parseFunction = do+  name <- parseName+  shadows <- queryAttr "shadows"+  let exposedName = case shadows of+                      Just n -> name {name = T.unpack n}+                      Nothing -> name+  callable <- parseCallable+  symbol <- getAttrWithNamespace CGIRNS "identifier"+  throws <- optionalAttr "throws" False parseBool+  return $ (exposedName,+            Function {+              fnSymbol = symbol+            , fnCallable = callable+            , fnThrows = throws+            })
+ src/GI/GIR/Interface.hs view
@@ -0,0 +1,40 @@+module GI.GIR.Interface+    ( Interface(..)+    , parseInterface+    ) where++import Data.Text (Text)++import GI.GIR.Method (Method, MethodType(..), parseMethod)+import GI.GIR.Property (Property, parseProperty)+import GI.GIR.Signal (Signal, parseSignal)+import GI.GIR.Parser++data Interface = Interface {+        ifTypeInit :: Maybe Text,+        ifPrerequisites :: [Name],+        ifProperties :: [Property],+        ifSignals :: [Signal],+        ifMethods :: [(Name, Method)],+        ifDeprecated :: Maybe DeprecationInfo+    } deriving Show++parseInterface :: Parser (Name, Interface)+parseInterface = do+  name <- parseName+  props <- parseChildrenWithLocalName "property" parseProperty+  signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal+  typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+  methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+  functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+  constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+  deprecated <- parseDeprecation+  return (name,+         Interface {+            ifProperties = props+          , ifPrerequisites = error ("unfixed interface " ++ show name)+          , ifSignals = signals+          , ifTypeInit = typeInit+          , ifMethods = constructors ++ methods ++ functions+          , ifDeprecated = deprecated+          })
src/GI/Type.hs view
@@ -4,6 +4,7 @@     , Type(..)     , io     , ptr+    , funptr     , con     , maybeT     ) where@@ -62,6 +63,9 @@  ptr :: TypeRep -> TypeRep ptr t = "Ptr" `con` [t]++funptr :: TypeRep -> TypeRep+funptr t = "FunPtr" `con` [t]  maybeT :: TypeRep -> TypeRep maybeT t = "Maybe" `con` [t]
src/haskell-gi.hs view
@@ -13,7 +13,7 @@ import Data.Text (pack, unpack, Text)  import System.Directory (createDirectoryIfMissing, doesFileExist)-import System.FilePath (splitPath, joinPath)+import System.FilePath (splitDirectories, joinPath) import System.Console.GetOpt import System.Exit import System.IO (hPutStr, hPutStrLn, stderr)@@ -99,7 +99,7 @@       Nothing -> return ("", ".")       Just dir -> do         createDirectoryIfMissing True dir-        let prefix = intercalate "." (splitPath dir) ++ "."+        let prefix = intercalate "." (splitDirectories dir) ++ "."         return (prefix, dir)  -- | Load the given API and dependencies, filtering them in the process.