haskell-gi 0.18 → 0.20
raw patch · 27 files changed
+1055/−582 lines, 27 filesdep +regex-tdfadep ~haskell-gi-base
Dependencies added: regex-tdfa
Dependency ranges changed: haskell-gi-base
Files
- haskell-gi.cabal +5/−2
- lib/Data/GI/CodeGen/API.hs +32/−13
- lib/Data/GI/CodeGen/Callable.hs +222/−110
- lib/Data/GI/CodeGen/Code.hs +20/−13
- lib/Data/GI/CodeGen/CodeGen.hs +32/−159
- lib/Data/GI/CodeGen/Constant.hs +1/−1
- lib/Data/GI/CodeGen/Conversions.hs +129/−49
- lib/Data/GI/CodeGen/EnumFlags.hs +147/−0
- lib/Data/GI/CodeGen/Fixups.hs +6/−6
- lib/Data/GI/CodeGen/GObject.hs +3/−4
- lib/Data/GI/CodeGen/Inheritance.hs +4/−4
- lib/Data/GI/CodeGen/LibGIRepository.hs +31/−26
- lib/Data/GI/CodeGen/OverloadedMethods.hs +5/−3
- lib/Data/GI/CodeGen/OverloadedSignals.hs +1/−1
- lib/Data/GI/CodeGen/Overrides.hs +72/−31
- lib/Data/GI/CodeGen/Properties.hs +22/−17
- lib/Data/GI/CodeGen/Signal.hs +113/−70
- lib/Data/GI/CodeGen/Struct.hs +72/−37
- lib/Data/GI/CodeGen/SymbolNaming.hs +58/−6
- lib/Data/GI/CodeGen/Transfer.hs +4/−11
- lib/Data/GI/CodeGen/Util.hs +13/−0
- lib/Data/GI/GIR/Alias.hs +1/−1
- lib/Data/GI/GIR/BasicTypes.hs +2/−2
- lib/Data/GI/GIR/Field.hs +15/−9
- lib/Data/GI/GIR/Method.hs +17/−1
- lib/Data/GI/GIR/Parser.hs +5/−5
- lib/Data/GI/GIR/Type.hs +23/−1
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name: haskell-gi-version: 0.18+version: 0.20 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too.@@ -14,6 +14,7 @@ stability: Experimental category: Development build-type: Simple+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 cabal-version: >=1.8 source-repository head@@ -23,7 +24,7 @@ Library pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 build-depends: base >= 4.7 && < 5,- haskell-gi-base == 0.18.*,+ haskell-gi-base == 0.20.*, Cabal >= 1.20, containers, directory,@@ -36,6 +37,7 @@ bytestring, xdg-basedir, xml-conduit >= 1.3.0,+ regex-tdfa >= 1.2, text >= 1.0 extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings@@ -77,6 +79,7 @@ Data.GI.CodeGen.Config, Data.GI.CodeGen.Constant, Data.GI.CodeGen.Conversions,+ Data.GI.CodeGen.EnumFlags, Data.GI.CodeGen.Fixups, Data.GI.CodeGen.GObject, Data.GI.CodeGen.GType,
lib/Data/GI/CodeGen/API.hs view
@@ -9,6 +9,7 @@ , GIRRule(..) , GIRPath , GIRNodeSpec(..)+ , GIRNameTag(..) -- Reexported from Data.GI.GIR.BasicTypes , Name(..)@@ -71,6 +72,8 @@ import Text.XML hiding (Name) import qualified Text.XML as XML +import Text.Regex.TDFA ((=~))+ import Data.GI.GIR.Alias (documentListAliases) import Data.GI.GIR.Allocation (AllocationInfo(..), AllocationOp(..), unknownAllocationInfo) import Data.GI.GIR.Arg (Arg(..), Direction(..), Scope(..))@@ -99,8 +102,9 @@ import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) import Data.GI.Base.Utils (allocMem, freeMem)-import Data.GI.CodeGen.LibGIRepository (girRequire, girStructSizeAndOffsets,- girUnionSizeAndOffsets, girLoadGType)+import Data.GI.CodeGen.LibGIRepository (girRequire, FieldInfo(..),+ girStructFieldInfo, girUnionFieldInfo,+ girLoadGType) import Data.GI.CodeGen.GType (gtypeIsBoxed) import Data.GI.CodeGen.Type (Type) @@ -131,11 +135,16 @@ type GIRPath = [GIRNodeSpec] -- | Node selector for a path in the GIR file.-data GIRNodeSpec = GIRNamed Text -- ^ Node with the given "name" attr.- | GIRType Text -- ^ Node of the given type.- | GIRTypedName Text Text -- ^ Combination of the above.+data GIRNodeSpec = GIRNamed GIRNameTag -- ^ Node with the given "name" attr.+ | GIRType Text -- ^ Node of the given type.+ | GIRTypedName Text GIRNameTag -- ^ Combination of the above. deriving (Show) +-- | A name tag, which is either a name or a regular expression.+data GIRNameTag = GIRPlainName Text+ | GIRRegex Text+ deriving (Show)+ -- | A rule for modifying the GIR file. data GIRRule = GIRSetAttr (GIRPath, XML.Name) Text -- ^ (Path to element, -- attrName), newValue@@ -387,9 +396,9 @@ -- by using libgirepository than reading the GIR file directly. fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct fixupStructSizeAndOffsets (Name ns n) s = do- (size, offsetMap) <- girStructSizeAndOffsets ns n+ (size, infoMap) <- girStructFieldInfo ns n return (s { structSize = size- , structFields = map (fixupField offsetMap) (structFields s)})+ , structFields = map (fixupField infoMap) (structFields s)}) -- | Same thing for unions. fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API)@@ -401,17 +410,17 @@ -- | Like 'fixupStructSizeAndOffset' above. fixupUnionSizeAndOffsets :: Name -> Union -> IO Union fixupUnionSizeAndOffsets (Name ns n) u = do- (size, offsetMap) <- girUnionSizeAndOffsets ns n+ (size, infoMap) <- girUnionFieldInfo ns n return (u { unionSize = size- , unionFields = map (fixupField offsetMap) (unionFields u)})+ , unionFields = map (fixupField infoMap) (unionFields u)}) -- | Fixup the offsets of fields using the given offset map.-fixupField :: M.Map Text Int -> Field -> Field+fixupField :: M.Map Text FieldInfo -> Field -> Field fixupField offsetMap f = f {fieldOffset = case M.lookup (fieldName f) offsetMap of Nothing -> error $ "Could not find field " ++ show (fieldName f)- Just o -> o }+ Just o -> fieldInfoOffset o } -- | Fixup parsed GIRInfos: some of the required information is not -- found in the GIR files themselves, but can be obtained by@@ -467,13 +476,23 @@ else n girSetAttr _ _ n = n +-- | Lookup the given attribute and if present see if it matches the+-- given regex.+lookupAndMatch :: GIRNameTag -> M.Map XML.Name Text -> XML.Name -> Bool+lookupAndMatch tag attrs attr =+ case M.lookup attr attrs of+ Just s -> case tag of+ GIRPlainName pn -> s == pn+ GIRRegex r -> T.unpack s =~ T.unpack r+ Nothing -> False+ -- | See if a given node specification applies to the given node. specMatch :: GIRNodeSpec -> XML.Node -> Bool specMatch (GIRType t) (XML.NodeElement elem) = XML.nameLocalName (XML.elementName elem) == t specMatch (GIRNamed name) (XML.NodeElement elem) =- M.lookup (xmlLocalName "name") (XML.elementAttributes elem) == Just name+ lookupAndMatch name (XML.elementAttributes elem) (xmlLocalName "name") specMatch (GIRTypedName t name) (XML.NodeElement elem) = XML.nameLocalName (XML.elementName elem) == t &&- M.lookup (xmlLocalName "name") (XML.elementAttributes elem) == Just name+ lookupAndMatch name (XML.elementAttributes elem) (xmlLocalName "name") specMatch _ _ = False
lib/Data/GI/CodeGen/Callable.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Data.GI.CodeGen.Callable- ( genCallable+ ( genCCallableWrapper+ , genDynamicCallableWrapper+ , ForeignSymbol(..)+ , ExposeClosures(..) , hOutType , arrayLengths@@ -8,6 +11,9 @@ , callableSignature , fixupCallerAllocates + , callableHInArgs+ , callableHOutArgs+ , wrapMaybe , inArgInterfaces ) where@@ -15,7 +21,7 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif-import Control.Monad (forM, forM_, when)+import Control.Monad (forM, forM_, when, void) import Data.Bool (bool) import Data.List (nub, (\\)) import Data.Maybe (isJust)@@ -36,6 +42,11 @@ import Text.Show.Pretty (ppShow) +-- | Whether to expose closures and the associated destroy notify+-- handlers in the Haskell wrapper.+data ExposeClosures = WithClosures+ | WithoutClosures+ hOutType :: Callable -> [Arg] -> Bool -> ExcCodeGen TypeRep hOutType callable outArgs ignoreReturn = do hReturnType <- case returnType callable of@@ -57,26 +68,25 @@ (_, "()") -> "(,)" `con` hOutArgTypes _ -> "(,)" `con` (maybeHReturnType : hOutArgTypes) -mkForeignImport :: Text -> Callable -> Bool -> CodeGen ()-mkForeignImport symbol callable throwsGError = do+-- | Generate a foreign import for the given C symbol. Return the name+-- of the corresponding Haskell identifier.+mkForeignImport :: Text -> Callable -> Bool -> CodeGen Text+mkForeignImport cSymbol callable throwsGError = do line first indent $ do mapM_ (\a -> line =<< fArgStr a) (args callable) when throwsGError $ line $ padTo 40 "Ptr (Ptr GError) -> " <> "-- error" line =<< last+ return hSymbol where- first = "foreign import ccall \"" <> symbol <> "\" " <>- symbol <> " :: "+ hSymbol = cSymbol+ first = "foreign import ccall \"" <> cSymbol <> "\" " <> hSymbol <> " :: " fArgStr arg = do ft <- foreignType $ argType arg- weAlloc <- isJust <$> requiresAlloc (argType arg)- let ft' = if direction arg == DirectionIn || weAlloc- || argCallerAllocates arg- then- ft- else- ptr ft+ let ft' = if direction arg == DirectionIn || argCallerAllocates arg+ then ft+ else ptr ft let start = tshow ft' <> " -> " return $ padTo 40 start <> "-- " <> (argCName arg) <> " : " <> tshow (argType arg)@@ -84,6 +94,15 @@ Nothing -> return $ typeOf () Just r -> foreignType r +-- | Make a wrapper for foreign `FunPtr`s of the given type. Return+-- the name of the resulting dynamic Haskell wrapper.+mkDynamicImport :: Text -> CodeGen Text+mkDynamicImport typeSynonym = do+ line $ "foreign import ccall \"dynamic\" " <> dynamic <> " :: FunPtr "+ <> typeSynonym <> " -> " <> typeSynonym+ return dynamic+ where dynamic = "__dynamic_" <> typeSynonym+ -- | Given an argument to a function, return whether it should be -- wrapped in a maybe type (useful for nullable types). We do some -- sanity checking to make sure that the argument is actually nullable@@ -250,18 +269,19 @@ -- should be ignored, as they will be dealt with separately. prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen Text prepareArgForCall omitted arg = do- isCallback <- findAPI (argType arg) >>=- \case Just (APICallback _) -> return True- _ -> return False- when (isCallback && direction arg /= DirectionIn) $+ callback <- findAPI (argType arg) >>=+ \case Just (APICallback c) -> return (Just c)+ _ -> return Nothing++ when (isJust callback && direction arg /= DirectionIn) $ notImplementedError "Only callbacks with DirectionIn are supported" case direction arg of DirectionIn -> if arg `elem` omitted then return . escapedArgName $ arg- else if isCallback- then prepareInCallback arg- else prepareInArg arg+ else case callback of+ Just c -> prepareInCallback arg c+ Nothing -> prepareInArg arg DirectionInout -> prepareInoutArg arg DirectionOut -> prepareOutArg arg @@ -284,20 +304,23 @@ return maybeName) -- Callbacks are a fairly special case, we treat them separately.-prepareInCallback :: Arg -> CodeGen Text-prepareInCallback arg = do+prepareInCallback :: Arg -> Callback -> CodeGen Text+prepareInCallback arg (Callback cb) = do let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg - (maker, wrapper) <- case argType arg of- TInterface ns n ->- do- let tn = Name ns n- maker <- qualifiedSymbol ("mk" <> n) tn- wrapper <- qualifiedSymbol (lcFirst n <> "Wrapper") tn- return $ (maker, wrapper)- _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg)+ (maker, wrapper, drop) <-+ case argType arg of+ TInterface tn@(Name _ n) ->+ do+ drop <- if callableHasClosures cb+ then Just <$> qualifiedSymbol (callbackDropClosures n) tn+ else return Nothing+ wrapper <- qualifiedSymbol (callbackHaskellToForeign n) tn+ maker <- qualifiedSymbol (callbackWrapperAllocator n) tn+ return (maker, wrapper, drop)+ _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg) when (scope == ScopeTypeAsync) $ do ft <- tshow <$> foreignType (argType arg)@@ -309,8 +332,12 @@ p = if (scope == ScopeTypeAsync) then parenthesize $ "Just " <> ptrName else "Nothing"+ dropped =+ case drop of+ Just dropper -> parenthesize (dropper <> " " <> name)+ Nothing -> name line $ name' <> " <- " <> maker <> " "- <> parenthesize (wrapper <> " " <> p <> " " <> name)+ <> parenthesize (wrapper <> " " <> p <> " " <> dropped) when (scope == ScopeTypeAsync) $ line $ "poke " <> ptrName <> " " <> name' return name')@@ -326,9 +353,14 @@ let p = if (scope == ScopeTypeAsync) then parenthesize $ "Just " <> ptrName else "Nothing"+ dropped =+ case drop of+ Just dropper ->+ parenthesize (dropper <> " " <> jName)+ Nothing -> jName line $ jName' <> " <- " <> maker <> " " <> parenthesize (wrapper <> " "- <> p <> " " <> jName)+ <> p <> " " <> dropped) when (scope == ScopeTypeAsync) $ line $ "poke " <> ptrName <> " " <> jName' line $ "return " <> jName'@@ -338,9 +370,9 @@ prepareInoutArg arg = do name' <- prepareInArg arg ft <- foreignType $ argType arg- allocInfo <- requiresAlloc (argType arg)+ allocInfo <- typeAllocInfo (argType arg) case allocInfo of- Just (isBoxed, n) -> do+ Just (TypeAllocInfo isBoxed n) -> do let allocator = if isBoxed then "callocBoxedBytes" else "callocBytes"@@ -362,21 +394,26 @@ line $ "poke " <> name'' <> " " <> name' return name'' -prepareOutArg :: Arg -> CodeGen Text+prepareOutArg :: Arg -> ExcCodeGen Text prepareOutArg arg = do let name = escapedArgName arg ft <- foreignType $ argType arg- allocInfo <- requiresAlloc (argType arg)- case allocInfo of- Just (isBoxed, n) -> do- let allocator = if isBoxed- then "callocBoxedBytes"- else "callocBytes"- genConversion name $ literal $ M $ allocator <> " " <> tshow n <>- " :: " <> tshow (io ft)- Nothing ->- genConversion name $- literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)+ if argCallerAllocates arg+ 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 <>+ " :: " <> tshow (io ft)+ Nothing ->+ notImplementedError $ ("Don't know how to allocate \""+ <> argCName arg <> "\" of type "+ <> tshow (argType arg))+ else genConversion name $+ literal $ M $ "allocMem :: " <> tshow (io $ ptr ft) -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object.@@ -514,38 +551,55 @@ when (argScope arg == ScopeTypeCall) $ line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' -formatHSignature :: Callable -> Bool -> ExcCodeGen ()-formatHSignature callable throwsGError = do- (constraints, vars) <- callableSignature callable throwsGError+formatHSignature :: Callable -> ForeignSymbol -> Bool -> ExcCodeGen ()+formatHSignature callable symbol throwsGError = do+ (constraints, vars) <- callableSignature callable symbol throwsGError indent $ do line $ "(" <> T.intercalate ", " constraints <> ") =>" forM_ (zip ("" : repeat "-> ") vars) $ \(prefix, (t, name)) -> line $ withComment (prefix <> t) name +-- | Name for the first argument in dynamic wrappers (the `FunPtr`).+funPtr :: Text+funPtr = "__funPtr"+ -- | The Haskell signature for the given callable. It returns a tuple -- ([constraints], [(type, argname)]).-callableSignature :: Callable -> Bool -> ExcCodeGen ([Text], [(Text, Text)])-callableSignature callable throwsGError = do+callableSignature :: Callable -> ForeignSymbol -> Bool ->+ ExcCodeGen ([Text], [(Text, Text)])+callableSignature callable symbol throwsGError = do let (hInArgs, _) = callableHInArgs callable+ (case symbol of+ KnownForeignSymbol _ -> WithoutClosures+ DynamicForeignSymbol _ -> WithClosures) (argConstraints, types) <- inArgInterfaces hInArgs let constraints = ("MonadIO m" : argConstraints) ignoreReturn = skipRetVal callable throwsGError outType <- hOutType callable (callableHOutArgs callable) ignoreReturn- let allNames = map escapedArgName hInArgs ++ ["result"]- allTypes = types ++ [tshow ("m" `con` [outType])]- return (constraints, zip allTypes allNames)+ case symbol of+ KnownForeignSymbol _ -> do+ let allNames = map escapedArgName hInArgs ++ ["result"]+ allTypes = types ++ [tshow ("m" `con` [outType])]+ return (constraints, zip allTypes allNames)+ DynamicForeignSymbol w -> do+ let allNames = funPtr : map escapedArgName hInArgs ++ ["result"]+ allTypes = ("FunPtr " <> dynamicType w) :+ types ++ [tshow ("m" `con` [outType])]+ return (constraints, zip allTypes allNames) -- | "In" arguments for the given callable on the Haskell side, -- together with the omitted arguments.-callableHInArgs :: Callable -> ([Arg], [Arg])-callableHInArgs callable =+callableHInArgs :: Callable -> ExposeClosures -> ([Arg], [Arg])+callableHInArgs callable expose = let inArgs = filter ((/= DirectionOut) . direction) $ args callable -- We do not expose user_data arguments, -- destroynotify arguments, and C array length -- arguments to Haskell code. closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs- omitted = arrayLengths callable <> closures <> destroyers+ omitted = case expose of+ WithoutClosures -> arrayLengths callable <> closures <> destroyers+ WithClosures -> arrayLengths callable in (filter (`notElem` omitted) inArgs, omitted) -- | "Out" arguments for the given callable on the Haskell side.@@ -555,9 +609,9 @@ in filter (`notElem` (arrayLengths callable)) outArgs -- | Convert the result of the foreign call to Haskell.-convertResult :: Callable -> Text -> Bool -> Map.Map Text Text ->+convertResult :: Name -> Callable -> Bool -> Map.Map Text Text -> ExcCodeGen Text-convertResult callable symbol ignoreReturn nameMap =+convertResult n callable ignoreReturn nameMap = if ignoreReturn || returnType callable == Nothing then return (error "convertResult: unreachable code reached, bug!") else do@@ -571,7 +625,7 @@ return "maybeResult" else do when nullableReturnType $- line $ "checkUnexpectedReturnNULL \"" <> symbol+ line $ "checkUnexpectedReturnNULL \"" <> lowerName n <> "\" result" unwrappedConvertResult "result" @@ -625,13 +679,12 @@ line $ "return " <> wrapped return $ "maybe" <> ucFirst aname') t -> do- weAlloc <- isJust <$> requiresAlloc t- peeked <- if weAlloc || argCallerAllocates arg+ peeked <- if argCallerAllocates arg then return inName else genConversion inName $ apply $ M "peek" -- If we alloc we always take control of the resulting -- memory, otherwise we may leak.- let transfer' = if weAlloc || argCallerAllocates arg+ let transfer' = if argCallerAllocates arg then TransferEverything else transfer arg result <- do@@ -656,7 +709,8 @@ forM hOutArgs (convertOutArg callable nameMap) -- | Invoke the given C function, taking care of errors.-invokeCFunction :: Callable -> Text -> Bool -> Bool -> [Text] -> CodeGen ()+invokeCFunction :: Callable -> ForeignSymbol -> Bool -> Bool -> [Text] ->+ CodeGen () invokeCFunction callable symbol throwsGError ignoreReturn argNames = do let returnBind = case returnType callable of Nothing -> ""@@ -666,8 +720,12 @@ maybeCatchGErrors = if throwsGError then "propagateGError $ " else ""+ call = case symbol of+ KnownForeignSymbol s -> s+ DynamicForeignSymbol w -> parenthesize (dynamicWrapper w+ <> " " <> funPtr) line $ returnBind <> maybeCatchGErrors- <> symbol <> (T.concat . map (" " <>)) argNames+ <> call <> (T.concat . map (" " <>)) argNames -- | Return the result of the call, possibly including out arguments. returnResult :: Callable -> Bool -> Text -> [Text] -> CodeGen ()@@ -682,21 +740,29 @@ _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")" -- | Generate a Haskell wrapper for the given foreign function.-genHaskellWrapper :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()-genHaskellWrapper n symbol callable throwsGError = group $ do- let name = lowerName n- (hInArgs, omitted) = callableHInArgs callable+genHaskellWrapper :: Name -> ForeignSymbol -> Callable -> Bool ->+ ExposeClosures -> ExcCodeGen Text+genHaskellWrapper n symbol callable throwsGError expose = group $ do+ let name = case symbol of+ KnownForeignSymbol _ -> lowerName n+ DynamicForeignSymbol _ -> callbackDynamicWrapper (upperName n)+ (hInArgs, omitted) = callableHInArgs callable expose hOutArgs = callableHOutArgs callable ignoreReturn = skipRetVal callable throwsGError line $ name <> " ::"- formatHSignature callable ignoreReturn- line $ name <> " " <> T.intercalate " " (map escapedArgName hInArgs) <> " = liftIO $ do"+ formatHSignature callable symbol ignoreReturn+ let argNames = case symbol of+ KnownForeignSymbol _ -> map escapedArgName hInArgs+ DynamicForeignSymbol _ ->+ funPtr : map escapedArgName hInArgs+ line $ name <> " " <> T.intercalate " " argNames <> " = liftIO $ do" indent (genWrapperBody n symbol callable throwsGError ignoreReturn hInArgs hOutArgs omitted)+ return name -- | Generate the body of the Haskell wrapper for the given foreign symbol.-genWrapperBody :: Name -> Text -> Callable -> Bool ->+genWrapperBody :: Name -> ForeignSymbol -> Callable -> Bool -> Bool -> [Arg] -> [Arg] -> [Arg] -> ExcCodeGen () genWrapperBody n symbol callable throwsGError@@ -715,7 +781,7 @@ invokeCFunction callable symbol throwsGError ignoreReturn inArgNames readOutArrayLengths callable nameMap- result <- convertResult callable symbol ignoreReturn nameMap+ result <- convertResult n callable ignoreReturn nameMap pps <- convertOutArgs callable nameMap hOutArgs freeCallCallbacks callable nameMap forM_ (args callable) touchInArg@@ -733,7 +799,7 @@ invokeCFunction callable symbol throwsGError ignoreReturn inArgNames readOutArrayLengths callable nameMap- result <- convertResult callable symbol ignoreReturn nameMap+ result <- convertResult n callable ignoreReturn nameMap pps <- convertOutArgs callable nameMap hOutArgs freeCallCallbacks callable nameMap forM_ (args callable) touchInArg@@ -742,23 +808,27 @@ -- | caller-allocates arguments are arguments that the caller -- allocates, and the called function modifies. They are marked as--- 'out' argumens in the introspection data, we treat them as 'inout'--- arguments instead. The semantics are somewhat tricky: for memory--- management purposes they should be treated as "in" arguments, but--- from the point of view of the exposed API they should be treated as--- "inout". Unfortunately we cannot always just assume that they are--- purely "out", so in many cases the generated API is somewhat--- suboptimal (since the initial values are not important): for--- example for g_io_channel_read_chars the size of the buffer to read--- is determined by the caller-allocates argument. As a compromise, we--- assume that we can allocate anything that is not a TCArray.+-- 'out' argumens in the introspection data, we sometimes treat them+-- as 'inout' arguments instead. The semantics are somewhat tricky:+-- for memory management purposes they should be treated as "in"+-- arguments, but from the point of view of the exposed API they+-- should be treated as "out" or "inout". Unfortunately we cannot+-- always just assume that they are purely "out", so in many cases the+-- generated API is somewhat suboptimal (since the initial values are+-- not important): for example for g_io_channel_read_chars the size of+-- the buffer to read is determined by the caller-allocates+-- argument. As a compromise, we assume that we can allocate anything+-- that is not a TCArray of length determined by an argument. fixupCallerAllocates :: Callable -> Callable fixupCallerAllocates c =- c{args = map (fixupLength . fixupArg . normalize) (args c)}- where fixupArg :: Arg -> Arg- fixupArg a = if argCallerAllocates a- then a {direction = DirectionInout}- else a+ c{args = map (fixupLength . fixupDir) (args c)}+ where fixupDir :: Arg -> Arg+ fixupDir a = case argType a of+ TCArray _ _ l _ ->+ if argCallerAllocates a && l > -1+ then a {direction = DirectionInout}+ else a+ _ -> a lengthsMap :: Map.Map Arg Arg lengthsMap = Map.fromList (map swap (arrayLengthsMap c))@@ -773,30 +843,72 @@ then a {direction = DirectionIn} else a - -- We impose that out or inout arguments of non-array type- -- are never caller-allocates.- normalize :: Arg -> Arg- normalize (a@Arg{argType = TCArray _ _ _ _}) = a- normalize a = a {argCallerAllocates = False}+-- | The foreign symbol to wrap. It is either a foreign symbol wrapped+-- in a foreign import, in which case we are given the name of the+-- Haskell wrapper, or alternatively the information about a "dynamic"+-- wrapper in scope.+data ForeignSymbol = KnownForeignSymbol Text -- ^ Haskell symbol in scope.+ | DynamicForeignSymbol DynamicWrapper+ -- ^ Info about the dynamic wrapper. -genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()-genCallable n symbol callable throwsGError = do+-- | Information about a dynamic wrapper.+data DynamicWrapper = DynamicWrapper {+ dynamicWrapper :: Text -- ^ Haskell dynamic wrapper+ , dynamicType :: Text -- ^ Name of the type synonym for the+ -- type of the function to be wrapped.+ }++-- | Some debug info for the callable.+genCallableDebugInfo :: Callable -> Bool -> CodeGen ()+genCallableDebugInfo callable throwsGError = group $ do- line $ "-- Args : " <> (tshow $ args callable)- line $ "-- Lengths : " <> (tshow $ arrayLengths callable)- line $ "-- returnType : " <> (tshow $ returnType callable)- line $ "-- throws : " <> (tshow throwsGError)- line $ "-- Skip return : " <> (tshow $ skipReturn callable)- when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $- do line "-- XXX return value ignored, but it is not a boolean."- line "-- This may be a memory leak?"+ line $ "-- Args : " <> (tshow $ args callable)+ line $ "-- Lengths : " <> (tshow $ arrayLengths callable)+ line $ "-- returnType : " <> (tshow $ returnType callable)+ line $ "-- throws : " <> (tshow throwsGError)+ line $ "-- Skip return : " <> (tshow $ skipReturn callable)+ when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $+ do line "-- XXX return value ignored, but it is not a boolean."+ line "-- This may be a memory leak?" - let callable' = fixupCallerAllocates callable+-- | Generate a wrapper for a known C symbol.+genCCallableWrapper :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()+genCCallableWrapper n cSymbol callable throwsGError = do+ genCallableDebugInfo callable throwsGError - mkForeignImport symbol callable' throwsGError+ let callable' = fixupCallerAllocates callable - blank+ hSymbol <- mkForeignImport cSymbol callable' throwsGError - line $ deprecatedPragma (lowerName n) (callableDeprecated callable)- exportMethod (lowerName n) (lowerName n)- genHaskellWrapper n symbol callable' throwsGError+ blank++ line $ deprecatedPragma (lowerName n) (callableDeprecated callable)+ void (genHaskellWrapper n (KnownForeignSymbol hSymbol) callable'+ throwsGError WithoutClosures)++-- | For callbacks we do not need to keep track of which arguments are+-- closures.+forgetClosures :: Callable -> Callable+forgetClosures c = c {args = map forgetClosure (args c)}+ where forgetClosure :: Arg -> Arg+ forgetClosure arg = arg {argClosure = -1}++-- | Generate a wrapper for a dynamic C symbol (i.e. a Haskell+-- function that will invoke its first argument, which should be a+-- `FunPtr` of the appropriate type). The caller should have created a+-- type synonym with the right type for the foreign symbol.+genDynamicCallableWrapper :: Name -> Text -> Callable -> Bool ->+ ExcCodeGen Text+genDynamicCallableWrapper n typeSynonym callable throwsGError = do+ genCallableDebugInfo callable throwsGError++ let callable' = forgetClosures (fixupCallerAllocates callable)++ wrapper <- mkDynamicImport typeSynonym++ blank++ let dyn = DynamicWrapper { dynamicWrapper = wrapper+ , dynamicType = typeSynonym }+ genHaskellWrapper n (DynamicForeignSymbol dyn) callable'+ throwsGError WithClosures
lib/Data/GI/CodeGen/Code.hs view
@@ -65,6 +65,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad.Except+import qualified Data.ByteString as B import qualified Data.Foldable as F import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid ((<>))@@ -74,7 +75,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.IO as TIO+import qualified Data.Text.Encoding as TE import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, takeDirectory)@@ -435,7 +436,7 @@ findAPI :: Type -> CodeGen (Maybe API) findAPI TError = Just <$> findAPIByName (Name "GLib" "Error")-findAPI (TInterface ns n) = Just <$> findAPIByName (Name ns n)+findAPI (TInterface n) = Just <$> findAPIByName n findAPI _ = return Nothing -- | Find the API associated with a given type. If the API cannot be@@ -723,14 +724,20 @@ -- | Standard imports. moduleImports :: Text-moduleImports = T.unlines [ "import Data.GI.Base.ShortPrelude"- , "import qualified Data.GI.Base.Overloading as O"- , "import qualified Prelude as P"- , ""- , "import qualified Data.GI.Base.Attributes as GI.Attributes"- , "import qualified Data.Text as T"- , "import qualified Data.ByteString.Char8 as B"- , "import qualified Data.Map as Map" ]+moduleImports = T.unlines [+ "import Data.GI.Base.ShortPrelude"+ , "import qualified Data.GI.Base.ShortPrelude as SP"+ , "import qualified Data.GI.Base.Overloading as O"+ , "import qualified Prelude as P"+ , ""+ , "import qualified Data.GI.Base.Attributes as GI.Attributes"+ , "import qualified Data.GI.Base.ManagedPtr as B.ManagedPtr"+ , "import qualified Data.GI.Base.GVariant as B.GVariant"+ , "import qualified Data.GI.Base.GParamSpec as B.GParamSpec"+ , "import qualified Data.Text as T"+ , "import qualified Data.ByteString.Char8 as B"+ , "import qualified Data.Map as Map"+ , "import qualified Foreign.Ptr as FP" ] -- | Write to disk the code for a module, under the given base -- directory. Does not write submodules recursively, for that use@@ -758,11 +765,11 @@ when verbose $ putStrLn ((T.unpack . dotModuleName . moduleName) minfo ++ " -> " ++ fname) createDirectoryIfMissing True dirname- TIO.writeFile fname (T.unlines [pragmas, optionsGHC, haddock, prelude,- imports, deps, code])+ B.writeFile fname (TE.encodeUtf8 $ T.unlines [pragmas, optionsGHC, haddock,+ prelude, imports, deps, code]) when (bootCode minfo /= NoCode) $ do let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot"- TIO.writeFile bootFName (genHsBoot minfo)+ B.writeFile bootFName (TE.encodeUtf8 (genHsBoot minfo)) -- | Generate the .hs-boot file for the given module. genHsBoot :: ModuleInfo -> Text
lib/Data/GI/CodeGen/CodeGen.hs view
@@ -10,21 +10,18 @@ #endif import Control.Monad (forM, forM_, when, unless, filterM) import Data.List (nub)-import Data.Tuple (swap) import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe) import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) -import Foreign.Storable (sizeOf)-import Foreign.C (CUInt)- import Data.GI.CodeGen.API-import Data.GI.CodeGen.Callable (genCallable)+import Data.GI.CodeGen.Callable (genCCallableWrapper) import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.Constant (genConstant) import Data.GI.CodeGen.Code+import Data.GI.CodeGen.EnumFlags (genEnum, genFlags) import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability) import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList,@@ -39,7 +36,7 @@ fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion, genWrappedPtr) import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName,- submoduleLocation)+ submoduleLocation, lowerName) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) @@ -52,7 +49,10 @@ handleCGExc (\e -> line ("-- XXX Could not generate function " <> symbol <> "\n-- Error was : " <> describeCGError e))- (genCallable n symbol callable throws)+ (do+ genCCallableWrapper n symbol callable throws+ exportMethod (lowerName n) (lowerName n)+ ) genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do@@ -68,139 +68,12 @@ hsBoot $ line $ "instance BoxedObject " <> name' <> " where" -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: " <> tshow (sizeOf (0 :: CUInt))- when (storageBytes /= 4) $- notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes-- let name' = upperName n- fields' <- forM fields $ \(fieldName, value) -> do- let n = upperName $ Name ns (name <> "_" <> fieldName)- return (n, value)-- line $ deprecatedPragma name' isDeprecated-- group $ do- exportDecl (name' <> "(..)")- hsBoot . line $ "data " <> name'- 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- bline $ "instance P.Enum " <> name' <> " where"- indent $ do- forM_ fields' $ \(n, v) ->- line $ "fromEnum " <> n <> " = " <> tshow 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 " <> tshow v <> " = " <> n- line $ "toEnum k = Another" <> name' <> " k"-- group $ do- line $ "instance P.Ord " <> name' <> " where"- indent $ line "compare a b = P.compare (P.fromEnum a) (P.fromEnum b)"-- maybe (return ()) (genErrorDomain name') eDomain--genBoxedEnum :: Name -> Text -> CodeGen ()-genBoxedEnum n typeInit = do- let name' = upperName n-- 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--genEnum :: Name -> Enumeration -> CodeGen ()-genEnum n@(Name _ name) enum = do- line $ "-- Enum " <> name-- handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)- (do genEnumOrFlags n enum- case enumTypeInit enum of- Nothing -> return ()- Just ti -> genBoxedEnum n ti)--genBoxedFlags :: Name -> Text -> CodeGen ()-genBoxedFlags n typeInit = do- let name' = upperName n-- 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---- 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-- case enumTypeInit enum of- Nothing -> return ()- Just ti -> genBoxedFlags n ti-- let name' = upperName n- group $ bline $ "instance IsGFlag " <> name')--genErrorDomain :: Text -> Text -> CodeGen ()-genErrorDomain name' domain = do- group $ do- line $ "instance GErrorClass " <> name' <> " where"- indent $ line $- "gerrorClassDomain _ = \"" <> 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"- exportToplevel ("catch" <> name')- exportToplevel ("handle" <> name')- -- | Generate wrapper for structures. genStruct :: Name -> Struct -> CodeGen () genStruct n s = unless (ignoreStruct n s) $ do let name' = upperName n - let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" hsBoot decl decl @@ -243,7 +116,7 @@ genUnion n u = do let name' = upperName n - let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" hsBoot decl decl @@ -279,14 +152,16 @@ when (cgOverloadedMethods (cgFlags cfg)) $ genMethodList n (catMaybes methods) --- 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' }+-- | When parsing the GIR file we 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 :: Callable -> Callable+fixMethodArgs c = c { args = args'' , returnType = returnType' } where returnType' = maybe Nothing (Just . fixCArrayLength) (returnType c)- args' = objArg : map (fixDestroyers . fixClosures . fixLengthArg) (args c)+ args' = map (fixDestroyers . fixClosures . fixLengthArg) (args c)+ args'' = fixInstance (head args') : tail args' fixLengthArg :: Arg -> Arg fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)}@@ -296,6 +171,7 @@ if length > -1 then TCArray zt fixed (length+1) t else TCArray zt fixed length t+ fixCArrayLength t = t fixDestroyers :: Arg -> Arg@@ -310,16 +186,12 @@ then arg {argClosure = closure + 1} else arg - objArg = Arg {- argCName = "_obj",- argType = TInterface (namespace cn) (name cn),- direction = DirectionIn,- mayBeNull = False,- argScope = ScopeTypeInvalid,- argClosure = -1,- argDestroy = -1,- argCallerAllocates = False,- transfer = TransferNothing }+ -- We always treat the instance argument of a method as non-null+ -- and "in", even if sometimes the introspection data may say+ -- otherwise.+ fixInstance :: Arg -> Arg+ fixInstance arg = arg { mayBeNull = False+ , direction = DirectionIn} -- For constructors we want to return the actual type of the object, -- rather than a generic superclass (so Gtk.labelNew returns a@@ -328,7 +200,7 @@ fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' } where returnType' = if returnsGObject then- Just (TInterface (namespace cn) (name cn))+ Just (TInterface cn) else returnType c @@ -350,9 +222,10 @@ then fixConstructorReturnType returnsGObject cn c else c c'' = if OrdinaryMethod == t- then fixMethodArgs cn c'+ then fixMethodArgs c' else c'- genCallable mn' sym c'' throws+ genCCallableWrapper mn' sym c'' throws+ exportMethod (lowerName mn) (lowerName mn') cfg <- config when (cgOverloadedMethods (cgFlags cfg)) $@@ -400,14 +273,14 @@ genObject :: Name -> Object -> CodeGen () genObject n o = do let name' = upperName n- let t = (\(Name ns' n') -> TInterface ns' n') 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- bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" exportDecl (name' <> "(..)") -- Type safe casting to parent objects, and implemented interfaces.@@ -450,7 +323,7 @@ line $ "-- interface " <> name' <> " " line $ deprecatedPragma name' $ ifDeprecated iface- bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ bline $ "newtype " <> name' <> " = " <> name' <> " (ManagedPtr " <> name' <> ")" exportDecl (name' <> "(..)") noName name'@@ -484,7 +357,7 @@ else group $ do cls <- classConstraint n exportDecl cls- bline $ "class ForeignPtrNewtype a => " <> cls <> " a"+ bline $ "class ManagedPtrNewtype a => " <> cls <> " a" line $ "instance " <> cls <> " " <> name' -- Methods
lib/Data/GI/CodeGen/Constant.hs view
@@ -61,7 +61,7 @@ ht <- tshow <$> haskellType t hv <- showBasicType b value writePattern name (SimpleSynonym hv ht)-assignValue name t@(TInterface _ _) value = do+assignValue name t@(TInterface _) value = do ht <- tshow <$> haskellType t api <- findAPI t case api of
lib/Data/GI/CodeGen/Conversions.hs view
@@ -6,9 +6,12 @@ , unpackCArray , computeArrayLength + , callableHasClosures+ , hToF , fToH , haskellType+ , isoHaskellType , foreignType , argumentType@@ -19,9 +22,12 @@ , isManaged , typeIsNullable , typeIsPtr+ , maybeNullConvert+ , nullPtrForType , getIsScalar- , requiresAlloc+ , typeAllocInfo+ , TypeAllocInfo(..) , apply , mapC@@ -33,6 +39,7 @@ import Control.Applicative ((<$>), (<*>), pure, Applicative) #endif import Control.Monad (when)+import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Int import Data.Text (Text)@@ -159,7 +166,7 @@ where findReader = case t of TBasicType TUInt8 -> return "B.length" TBasicType _ -> return "length"- TInterface _ _ -> return "length"+ TInterface _ -> return "length" TCArray{} -> return "length" _ -> notImplementedError $ "Don't know how to compute length of " <> tshow t@@ -178,31 +185,31 @@ then do isGO <- isGObject t if isGO- then return $ M "refObject"+ 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 "unsafeManagedPtrCastPtr"+ else return $ M "unsafeManagedPtrCastPtr" hVariantToF :: Transfer -> CodeGen Constructor hVariantToF transfer = if transfer == TransferEverything- then return $ M "refGVariant"- else return "unsafeManagedPtrGetPtr"+ then return $ M "B.GVariant.disownGVariant"+ else return $ M "unsafeManagedPtrGetPtr" hParamSpecToF :: Transfer -> CodeGen Constructor hParamSpecToF transfer = if transfer == TransferEverything- then return $ M "refGParamSpec"- else return "unsafeManagedPtrGetPtr"+ then return $ M "B.GParamSpec.disownGParamSpec"+ else return $ M "unsafeManagedPtrGetPtr" hBoxedToF :: Transfer -> CodeGen Constructor hBoxedToF transfer = if transfer == TransferEverything- then return $ M "copyBoxed"- else return "unsafeManagedPtrGetPtr"+ then return $ M "B.ManagedPtr.disownBoxed"+ else return $ M "unsafeManagedPtrGetPtr" hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor hStructToF s transfer =@@ -211,7 +218,7 @@ else do when (structSize s == 0) $ badIntroError "Transferring a non-boxed struct with unknown size!"- return "unsafeManagedPtrGetPtr"+ return $ M "unsafeManagedPtrGetPtr" hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor hUnionToF u transfer =@@ -220,7 +227,7 @@ else do when (unionSize u == 0) $ badIntroError "Transferring a non-boxed union with unknown size!"- return "unsafeManagedPtrGetPtr"+ return $ M "unsafeManagedPtrGetPtr" -- Given the Haskell and Foreign types, returns the name of the -- function marshalling between both.@@ -355,7 +362,7 @@ else "pack" hToF_PackedType t (packer <> "PtrArray") transfer -hToF (TCArray zt _ _ t@(TInterface _ _)) transfer = do+hToF (TCArray zt _ _ t@(TInterface _)) transfer = do isScalar <- getIsScalar t let packer = if zt then "packZeroTerminated"@@ -411,15 +418,21 @@ TransferEverything -> if isGO then return $ M $ parenthesize $ "wrapObject " <> constructor- else badIntroError "Got a transfer of something not a GObject"+ else badIntroError ("Got a transfer of something not a GObject: " <>+ constructor) _ -> if isGO then return $ M $ parenthesize $ "newObject " <> constructor- else badIntroError "Wrapping not a GObject with no copy..."+ else badIntroError ("Wrapping not a GObject with no copy: " <>+ constructor) -fCallbackToH :: Callback -> TypeRep -> Transfer -> ExcCodeGen Constructor-fCallbackToH _ _ _ =- notImplementedError "Wrapping foreign callbacks is not supported yet"+fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor+fCallbackToH hType TransferNothing = do+ let constructor = T.pack . tyConName . typeRepTyCon $ hType+ return (P (callbackDynamicWrapper constructor))+fCallbackToH _ transfer =+ notImplementedError ("ForeignCallback with unsupported transfer type `"+ <> tshow transfer <> "'") fVariantToH :: Transfer -> CodeGen Constructor fVariantToH transfer =@@ -446,7 +459,7 @@ | Just (APIUnion u) <- a = unionForeignPtr u hType transfer | Just (APIObject _) <- a = fObjectToH t hType transfer | Just (APIInterface _) <- a = fObjectToH t hType transfer- | Just (APICallback c) <- a = fCallbackToH c hType transfer+ | Just (APICallback _) <- a = fCallbackToH hType transfer | TCArray True _ _ (TBasicType TUTF8) <- t = return $ M "unpackZeroTerminatedUTF8CArray" | TCArray True _ _ (TBasicType TFileName) <- t =@@ -523,7 +536,7 @@ fToH (TCArray False (-1) (-1) _) _ = return $ Pure () fToH (TCArray True _ _ t@(TCArray{})) transfer = fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer-fToH (TCArray True _ _ t@(TInterface _ _)) transfer = do+fToH (TCArray True _ _ t@(TInterface _)) transfer = do isScalar <- getIsScalar t if isScalar then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer@@ -557,7 +570,7 @@ "unpackMapStorableArrayWithLength realToFrac " <> length TBasicType _ -> return $ apply $ M $ parenthesize $ "unpackStorableArrayWithLength " <> length- TInterface _ _ -> do+ TInterface _ -> do a <- findAPI t isScalar <- getIsScalar t hType <- haskellType t@@ -672,15 +685,38 @@ haskellType TError = return $ "GError" `con` [] haskellType TVariant = return $ "GVariant" `con` [] haskellType TParamSpec = return $ "GParamSpec" `con` []-haskellType (TInterface "GObject" "Value") = return $ "GValue" `con` []-haskellType (TInterface "GObject" "Closure") = return $ "Closure" `con` []-haskellType t@(TInterface ns n) = do+haskellType (TInterface (Name "GObject" "Value")) = return $ "GValue" `con` []+haskellType (TInterface (Name "GObject" "Closure")) = return $ "Closure" `con` []+haskellType t@(TInterface n) = do api <- getAPI t- tname <- qualifiedAPI (Name ns n)+ 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++-- | 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.+isoHaskellType :: Type -> CodeGen TypeRep+isoHaskellType t@(TInterface n) = do+ api <- findAPI t+ case api of+ Just (APICallback (Callback c)) -> do+ tname <- qualifiedAPI n+ if callableHasClosures c+ then return ((callbackHTypeWithClosures tname) `con` [])+ else return (tname `con` [])+ _ -> haskellType t+isoHaskellType t = haskellType t+ foreignBasicType TBoolean = "CInt" `con` [] foreignBasicType TUTF8 = "CString" `con` [] foreignBasicType TFileName = "CString" `con` []@@ -724,10 +760,10 @@ foreignType t@TError = ptr <$> haskellType t foreignType t@TVariant = ptr <$> haskellType t foreignType t@TParamSpec = ptr <$> haskellType t-foreignType (TInterface "GObject" "Value") = return $ ptr $ "GValue" `con` []-foreignType (TInterface "GObject" "Closure") =+foreignType (TInterface (Name "GObject" "Value")) = return $ ptr $ "GValue" `con` []+foreignType (TInterface (Name "GObject" "Closure")) = return $ ptr $ "Closure" `con` []-foreignType t@(TInterface ns n) = do+foreignType t@(TInterface n) = do isScalar <- getIsScalar t if isScalar then return $ "CUInt" `con` []@@ -735,10 +771,10 @@ api <- getAPI t case api of APICallback _ -> do- tname <- qualifiedSymbol (n <> "C") (Name ns n)+ tname <- qualifiedSymbol (callbackCType $ name n) n return (funptr $ tname `con` []) _ -> do- tname <- qualifiedAPI (Name ns n)+ tname <- qualifiedAPI n return (ptr $ tname `con` []) getIsScalar :: Type -> CodeGen Bool@@ -750,22 +786,33 @@ (Just (APIFlags _)) -> return True _ -> return False --- Whether the given type corresponds to a struct we allocate--- ourselves. If we need to allocate the struct we return its size in--- bytes and whether the type is boxed, otherwise we return Nothing.-requiresAlloc :: Type -> CodeGen (Maybe (Bool, Int))-requiresAlloc t = do+-- | 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 -> return (Just (structIsBoxed s, n))+ 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).+-- | Returns whether the given type corresponds to a `ManagedPtr`+-- instance (a thin wrapper over a `ForeignPtr`). isManaged :: Type -> CodeGen Bool-isManaged t = do+isManaged TError = return True+isManaged TVariant = return True+isManaged TParamSpec = return True+isManaged t@(TInterface _) = do a <- findAPI t case a of Just (APIObject _) -> return True@@ -773,17 +820,54 @@ 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 (TBasicType TPtr) = return True-typeIsPtr (TBasicType TUTF8) = return True-typeIsPtr (TBasicType TFileName) = return True-typeIsPtr t = do+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- return (tyConName (typeRepTyCon ft) `elem` ["Ptr", "FunPtr"])+ case tyConName (typeRepTyCon 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@@ -791,11 +875,7 @@ -- which we just pass through to the Haskell side. Notice that -- introspection annotations can override this. typeIsNullable :: Type -> CodeGen Bool-typeIsNullable t = case t of- TBasicType TPtr -> return False- TGList _ -> return False- TGSList _ -> return False- _ -> typeIsPtr t+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.
+ lib/Data/GI/CodeGen/EnumFlags.hs view
@@ -0,0 +1,147 @@+-- | Support for enums and flags.+module Data.GI.CodeGen.EnumFlags+ ( genEnum+ , genFlags+ ) where++import Control.Monad (when, forM_, forM)+import qualified Data.Map as M+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Tuple (swap)++import Foreign.C (CUInt)+import Foreign.Storable (sizeOf)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.SymbolNaming (upperName)+import Data.GI.CodeGen.Util (tshow)++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: " <> tshow (sizeOf (0 :: CUInt))+ when (storageBytes /= 4) $+ notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes++ let name' = upperName n+ fields' <- forM fields $ \(fieldName, value) -> do+ let n = upperName $ Name ns (name <> "_" <> fieldName)+ return (n, value)++ line $ deprecatedPragma name' isDeprecated++ group $ do+ exportDecl (name' <> "(..)")+ hsBoot . line $ "data " <> name'+ 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+ bline $ "instance P.Enum " <> name' <> " where"+ indent $ do+ forM_ fields' $ \(n, v) ->+ line $ "fromEnum " <> n <> " = " <> tshow 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 " <> tshow v <> " = " <> n+ line $ "toEnum k = Another" <> name' <> " k"++ group $ do+ line $ "instance P.Ord " <> name' <> " where"+ indent $ line "compare a b = P.compare (P.fromEnum a) (P.fromEnum b)"++ maybe (return ()) (genErrorDomain name') eDomain++genBoxedEnum :: Name -> Text -> CodeGen ()+genBoxedEnum n typeInit = do+ let name' = upperName n++ 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++genEnum :: Name -> Enumeration -> CodeGen ()+genEnum n@(Name _ name) enum = do+ line $ "-- Enum " <> name++ handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)+ (do genEnumOrFlags n enum+ case enumTypeInit enum of+ Nothing -> return ()+ Just ti -> genBoxedEnum n ti)++genBoxedFlags :: Name -> Text -> CodeGen ()+genBoxedFlags n typeInit = do+ let name' = upperName n++ 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++-- | 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++ case enumTypeInit enum of+ Nothing -> return ()+ Just ti -> genBoxedFlags n ti++ let name' = upperName n+ group $ bline $ "instance IsGFlag " <> name')++-- | Support for enums encapsulating error codes.+genErrorDomain :: Text -> Text -> CodeGen ()+genErrorDomain name' domain = do+ group $ do+ line $ "instance GErrorClass " <> name' <> " where"+ indent $ line $+ "gerrorClassDomain _ = \"" <> 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"+ exportToplevel ("catch" <> name')+ exportToplevel ("handle" <> name')
lib/Data/GI/CodeGen/Fixups.hs view
@@ -74,7 +74,7 @@ -- for the property. Just m -> let c = methodCallable m- in if length (args c) == 0 &&+ in if length (args c) == 1 && returnType c == Just (propType p) && returnTransfer c == TransferNothing && skipReturn c == False &&@@ -99,15 +99,15 @@ -- Check that it looks like a sensible setter. Just m -> let c = methodCallable m- in if length (args c) == 1 &&- (argType . head . args) c == propType p &&+ in if length (args c) == 2 &&+ (argType . last . args) c == propType p && returnType c == Nothing &&- (transfer . head . args) c == TransferNothing &&- (direction . head . args) c == DirectionIn &&+ (transfer . last . args) c == TransferNothing &&+ (direction . last . args) c == DirectionIn && methodMovedTo m == Nothing && methodType m == OrdinaryMethod && methodThrows m == False- then Just ((mayBeNull . head . args) c)+ then Just ((mayBeNull . last . args) c) else Nothing -- | Find the first method with the given name, if any.
lib/Data/GI/CodeGen/GObject.hs view
@@ -16,9 +16,8 @@ -- Returns whether the given type is a descendant of the given parent. typeDoParentSearch :: Name -> Type -> CodeGen Bool-typeDoParentSearch parent (TInterface ns n) = findAPIByName name >>=- apiDoParentSearch parent name- where name = Name ns n+typeDoParentSearch parent (TInterface n) = findAPIByName n >>=+ apiDoParentSearch parent n typeDoParentSearch _ _ = return False apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool@@ -27,7 +26,7 @@ | otherwise = case api of APIObject o -> case objParent o of- Just (Name pns pn) -> typeDoParentSearch parent (TInterface pns pn)+ Just p -> typeDoParentSearch parent (TInterface p) Nothing -> return False APIInterface iface -> do let prs = ifPrerequisites iface
lib/Data/GI/CodeGen/Inheritance.hs view
@@ -96,13 +96,13 @@ (++) (map ((,) n) (ifInheritables iface)) <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface)) --- It is sometimes the case that a property name or signal is defined+-- | It is sometimes the case that a property name or signal is defined -- both in an object and in one of its ancestors/implemented -- interfaces. This is harmless if the properties are isomorphic -- (there will be more than one qualified set of property -- setters/getters that we can call, but they are all isomorphic). If--- they are not isomorphic we refuse to set either, and print a--- warning in the generated code.+-- they are not isomorphic we print a warning, and choose to use the+-- one closest to the leaves of the object hierarchy. removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) => Bool -> [(Name, i)] -> CodeGen [(Name, i)] removeDuplicates verbose inheritables =@@ -125,7 +125,7 @@ Nothing -> return $ M.insert (iName prop) (False, name, prop) m filterTainted :: [(Text, (Bool, Name, i))] -> [(Name, i)] filterTainted xs =- [(name, prop) | (_, (tainted, name, prop)) <- xs, not tainted]+ [(name, prop) | (_, (_, name, prop)) <- xs] -- | List all properties defined for an object, including those -- defined by its ancestors.
lib/Data/GI/CodeGen/LibGIRepository.hs view
@@ -2,8 +2,9 @@ -- | A minimal wrapper for libgirepository. module Data.GI.CodeGen.LibGIRepository ( girRequire- , girStructSizeAndOffsets- , girUnionSizeAndOffsets+ , FieldInfo(..)+ , girStructFieldInfo+ , girUnionFieldInfo , girLoadGType ) where @@ -11,27 +12,34 @@ import Control.Applicative ((<$>)) #endif -import Control.Monad (forM, when)+import Control.Monad (forM, when, (>=>)) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Foreign.C.Types (CInt(..), CSize(..)) import Foreign.C.String (CString)-import Foreign (nullPtr, Ptr, ForeignPtr, FunPtr, peek)+import Foreign (nullPtr, Ptr, FunPtr, peek) import Data.GI.Base.BasicConversions (withTextCString, cstringToText)-import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType)+import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType, ManagedPtr) import Data.GI.Base.GError (GError, checkGError) import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr) import Data.GI.Base.Utils (allocMem, freeMem) -- | Wrapper for 'GIBaseInfo'-newtype BaseInfo = BaseInfo (ForeignPtr BaseInfo)+newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo) -- | Wrapper for 'GITypelib' newtype Typelib = Typelib (Ptr Typelib) +-- | Extra info about a field in a struct or union which is not easily+-- determined from the GIR file. (And which we determine by using+-- libgirepository.)+data FieldInfo = FieldInfo {+ fieldInfoOffset :: Int+ }+ foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType instance BoxedObject BaseInfo where@@ -72,6 +80,13 @@ foreign import ccall "g_base_info_get_name" g_base_info_get_name :: Ptr BaseInfo -> IO CString +-- | Get the extra information for the given field.+getFieldInfo :: BaseInfo -> IO (Text, FieldInfo)+getFieldInfo field = withManagedPtr field $ \fi -> do+ fname <- (g_base_info_get_name fi >>= cstringToText)+ fOffset <- g_field_info_get_offset fi+ return (fname, FieldInfo { fieldInfoOffset = fromIntegral fOffset })+ foreign import ccall "g_struct_info_get_size" g_struct_info_get_size :: Ptr BaseInfo -> IO CSize foreign import ccall "g_struct_info_get_n_fields" g_struct_info_get_n_fields ::@@ -81,20 +96,15 @@ -- | Find out the size of a struct, and the map from field names to -- offsets inside the struct.-girStructSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)-girStructSizeAndOffsets ns name = do+girStructFieldInfo :: Text -> Text -> IO (Int, M.Map Text FieldInfo)+girStructFieldInfo ns name = do baseinfo <- girFindByName ns name withManagedPtr baseinfo $ \si -> do size <- g_struct_info_get_size si nfields <- g_struct_info_get_n_fields si- fieldOffsets <- forM [0..(nfields-1)] $ \i -> do- fieldInfo <- (g_struct_info_get_field si i- >>= wrapBoxed BaseInfo)- withManagedPtr fieldInfo $ \fi -> do- fname <- (g_base_info_get_name fi >>= cstringToText)- fOffset <- g_field_info_get_offset fi- return (fname, fromIntegral fOffset)- return (fromIntegral size, M.fromList fieldOffsets)+ fieldInfos <- forM [0..(nfields-1)]+ (g_struct_info_get_field si >=> wrapBoxed BaseInfo >=> getFieldInfo)+ return (fromIntegral size, M.fromList fieldInfos) foreign import ccall "g_union_info_get_size" g_union_info_get_size :: Ptr BaseInfo -> IO CSize@@ -105,20 +115,15 @@ -- | Find out the size of a union, and the map from field names to -- offsets inside the union.-girUnionSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)-girUnionSizeAndOffsets ns name = do+girUnionFieldInfo :: Text -> Text -> IO (Int, M.Map Text FieldInfo)+girUnionFieldInfo ns name = do baseinfo <- girFindByName ns name withManagedPtr baseinfo $ \ui -> do size <- g_union_info_get_size ui nfields <- g_union_info_get_n_fields ui- fieldOffsets <- forM [0..(nfields-1)] $ \i -> do- fieldInfo <- (g_union_info_get_field ui i- >>= wrapBoxed BaseInfo)- withManagedPtr fieldInfo $ \fi -> do- fname <- (g_base_info_get_name fi >>= cstringToText)- fOffset <- g_field_info_get_offset fi- return (fname, fromIntegral fOffset)- return (fromIntegral size, M.fromList fieldOffsets)+ fieldInfos <- forM [0..(nfields-1)] (+ g_union_info_get_field ui >=> wrapBoxed BaseInfo >=> getFieldInfo)+ return (fromIntegral size, M.fromList fieldInfos) foreign import ccall "g_typelib_symbol" g_typelib_symbol :: Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt
lib/Data/GI/CodeGen/OverloadedMethods.hs view
@@ -10,7 +10,8 @@ import qualified Data.Text as T import Data.GI.CodeGen.API-import Data.GI.CodeGen.Callable (callableSignature, fixupCallerAllocates)+import Data.GI.CodeGen.Callable (callableSignature, ForeignSymbol(..),+ fixupCallerAllocates) import Data.GI.CodeGen.Code import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol) import Data.GI.CodeGen.Util (ucFirst)@@ -76,7 +77,8 @@ group $ do infoName <- methodInfoName n m let callable = fixupCallerAllocates (methodCallable m)- (constraints, types) <- callableSignature callable (methodThrows m)+ (constraints, types) <- callableSignature callable+ (KnownForeignSymbol undefined) (methodThrows m) bline $ "data " <> infoName -- This should not happen, since ordinary methods always -- have the instance as first argument.@@ -90,7 +92,7 @@ let mn = methodName m mangled = lowerName (mn {name = name n <> "_" <> name mn}) indent $ line $ "overloadedMethod _ = " <> mangled- exportMethod mangled infoName+ exportMethod (lowerName mn) infoName -- | Generate a method info that is not actually callable, but rather -- gives a type error when trying to use it.
lib/Data/GI/CodeGen/OverloadedSignals.hs view
@@ -87,7 +87,7 @@ cbHaskellType = signalConnectorName <> "Callback" line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType line $ "connectSignal _ = " <> "connect" <> name <> sn- exportSignal sn si+ exportSignal (lcFirst sn) si -- | Signal instances for (GObject-derived) objects. genObjectSignals :: Name -> Object -> CodeGen ()
lib/Data/GI/CodeGen/Overrides.hs view
@@ -19,12 +19,17 @@ import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text)+import qualified Data.Version as V +import Text.ParserCombinators.ReadP (readP_to_S)+ import qualified System.Info as SI import qualified System.Environment as SE import Data.GI.CodeGen.API import qualified Text.XML as XML+import Data.GI.CodeGen.PkgConfig (tryPkgConfig)+import Data.GI.CodeGen.Util (tshow) import Data.GI.GIR.XMLUtils (xmlLocalName, xmlNSName, GIRXMLNamespace(CGIRNS, GLibGIRNS)) @@ -81,7 +86,10 @@ -- | The state of the overrides parser. data ParserState = ParserState { currentNS :: Maybe Text -- ^ The current namespace.- , flags :: [ParserFlag] -- ^ Currently loaded flags.+ , flags :: [Bool] -- ^ The contents of the override file will+ -- be ignored if there is any `False` value+ -- here. @if@ primitive push (prepend)+ -- values here, @endif@ pop them. } deriving (Show) -- | Default, empty, parser state.@@ -91,12 +99,6 @@ , flags = [] } --- | Conditional flags for the parser-data ParserFlag = FlagLinux- | FlagOSX- | FlagWindows- deriving (Show)- -- | Get the current namespace. getNS :: Parser (Maybe Text) getNS = currentNS <$> get@@ -105,25 +107,10 @@ withFlags :: Parser () -> Parser () withFlags p = do fs <- flags <$> get- check <- and <$> liftIO (traverse checkFlag fs)- if check+ if and fs then p else return () --- | Check whether the given flag holds.-checkFlag :: ParserFlag -> IO Bool-checkFlag FlagLinux = checkOS "linux"-checkFlag FlagOSX = checkOS "darwin"-checkFlag FlagWindows = checkOS "mingw32"---- | Check whether we are running under the given OS. We take the OS--- from `System.Info.os`, but it is possible to override this value by--- setting the environment variable @HASKELL_GI_OVERRIDE_OS@.-checkOS :: String -> IO Bool-checkOS os = SE.lookupEnv "HASKELL_GI_OVERRIDE_OS" >>= \case- Nothing -> return (SI.os == os)- Just ov -> return (ov == os)- -- | We have a bit of context (the current namespace), and can fail, -- encode this in a monad. type Parser a = WriterT Overrides (StateT ParserState (ExceptT Text IO)) a@@ -160,8 +147,7 @@ withFlags $ parseNsVersion s parseOneLine (T.stripPrefix "set-attr " -> Just s) = withFlags $ parseSetAttr s-parseOneLine (T.stripPrefix "if " -> Just s) =- withFlags $ parseIf s+parseOneLine (T.stripPrefix "if " -> Just s) = parseIf s parseOneLine (T.stripPrefix "endif" -> Just s) = parseEndif s parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"." @@ -258,12 +244,18 @@ parsePathSpec :: Text -> Parser GIRPath parsePathSpec spec = mapM parseNodeSpec (T.splitOn "/" spec) +-- | A specification of a name, which is either a regex (prefixed with+-- "~") or a plain name.+parseGIRNameTag :: Text -> GIRNameTag+parseGIRNameTag (T.stripPrefix "~" -> Just regex) = GIRRegex regex+parseGIRNameTag t = GIRPlainName t+ -- | Parse a single node specification. parseNodeSpec :: Text -> Parser GIRNodeSpec parseNodeSpec spec = case T.splitOn "@" spec of- [n] -> return (GIRNamed n)+ [n] -> return (GIRNamed (parseGIRNameTag n)) ["", t] -> return (GIRType t)- [n, t] -> return (GIRTypedName t n)+ [n, t] -> return (GIRTypedName t (parseGIRNameTag n)) _ -> throwError ("Could not understand node spec \"" <> spec <> "\".") @@ -276,15 +268,64 @@ _ -> throwError ("Could not understand xml name \"" <> a <> "\".") +-- | Known operating systems.+data OSType = Linux+ | OSX+ | Windows+ deriving (Show)++-- | Check whether we are running under the given OS. We take the OS+-- from `System.Info.os`, but it is possible to override this value by+-- setting the environment variable @HASKELL_GI_OVERRIDE_OS@.+checkOS :: String -> Parser Bool+checkOS os = liftIO (SE.lookupEnv "HASKELL_GI_OVERRIDE_OS") >>= \case+ Nothing -> return (SI.os == os)+ Just ov -> return (ov == os)++-- | Parse a textual representation of a version into a `Data.Version.Version`.+parseVersion :: Text -> Parser V.Version+parseVersion v = (chooseFullParse . readP_to_S V.parseVersion . T.unpack) v+ where chooseFullParse :: [(V.Version, String)] -> Parser V.Version+ chooseFullParse [] = throwError ("Could not parse version \""+ <> v <> "\".")+ chooseFullParse [(parsed, "")] = return parsed+ chooseFullParse (_ : rest) = chooseFullParse rest++-- | Check that the given pkg-config package has a version compatible+-- with the given constraint.+checkPkgConfigVersion :: Text -> Text -> Text -> Parser Bool+checkPkgConfigVersion pkg op tVersion = do+ version <- parseVersion tVersion+ pcVersion <- liftIO (tryPkgConfig pkg) >>= \case+ Nothing ->+ throwError ("Could not determine pkg-config version for \""+ <> pkg <> "\".")+ Just (_, tv) -> parseVersion tv+ case op of+ "==" -> return (pcVersion == version)+ "/=" -> return (pcVersion /= version)+ ">=" -> return (pcVersion >= version)+ ">" -> return (pcVersion > version)+ "<=" -> return (pcVersion <= version)+ "<" -> return (pcVersion < version)+ _ -> throwError ("Unrecognized comparison operator \"" <> op <> "\".")+ -- | Parse a 'if' directive. parseIf :: Text -> Parser () parseIf cond = case T.words cond of [] -> throwError ("Empty 'if' condition.")- ["linux"] -> setFlag FlagLinux- ["osx"] -> setFlag FlagOSX- ["windows"] -> setFlag FlagWindows+ ["linux"] -> checkOS "linux" >>= setFlag+ ["osx"] -> checkOS "darwin" >>= setFlag+ ["windows"] -> checkOS "mingw32" >>= setFlag+ ("pkg-config-version" : rest) ->+ case rest of+ [pkg, op, version] ->+ checkPkgConfigVersion pkg op version >>= setFlag+ _ -> throwError ("Syntax for `pkg-config-version' is "+ <> "\"pkg op version\", got \""+ <> tshow rest <> "\".") _ -> throwError ("Unknown condition \"" <> cond <> "\".")- where setFlag :: ParserFlag -> Parser ()+ where setFlag :: Bool -> Parser () setFlag flag = modify' (\s -> s {flags = flag : flags s}) -- | Parse an 'endif' directive.
lib/Data/GI/CodeGen/Properties.hs view
@@ -59,8 +59,8 @@ TCArray True _ _ (TBasicType TUTF8) -> return "StringArray" TCArray True _ _ (TBasicType TFileName) -> return "StringArray" TGList (TBasicType TPtr) -> return "PtrGList"- t@(TInterface ns n) -> do- api <- findAPIByName (Name ns n)+ t@(TInterface n) -> do+ api <- findAPIByName n case api of APIEnum _ -> return "Enum" APIFlags _ -> return "Flags"@@ -91,7 +91,7 @@ return (constraints, t) genPropertySetter :: Text -> Name -> Text -> Property -> CodeGen ()-genPropertySetter setter n cName prop = group $ do+genPropertySetter setter n docSection prop = group $ do (constraints, t) <- attrType prop isNullable <- typeIsNullable (propType prop) cls <- classConstraint n@@ -104,10 +104,10 @@ <> if isNullable then "\" (Just val)" else "\" val"- exportProperty cName setter+ exportProperty docSection setter genPropertyGetter :: Text -> Name -> Text -> Property -> CodeGen ()-genPropertyGetter getter n cName prop = group $ do+genPropertyGetter getter n docSection prop = group $ do isNullable <- typeIsNullable (propType prop) let isMaybe = isNullable && propReadNullable prop /= Just False constructorType <- haskellType (propType prop)@@ -128,10 +128,10 @@ if tStr `elem` ["Object", "Boxed"] then " " <> tshow constructorType -- These require the constructor. else ""- exportProperty cName getter+ exportProperty docSection getter genPropertyConstructor :: Text -> Name -> Text -> Property -> CodeGen ()-genPropertyConstructor constructor n cName prop = group $ do+genPropertyConstructor constructor n docSection prop = group $ do (constraints, t) <- attrType prop tStr <- propTypeStr $ propType prop isNullable <- typeIsNullable (propType prop)@@ -145,10 +145,10 @@ <> if isNullable then "\" (Just val)" else "\" val"- exportProperty cName constructor+ exportProperty docSection constructor genPropertyClear :: Text -> Name -> Text -> Property -> CodeGen ()-genPropertyClear clear n cName prop = group $ do+genPropertyClear clear n docSection prop = group $ do nothingType <- tshow . maybeT <$> haskellType (propType prop) cls <- classConstraint n let constraints = ["MonadIO m", cls <> " o"]@@ -158,7 +158,7 @@ line $ clear <> " obj = liftIO $ setObjectProperty" <> tStr <> " obj \"" <> propName prop <> "\" (Nothing :: " <> nothingType <> ")"- exportProperty cName clear+ exportProperty docSection clear -- | The property name as a lexically valid Haskell identifier. Note -- that this is not escaped, since it is assumed that it will be used@@ -209,6 +209,7 @@ genOneProperty owner prop = do let name = upperName owner cName = (hyphensToCamelCase . propName) prop+ docSection = lcFirst cName pName = name <> cName flags = propFlags prop writable = PropertyWritable `elem` flags &&@@ -246,11 +247,11 @@ propWriteNullable prop /= Just False) "clear" owner cName - when (getter /= "undefined") $ genPropertyGetter getter owner cName prop- when (setter /= "undefined") $ genPropertySetter setter owner cName prop+ when (getter /= "undefined") $ genPropertyGetter getter owner docSection prop+ when (setter /= "undefined") $ genPropertySetter setter owner docSection prop when (constructor /= "undefined") $- genPropertyConstructor constructor owner cName prop- when (clear /= "undefined") $ genPropertyClear clear owner cName prop+ genPropertyConstructor constructor owner docSection prop+ when (clear /= "undefined") $ genPropertyClear clear owner docSection prop outType <- if not readable then return "()"@@ -289,7 +290,7 @@ then ["'AttrClear"] else []) it <- infoType owner prop- exportProperty cName it+ exportProperty docSection it bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do@@ -300,6 +301,7 @@ line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\""+ line $ "type AttrOrigin " <> it <> " = " <> name line $ "attrGet _ = " <> getter line $ "attrSet _ = " <> setter line $ "attrConstruct _ = " <> constructor@@ -312,7 +314,8 @@ line $ "-- XXX Placeholder" it <- infoType owner prop let cName = (hyphensToCamelCase . propName) prop- exportProperty cName it+ docSection = lcFirst cName+ exportProperty docSection it line $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do@@ -321,6 +324,7 @@ line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()" line $ "type AttrGetType " <> it <> " = ()" line $ "type AttrLabel " <> it <> " = \"\""+ line $ "type AttrOrigin " <> it <> " = " <> upperName owner line $ "attrGet = undefined" line $ "attrSet = undefined" line $ "attrConstruct = undefined"@@ -370,8 +374,9 @@ forM_ filteredAttrs $ \attr -> group $ do let cName = ucFirst attr labelProxy = lcFirst name <> cName+ docSection = lcFirst cName line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst cName <> "\"" line $ labelProxy <> " = AttrLabelProxy" - exportProperty cName labelProxy+ exportProperty docSection labelProxy
lib/Data/GI/CodeGen/Signal.hs view
@@ -9,6 +9,7 @@ #endif import Control.Monad (forM, forM_, when, unless) +import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Typeable (typeOf) import Data.Bool (bool)@@ -18,21 +19,29 @@ import Text.Show.Pretty (ppShow) import Data.GI.CodeGen.API-import Data.GI.CodeGen.Callable (hOutType, arrayLengths, wrapMaybe, fixupCallerAllocates)+import Data.GI.CodeGen.Callable (hOutType, wrapMaybe,+ fixupCallerAllocates,+ genDynamicCallableWrapper, ExposeClosures(..),+ callableHInArgs, callableHOutArgs) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Transfer (freeContainerType) import Data.GI.CodeGen.Type-import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst,- prime)+import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror,+ lcFirst, ucFirst, prime) -- The prototype of the callback on the Haskell side (what users of -- the binding will see)-genHaskellCallbackPrototype :: Text -> Callable -> Text -> [Arg] -> [Arg] ->+genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures -> ExcCodeGen ()-genHaskellCallbackPrototype subsec cb name' hInArgs hOutArgs = do- group $ do+genHaskellCallbackPrototype subsec cb htype expose = group $ do+ let name' = case expose of+ WithClosures -> callbackHTypeWithClosures htype+ WithoutClosures -> htype+ (hInArgs, _) = callableHInArgs cb expose+ hOutArgs = callableHOutArgs cb+ exportSignal subsec name' line $ "type " <> name' <> " =" indent $ do@@ -44,16 +53,16 @@ ret <- hOutType cb hOutArgs False line $ tshow $ io ret - -- For optional parameters, in case we want to pass Nothing.- group $ do+ -- For optional parameters, in case we want to pass Nothing. exportSignal subsec ("no" <> name') line $ "no" <> name' <> " :: Maybe " <> name' line $ "no" <> name' <> " = Nothing" --- Prototype of the callback on the C side-genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen ()+-- | Generate the type synonym for the prototype of the callback on+-- the C side. Returns the name given to the type synonym.+genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen Text genCCallbackPrototype subsec cb name' isSignal = group $ do- let ctypeName = name' <> "C"+ let ctypeName = callbackCType name' exportSignal subsec ctypeName line $ "type " <> ctypeName <> " ="@@ -70,29 +79,46 @@ Nothing -> return $ typeOf () Just t -> foreignType t line $ tshow ret+ return ctypeName -- Generator for wrappers callable from C genCallbackWrapperFactory :: Text -> Text -> CodeGen ()-genCallbackWrapperFactory subsec name' =- group $ do- let factoryName = "mk" <> name'+genCallbackWrapperFactory subsec name' = group $ do+ let factoryName = callbackWrapperAllocator name' line "foreign import ccall \"wrapper\""- indent $ line $ factoryName <> " :: "- <> name' <> "C -> IO (FunPtr " <> name' <> "C)"+ indent $ line $ factoryName <> " :: " <> callbackCType name'+ <> " -> IO (FunPtr " <> callbackCType name' <> ")" exportSignal subsec factoryName --- Generator of closures-genClosure :: Text -> Text -> Text -> Bool -> CodeGen ()-genClosure subsec callback closure isSignal = do+-- | Wrap the Haskell `cb` callback into a foreign function of the+-- right type. Returns the name of the wrapped value.+genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen Text+genWrappedCallback cb cbArg callback isSignal = do+ drop <- if callableHasClosures cb+ then do+ let arg' = prime cbArg+ line $ "let " <> arg' <> " = "+ <> callbackDropClosures callback <> " " <> cbArg+ return arg'+ else return cbArg+ line $ "let " <> prime drop <> " = " <> callbackHaskellToForeign callback <>+ if isSignal+ then " " <> drop+ else " Nothing " <> drop+ return (prime drop)++-- | Generator of closures+genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen ()+genClosure subsec cb callback name isSignal = group $ do+ let closure = callbackClosureGenerator name exportSignal subsec closure group $ do line $ closure <> " :: " <> callback <> " -> IO Closure"- line $ closure <> " cb = newCClosure =<< mk" <> callback <> " wrapped"- indent $- line $ "where wrapped = " <> lcFirst callback <> "Wrapper " <>- if isSignal- then "cb"- else "Nothing cb"+ line $ closure <> " cb = do"+ indent $ do+ wrapped <- genWrappedCallback cb "cb" callback isSignal+ line $ callbackWrapperAllocator callback <> " " <> wrapped+ <> " >>= newCClosure" -- Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL.@@ -176,30 +202,51 @@ else convert name' $ hToF (argType arg) TransferEverything line $ "poke " <> name <> " " <> name'' +-- | A simple wrapper that drops every closure argument.+genDropClosures :: Text -> Callable -> Text -> CodeGen ()+genDropClosures subsec cb name' = group $ do+ let dropper = callbackDropClosures name'+ (inWithClosures, _) = callableHInArgs cb WithClosures+ (inWithoutClosures, _) = callableHInArgs cb WithoutClosures+ passOrIgnore = \arg -> if arg `elem` inWithoutClosures+ then Just (escapedArgName arg)+ else Nothing+ argNames = map (maybe "_" id . passOrIgnore) inWithClosures++ exportSignal subsec dropper++ line $ dropper <> " :: " <> name' <> " -> " <> callbackHTypeWithClosures name'+ line $ dropper <> " _f " <> T.unwords argNames <> " = _f "+ <> T.unwords (catMaybes (map passOrIgnore inWithClosures))+ -- The wrapper itself, marshalling to and from Haskell. The first -- argument is possibly a pointer to a FunPtr to free (via -- freeHaskellFunPtr) once the callback is run once, or Nothing if the -- FunPtr will be freed by someone else (the function registering the -- callback for ScopeTypeCall, or a destroy notifier for -- ScopeTypeNotified).-genCallbackWrapper :: Text -> Callable -> Text -> [Arg] -> [Arg] -> [Arg] ->- Bool -> ExcCodeGen ()-genCallbackWrapper subsec cb name' dataptrs hInArgs hOutArgs isSignal = do- let cName arg = if arg `elem` dataptrs- then "_"- else escapedArgName arg- cArgNames = map cName (args cb)- wrapperName = lcFirst name' <> "Wrapper"+genCallbackWrapper :: Text -> Callable -> Text -> Bool -> ExcCodeGen ()+genCallbackWrapper subsec cb name' isSignal = group $ do+ let wrapperName = callbackHaskellToForeign name'+ (hInArgs, _) = callableHInArgs cb WithClosures+ hOutArgs = callableHOutArgs cb exportSignal subsec wrapperName group $ do line $ wrapperName <> " ::" indent $ do- unless isSignal $- line $ "Maybe (Ptr (FunPtr (" <> name' <> "C))) ->"- line $ name' <> " ->"- when isSignal $ line "Ptr () ->"+ if isSignal+ then do+ line $ name' <> " ->"+ line "Ptr () ->"+ else do+ line $ "Maybe (Ptr (FunPtr " <> callbackCType name' <> ")) ->"+ let hType = if callableHasClosures cb+ then callbackHTypeWithClosures name'+ else name'+ line $ hType <> " ->"+ forM_ (args cb) $ \arg -> do ht <- foreignType $ argType arg let ht' = if direction arg /= DirectionIn@@ -212,7 +259,8 @@ Just t -> foreignType t line $ tshow ret - let allArgs = if isSignal+ let cArgNames = map escapedArgName (args cb)+ allArgs = if isSignal then T.unwords $ ["_cb", "_"] <> cArgNames <> ["_"] else T.unwords $ ["funptrptr", "_cb"] <> cArgNames line $ wrapperName <> " " <> allArgs <> " = do"@@ -251,15 +299,7 @@ genCallback n (Callback cb) = do let name' = upperName n line $ "-- callback " <> name'-- let -- user_data pointers, which we generically omit- dataptrs = map (args cb !!) . filter (/= -1) . map argClosure $ args cb- hidden = dataptrs <> arrayLengths cb-- inArgs = filter ((/= DirectionOut) . direction) $ args cb- hInArgs = filter (not . (`elem` hidden)) inArgs- outArgs = filter ((/= DirectionIn) . direction) $ args cb- hOutArgs = filter (not . (`elem` hidden)) outArgs+ line $ "-- -> " <> tshow (fixupCallerAllocates cb) if skipReturn cb then group $ do@@ -267,17 +307,22 @@ line $ "-- Callbacks skipping return unsupported :\n" <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb) else do- let closure = lcFirst name' <> "Closure"- cb' = fixupCallerAllocates cb+ let cb' = fixupCallerAllocates cb handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for " <> name' <>- "\n-- Error was : " <> describeCGError e))- (genClosure name' name' closure False >>- genCCallbackPrototype name' cb' name' False >>- genCallbackWrapperFactory name' name' >>- genHaskellCallbackPrototype name' cb' name' hInArgs hOutArgs >>- genCallbackWrapper name' cb' name' dataptrs hInArgs hOutArgs False)+ "\n-- Error was : " <> describeCGError e)) $ do+ genClosure name' cb' name' name' False+ typeSynonym <- genCCallbackPrototype name' cb' name' False+ dynamic <- genDynamicCallableWrapper n typeSynonym cb False+ exportSignal name' dynamic+ genCallbackWrapperFactory name' name'+ line $ deprecatedPragma name' (callableDeprecated cb')+ genHaskellCallbackPrototype name' cb' name' WithoutClosures+ when (callableHasClosures cb') $ do+ genHaskellCallbackPrototype name' cb' name' WithClosures+ genDropClosures name' cb' name'+ genCallbackWrapper name' cb' name' False -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text@@ -290,24 +335,20 @@ line $ "-- signal " <> on' <> "::" <> sn - let inArgs = filter ((/= DirectionOut) . direction) $ args cb- hInArgs = filter (not . (`elem` arrayLengths cb)) inArgs- outArgs = filter ((/= DirectionIn) . direction) $ args cb- hOutArgs = filter (not . (`elem` arrayLengths cb)) outArgs- sn' = signalHaskellName (sn)+ let sn' = signalHaskellName (sn) signalConnectorName = on' <> ucFirst sn' cbType = signalConnectorName <> "Callback" - genHaskellCallbackPrototype (ucFirst sn') cb cbType hInArgs hOutArgs+ line $ deprecatedPragma cbType (callableDeprecated cb)+ genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures - genCCallbackPrototype (ucFirst sn') cb cbType True+ _ <- genCCallbackPrototype (lcFirst sn') cb cbType True - genCallbackWrapperFactory (ucFirst sn') cbType+ genCallbackWrapperFactory (lcFirst sn') cbType - let closure = lcFirst signalConnectorName <> "Closure"- genClosure (ucFirst sn') cbType closure True+ genClosure (lcFirst sn') cb cbType signalConnectorName True - genCallbackWrapper (ucFirst sn') cb cbType [] hInArgs hOutArgs True+ genCallbackWrapper (lcFirst sn') cb cbType True -- Wrapper for connecting functions to the signal -- We can connect to a signal either before the default handler runs@@ -325,8 +366,8 @@ line $ afterName <> signature line $ afterName <> " obj cb = connect" <> signalConnectorName <> " obj cb SignalConnectAfter"- exportSignal (ucFirst sn') onName- exportSignal (ucFirst sn') afterName+ exportSignal (lcFirst sn') onName+ exportSignal (lcFirst sn') afterName group $ do let fullName = "connect" <> signalConnectorName@@ -337,5 +378,7 @@ line $ T.replicate (4 + T.length fullName) " " <> signatureArgs line $ fullName <> " obj cb after = liftIO $ do" indent $ do- line $ "cb' <- mk" <> cbType <> " (" <> lcFirst cbType <> "Wrapper cb)"- line $ "connectSignalFunPtr obj \"" <> sn <> "\" cb' after"+ cb' <- genWrappedCallback cb "cb" cbType True+ let cb'' = prime cb'+ line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb'+ line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " after"
lib/Data/GI/CodeGen/Struct.hs view
@@ -49,7 +49,7 @@ case fieldCallback field of Nothing -> field Just _ -> let n' = fieldCallbackType structName field- in field {fieldType = TInterface ns n'}+ in field {fieldType = TInterface (Name ns n')} -- | Fix the interface names of callback fields in an APIStruct to -- correspond to the ones that we are going to generate. If something@@ -82,16 +82,36 @@ let fName = (underscoresToCamelCase . fieldName) field return $ name <> fName <> "FieldInfo" +-- | Whether a given field is an embedded struct/union.+isEmbedded :: Field -> CodeGen Bool+isEmbedded field+ | fieldIsPointer field = return False+ | otherwise = do+ api <- findAPI (fieldType field)+ case api of+ Just (APIStruct _) -> return True+ Just (APIUnion _) -> return True+ _ -> return False++-- Notice that when reading the field we return a copy of any embedded+-- structs, so modifications of the returned struct will not affect+-- the original struct. This is on purpose, in order to increase+-- safety (otherwise the garbage collector may decide to free the+-- parent structure while we are modifying the embedded one, and havoc+-- will ensue). -- | Extract a field from a struct. buildFieldReader :: Name -> Field -> ExcCodeGen () buildFieldReader n field = group $ do let name' = upperName n- let getter = fieldGetter n field+ getter = fieldGetter n field - isMaybe <- typeIsNullable (fieldType field)- hType <- tshow <$> if isMaybe- then maybeT <$> haskellType (fieldType field)- else haskellType (fieldType field)+ embedded <- isEmbedded field+ nullConvert <- if embedded+ then return Nothing+ else maybeNullConvert (fieldType field)+ hType <- tshow <$> if isJust nullConvert+ then maybeT <$> isoHaskellType (fieldType field)+ else isoHaskellType (fieldType field) fType <- tshow <$> foreignType (fieldType field) line $ getter <> " :: MonadIO m => " <> name' <> " -> m " <>@@ -100,14 +120,18 @@ else hType line $ getter <> " s = liftIO $ withManagedPtr s $ \\ptr -> do" indent $ do- line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field)- <> ") :: IO " <> if T.any (== ' ') fType- then parenthesize fType- else fType- result <- if not isMaybe- then convert "val" $ fToH (fieldType field) TransferNothing- else do- line $ "result <- convertIfNonNull val $ \\val' -> do"+ let peekedType = if T.any (== ' ') fType+ then parenthesize fType+ else fType+ if embedded+ then line $ "let val = ptr `plusPtr` " <> tshow (fieldOffset field)+ <> " :: " <> peekedType+ else line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field)+ <> ") :: IO " <> peekedType+ result <- case nullConvert of+ Nothing -> convert "val" $ fToH (fieldType field) TransferNothing+ Just nullConverter -> do+ line $ "result <- " <> nullConverter <> " val $ \\val' -> do" indent $ do val' <- convert "val'" $ fToH (fieldType field) TransferNothing line $ "return " <> val'@@ -143,8 +167,8 @@ <> ") (" <> converted <> " :: " <> fType <> ")" -- | Write a @NULL@ into a field of a struct of type `Ptr`.-buildFieldClear :: Name -> Field -> ExcCodeGen ()-buildFieldClear n field = group $ do+buildFieldClear :: Name -> Field -> Text -> ExcCodeGen ()+buildFieldClear n field nullPtr = group $ do let name' = upperName n let clear = fieldClear n field @@ -152,9 +176,9 @@ line $ clear <> " :: MonadIO m => " <> name' <> " -> m ()" line $ clear <> " s = liftIO $ withManagedPtr s $ \\ptr -> do"- indent $ do+ indent $ line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)- <> ") (nullPtr :: " <> fType <> ")"+ <> ") (" <> nullPtr <> " :: " <> fType <> ")" -- | Name for the getter function fieldGetter :: Name -> Field -> Text@@ -182,10 +206,11 @@ isPtr <- typeIsPtr (fieldType field) + embedded <- isEmbedded field isNullable <- typeIsNullable (fieldType field)- outType <- tshow <$> if isNullable- then maybeT <$> haskellType (fieldType field)- else haskellType (fieldType field)+ outType <- tshow <$> if not embedded && isNullable+ then maybeT <$> isoHaskellType (fieldType field)+ else isoHaskellType (fieldType field) inType <- if isPtr then tshow <$> foreignType (fieldType field) else tshow <$> haskellType (fieldType field)@@ -194,9 +219,11 @@ line $ "instance AttrInfo " <> it <> " where" indent $ do line $ "type AttrAllowedOps " <> it <>- if isPtr- then " = '[ 'AttrSet, 'AttrGet, 'AttrClear]"- else " = '[ 'AttrSet, 'AttrGet]"+ if embedded+ then " = '[ 'AttrGet]"+ else if isPtr+ then " = '[ 'AttrSet, 'AttrGet, 'AttrClear]"+ else " = '[ 'AttrSet, 'AttrGet]" line $ "type AttrSetTypeConstraint " <> it <> " = (~) " <> if T.any (== ' ') inType then parenthesize inType@@ -204,21 +231,24 @@ line $ "type AttrBaseTypeConstraint " <> it <> " = (~) " <> on line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> fieldName field <> "\""+ line $ "type AttrOrigin " <> it <> " = " <> on line $ "attrGet _ = " <> fieldGetter owner field- line $ "attrSet _ = " <> fieldSetter owner field+ line $ "attrSet _ = " <> if not embedded+ then fieldSetter owner field+ else "undefined" line $ "attrConstruct = undefined"- line $ "attrClear _ = " <> if isPtr+ line $ "attrClear _ = " <> if not embedded && isPtr then fieldClear owner field else "undefined" blank group $ do- let labelProxy = lcFirst on <> fName field+ let labelProxy = lcFirst on <> "_" <> lcFirst (fName field) line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst (fName field) <> "\"" line $ labelProxy <> " = AttrLabelProxy" - exportProperty (fName field) labelProxy+ exportProperty (lcFirst $ fName field) labelProxy return $ "'(\"" <> (lcFirst . fName) field <> "\", " <> it <> ")" @@ -227,25 +257,30 @@ | not (fieldVisible field) = return Nothing | privateType (fieldType field) = return Nothing | otherwise = group $ do- isPtr <- typeIsPtr (fieldType field)+ nullPtr <- nullPtrForType (fieldType field) + embedded <- isEmbedded field+ buildFieldReader n field- buildFieldWriter n field- when isPtr $- buildFieldClear n field+ exportProperty (lcFirst $ fName field) (fieldGetter n field) - exportProperty (fName field) (fieldGetter n field)- exportProperty (fName field) (fieldSetter n field)- when isPtr $- exportProperty (fName field) (fieldClear n field)+ when (not embedded) $ do+ buildFieldWriter n field+ exportProperty (lcFirst $ fName field) (fieldSetter n field) + case nullPtr of+ Just null -> do+ buildFieldClear n field null+ exportProperty (lcFirst $ fName field) (fieldClear n field)+ Nothing -> return ()+ cfg <- config if cgOverloadedProperties (cgFlags cfg) then Just <$> genAttrInfo n field else return Nothing where privateType :: Type -> Bool- privateType (TInterface _ n) = "Private" `T.isSuffixOf` n+ privateType (TInterface n) = "Private" `T.isSuffixOf` name n privateType _ = False genStructOrUnionFields :: Name -> [Field] -> CodeGen ()
lib/Data/GI/CodeGen/SymbolNaming.hs view
@@ -11,6 +11,15 @@ , hyphensToCamelCase , underscoresToCamelCase + , callbackCType+ , callbackHTypeWithClosures+ , callbackDropClosures+ , callbackDynamicWrapper+ , callbackWrapperAllocator+ , callbackHaskellToForeign+ , callbackHaskellToForeignWithClosures+ , callbackClosureGenerator+ , submoduleLocation , qualifiedAPI , qualifiedSymbol@@ -24,7 +33,7 @@ import Data.GI.CodeGen.Code (CodeGen, ModuleName, group, line, exportDecl, qualified, getAPI) import Data.GI.CodeGen.Type (Type(TInterface))-import Data.GI.CodeGen.Util (lcFirst, ucFirst)+import Data.GI.CodeGen.Util (lcFirst, ucFirst, modifyQualified) -- | Return a qualified form of the constraint for the given name -- (which should correspond to a valid `TInterface`).@@ -34,9 +43,52 @@ -- | Same as `classConstraint`, but applicable directly to a type. The -- type should be a `TInterface`, otherwise an error will be raised. typeConstraint :: Type -> CodeGen Text-typeConstraint (TInterface ns s) = classConstraint (Name ns s)+typeConstraint (TInterface n) = classConstraint n typeConstraint t = error $ "Class constraint for non-interface type: " <> show t +-- | Foreign type associated with a callback type. It can be passed in+-- qualified.+callbackCType :: Text -> Text+callbackCType = modifyQualified ("C_" <>)++-- | Haskell type exposing the closure arguments, which are generally+-- elided.+callbackHTypeWithClosures :: Text -> Text+callbackHTypeWithClosures = modifyQualified (<> "_WithClosures")++-- | The name of the dynamic wrapper for the given callback type. It+-- can be passed in qualified.+callbackDynamicWrapper :: Text -> Text+callbackDynamicWrapper = modifyQualified ("dynamic_" <>)++-- | The name of the Haskell to foreign wrapper for the given callback+-- type. It can be passed in qualified.+callbackHaskellToForeign :: Text -> Text+callbackHaskellToForeign = modifyQualified ("wrap_" <>)++-- | The name of the Haskell to foreign wrapper for the given callback+-- type, keeping the closure arguments (we usually elide them). The+-- callback type can be passed in qualified.+callbackHaskellToForeignWithClosures :: Text -> Text+callbackHaskellToForeignWithClosures = modifyQualified ("with_closures_" <>)++-- | The name of a function which takes a callback without closure+-- arguments, and generates a function which does accep the closures,+-- but simply ignores them.+callbackDropClosures :: Text -> Text+callbackDropClosures = modifyQualified ("drop_closures_" <>)++-- | The name for the foreign wrapper allocator (@foreign import+-- "wrapper" ...@) for the given callback type. It can be passed in+-- qualified.+callbackWrapperAllocator :: Text -> Text+callbackWrapperAllocator = modifyQualified ("mk_" <>)++-- | The name for the closure generator for the given callback+-- type. It can be passed in qualified.+callbackClosureGenerator :: Text -> Text+callbackClosureGenerator = modifyQualified ("genClosure_" <>)+ -- | Move leading underscores to the end (for example in -- GObject::_Value_Data_Union -> GObject::Value_Data_Union_) sanitize :: Text -> Text@@ -55,14 +107,14 @@ -- | Return an identifier for the given interface type valid in the current -- module. qualifiedAPI :: Name -> CodeGen Text-qualifiedAPI n@(Name ns s) = do- api <- getAPI (TInterface ns s)+qualifiedAPI n@(Name ns _) = do+ api <- getAPI (TInterface n) qualified ("GI" : ucFirst ns : submoduleLocation n api) n -- | Construct an identifier for the given symbol in the given API. qualifiedSymbol :: Text -> Name -> CodeGen Text-qualifiedSymbol s n@(Name ns nn) = do- api <- getAPI (TInterface ns nn)+qualifiedSymbol s n@(Name ns _) = do+ api <- getAPI (TInterface n) qualified ("GI" : ucFirst ns : submoduleLocation n api) (Name ns s) -- | Construct the submodule name (as a list, to be joined by
lib/Data/GI/CodeGen/Transfer.hs view
@@ -11,7 +11,6 @@ #endif import Control.Monad (when)-import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Text (Text) @@ -30,7 +29,7 @@ basicFreeFn (TBasicType TUTF8) = Just "freeMem" basicFreeFn (TBasicType TFileName) = Just "freeMem" basicFreeFn (TBasicType _) = Nothing-basicFreeFn (TInterface _ _) = Nothing+basicFreeFn (TInterface _) = Nothing basicFreeFn (TCArray False (-1) (-1) _) = Nothing -- Just passing it along basicFreeFn (TCArray{}) = Just "freeMem" basicFreeFn (TGArray _) = Just "unrefGArray"@@ -59,7 +58,7 @@ return $ if transfer == TransferEverything then Just "unrefGParamSpec" else Nothing-basicFreeFnOnError t@(TInterface _ _) transfer = do+basicFreeFnOnError t@(TInterface _) transfer = do api <- findAPI t case api of Just (APIObject _) -> if transfer == TransferEverything@@ -226,20 +225,14 @@ -- transfer semantics of the callable). freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text] freeInArg arg label len = do- weAlloc <- isJust <$> requiresAlloc (argType arg) -- Arguments that we alloc ourselves do not need to be freed, they -- will always be soaked up by the wrapPtr constructor, or they will -- be DirectionIn.- if not weAlloc+ if not (argCallerAllocates arg) then case direction arg of DirectionIn -> freeIn (transfer arg) (argType arg) label len DirectionOut -> freeOut label- DirectionInout ->- -- Caller-allocates arguments are like "in" arguments for- -- memory management purposes.- if argCallerAllocates arg- then freeIn (transfer arg) (argType arg) label len- else freeOut label+ DirectionInout -> freeOut label else return [] -- | Same thing as freeInArg, but called in case the call to C didn't
lib/Data/GI/CodeGen/Util.hs view
@@ -8,6 +8,8 @@ , ucFirst , lcFirst + , modifyQualified+ , tshow , terror ) where@@ -46,3 +48,14 @@ lcFirst :: Text -> Text lcFirst "" = "" lcFirst t = T.cons (toLower $ T.head t) (T.tail t)++-- | Apply the given modification function to the given symbol. If the+-- symbol is qualified the modification will only apply to the last+-- component.+modifyQualified :: (Text -> Text) -> Text -> Text+modifyQualified f = T.intercalate "." . modify . T.splitOn "."+ where modify :: [Text] -> [Text]+ modify [] = []+ modify (a:[]) = f a : []+ modify (a:as) = a : modify as+
lib/Data/GI/GIR/Alias.hs view
@@ -20,7 +20,7 @@ Just nsName -> case runParser nsName M.empty ns parseAliases of Left err -> (error . T.unpack) err Right aliases -> M.fromList (map addNS aliases)- where addNS (n, t) = (Alias (nsName, n), t)+ where addNS (n, t) = (Alias (Name nsName n), t) -- | Parse all the aliases in the current namespace parseAliases :: Parser [(Text, Type)]
lib/Data/GI/GIR/BasicTypes.hs view
@@ -20,7 +20,7 @@ deriving (Show, Eq, Ord) -- | An alias, which is simply (Namespace, name).-newtype Alias = Alias (Text, Text) deriving (Ord, Eq, Show)+newtype Alias = Alias Name deriving (Ord, Eq, Show) -- | Basic types. These are generally trivial to marshal, and the GIR -- assumes that they are defined.@@ -63,5 +63,5 @@ | TGList Type -- ^ GList | TGSList Type -- ^ GSList | TGHash Type Type -- ^ GHashTable- | TInterface Text Text -- ^ A reference to some API in the GIR+ | TInterface Name -- ^ A reference to some API in the GIR deriving (Eq, Show, Ord)
lib/Data/GI/GIR/Field.hs view
@@ -6,17 +6,18 @@ ) where import Data.Monoid ((<>))-import Data.Text (Text)+import Data.Text (Text, isSuffixOf) import Data.GI.GIR.BasicTypes (Type(..)) import Data.GI.GIR.Callback (Callback, parseCallback)-import Data.GI.GIR.Type (parseType)+import Data.GI.GIR.Type (parseType, parseCType) import Data.GI.GIR.Parser data Field = Field { fieldName :: Text, fieldVisible :: Bool, fieldType :: Type,+ fieldIsPointer :: Bool, fieldCallback :: Maybe Callback, fieldOffset :: Int, fieldFlags :: [FieldInfoFlag],@@ -40,7 +41,7 @@ <> if writable then [FieldIsWritable] else [] introspectable <- optionalAttr "introspectable" True parseBool private <- optionalAttr "private" False parseBool- (t, callback) <-+ (t, ctype, callback) <- if introspectable then do callbacks <- parseChildrenWithLocalName "callback" parseCallback@@ -48,22 +49,27 @@ [] -> return (Nothing, Nothing) [(n, cb)] -> return (Just n, Just cb) _ -> parseError "Multiple callbacks in field"- t <- case cbn of- Nothing -> parseType- Just (Name ns n) -> return (TInterface ns n)- return (t, callback)+ (t, ct) <- case cbn of+ Nothing -> do+ t <- parseType+ ct <- parseCType+ return (t, Just ct)+ Just n -> return (TInterface n, Nothing)+ return (t, ct, callback) else do callbacks <- parseAllChildrenWithLocalName "callback" parseName case callbacks of [] -> do t <- parseType- return (t, Nothing)- [Name ns n] -> return (TInterface ns n, Nothing)+ ct <- parseCType+ return (t, Just ct, Nothing)+ [n] -> return (TInterface n, Nothing, Nothing) _ -> parseError "Multiple callbacks in field" return $ Field { fieldName = name , fieldVisible = introspectable && not private , fieldType = t+ , fieldIsPointer = maybe True ("*" `isSuffixOf`) ctype , fieldCallback = callback , fieldOffset = error ("unfixed field offset " ++ show name) , fieldFlags = flags
lib/Data/GI/GIR/Method.hs view
@@ -6,6 +6,7 @@ import Data.Text (Text) +import Data.GI.GIR.Arg (Arg, parseArg) import Data.GI.GIR.Callable (Callable(..), parseCallable) import Data.GI.GIR.Parser @@ -24,6 +25,16 @@ methodCallable :: Callable } deriving (Eq, Show) +parseInstanceArg :: Parser Arg+parseInstanceArg = do+ instanceInfo <- parseChildrenWithLocalName "parameters" parseInstPars+ case instanceInfo of+ [[inst]] -> return inst+ [] -> parseError $ "No instance-parameter found."+ _ -> parseError $ "Too many instance parameters."+ where parseInstPars :: Parser [Arg]+ parseInstPars = parseChildrenWithLocalName "instance-parameter" parseArg+ parseMethod :: MethodType -> Parser Method parseMethod mType = do name <- parseName@@ -31,7 +42,12 @@ let exposedName = case shadows of Just n -> name {name = n} Nothing -> name- callable <- parseCallable+ callable <- if mType /= OrdinaryMethod+ then parseCallable+ else do+ c <- parseCallable+ instanceArg <- parseInstanceArg+ return $ c {args = instanceArg : args c} symbol <- getAttrWithNamespace CGIRNS "identifier" throws <- optionalAttr "throws" False parseBool movedTo <- queryAttr "moved-to"
lib/Data/GI/GIR/Parser.hs view
@@ -101,15 +101,15 @@ -- | Check whether there is an alias for the given name, and return -- the corresponding type in case it exists, and otherwise a TInterface.-resolveQualifiedTypeName :: Text -> Text -> Parser Type-resolveQualifiedTypeName ns n = do+resolveQualifiedTypeName :: Name -> Parser Type+resolveQualifiedTypeName name = do ctx <- ask- case M.lookup (Alias (ns, n)) (knownAliases ctx) of+ case M.lookup (Alias name) (knownAliases ctx) of -- The resolved type may be an alias itself, like for -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt- Just (TInterface ns n) -> resolveQualifiedTypeName ns n+ Just (TInterface n) -> resolveQualifiedTypeName n Just t -> return t- Nothing -> return $ TInterface ns n+ Nothing -> return $ TInterface name -- | Return the value of an attribute for the given element. If the -- attribute is not present this throws an error.
lib/Data/GI/GIR/Type.hs view
@@ -2,6 +2,7 @@ -- | Parsing type information from GIR files. module Data.GI.GIR.Type ( parseType+ , parseCType , parseOptionalType ) where @@ -113,7 +114,7 @@ parseFundamentalType "GLib" "Variant" = return TVariant parseFundamentalType "GObject" "ParamSpec" = return TParamSpec -- A TInterface type (basically, everything that is not of a known type).-parseFundamentalType ns n = resolveQualifiedTypeName ns n+parseFundamentalType ns n = resolveQualifiedTypeName (Name ns n) -- | Parse information on a "type" element. Returns either a `Type`, -- or `Nothing` indicating that the name of the type in the@@ -140,6 +141,19 @@ arrays <- parseChildrenWithLocalName "array" parseArrayInfo return (types ++ map Just arrays) +-- | Find the C name (or if not present, the introspection name) for+-- the current element.+parseCTypeName :: Parser Text+parseCTypeName = queryAttrWithNamespace CGIRNS "type"+ >>= maybe (getAttr "name") return++-- | Find the children giving the C type for the element.+parseCTypeNameElements :: Parser [Text]+parseCTypeNameElements = do+ types <- parseChildrenWithLocalName "type" parseCTypeName+ arrays <- parseChildrenWithLocalName "array" parseCTypeName+ return (types ++ arrays)+ -- | Try to find a type node, but do not error out if it is not -- found. This _does_ give an error if more than one type node is -- found, or if the type name is "none".@@ -166,3 +180,11 @@ [e] -> return e [] -> parseError $ "Did not find a type for the element." _ -> parseError $ "Found more than one type for the element."++-- | Parse the C-type associated to the element. If there is no+-- "c:type" attribute we return the type name.+parseCType :: Parser Text+parseCType = parseCTypeNameElements >>= \case+ [e] -> return e+ [] -> parseError $ "Did not find a C type for the element."+ _ -> parseError $ "Found more than one type for the element."