haskell-gi 0.12 → 0.13
raw patch · 30 files changed
+894/−422 lines, 30 filesdep ~haskell-gi-base
Dependency ranges changed: haskell-gi-base
Files
- haskell-gi.cabal +4/−3
- src/GI/API.hs +2/−1
- src/GI/Attributes.hs +0/−54
- src/GI/Cabal.hs +7/−5
- src/GI/Callable.hs +304/−200
- src/GI/Code.hs +56/−5
- src/GI/CodeGen.hs +101/−43
- src/GI/Constant.hs +13/−5
- src/GI/Conversions.hs +2/−0
- src/GI/GIR/Arg.hs +7/−2
- src/GI/GIR/Function.hs +6/−3
- src/GI/GIR/Interface.hs +1/−1
- src/GI/GIR/Method.hs +10/−6
- src/GI/GIR/Object.hs +1/−1
- src/GI/GIR/Struct.hs +3/−2
- src/GI/GIR/Type.hs +2/−0
- src/GI/GIR/Union.hs +3/−2
- src/GI/Inheritance.hs +30/−10
- src/GI/OverloadedLabels.hs +84/−0
- src/GI/OverloadedMethods.hs +106/−0
- src/GI/OverloadedSignals.hs +25/−31
- src/GI/Overrides.hs +7/−7
- src/GI/Properties.hs +10/−4
- src/GI/Signal.hs +26/−13
- src/GI/Struct.hs +26/−0
- src/GI/SymbolNaming.hs +13/−6
- src/GI/Transfer.hs +12/−2
- src/GI/Type.hs +17/−1
- src/GI/Util.hs +2/−2
- src/haskell-gi.hs +14/−13
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name: haskell-gi-version: 0.12+version: 0.13 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too.@@ -36,7 +36,7 @@ bytestring, xdg-basedir, xml-conduit >= 1.3.0,- haskell-gi-base == 0.12.*,+ haskell-gi-base == 0.13.*, text >= 1.0, free @@ -66,7 +66,6 @@ GI.GIR.Union, GI.GIR.XMLUtils, GI.API,- GI.Attributes, GI.Cabal, GI.Callable, GI.Code,@@ -79,6 +78,8 @@ GI.Inheritance, GI.LibGIRepository, GI.OverloadedSignals,+ GI.OverloadedLabels,+ GI.OverloadedMethods, GI.Overrides, GI.PkgConfig, GI.ProjectInfo,
src/GI/API.hs view
@@ -213,8 +213,9 @@ let (name, version) = S.elemAt 0 requested doc <- readGiRepository verbose name (Just version) extraPaths let newLoaded = M.insert (name, version) doc loaded+ loadedSet = S.fromList (M.keys newLoaded) newRequested = S.union requested (documentListIncludes doc)- notYetLoaded = S.filter (/= (name, version)) newRequested+ notYetLoaded = S.difference newRequested loadedSet loadDependencies verbose notYetLoaded newLoaded extraPaths -- | Load a given GIR file and recursively its dependencies
− src/GI/Attributes.hs
@@ -1,54 +0,0 @@-module GI.Attributes- ( genAllAttributes- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (forM_)-import qualified Data.Set as S-import Data.Text (Text)--import GI.API-import GI.Code-import GI.SymbolNaming-import GI.Util (lcFirst)---- A list of distinct property names for all GObjects appearing in the--- given list of APIs.-findObjectPropNames :: [(Name, API)] -> CodeGen [Text]-findObjectPropNames apis = S.toList <$> go apis S.empty- where- go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)- go [] set = return set- go ((_, api):apis) set =- case api of- APIInterface iface ->- go apis $ insertProps (ifProperties iface) set- APIObject object ->- go apis $ insertProps (objProperties object) set- _ -> go apis set-- insertProps :: [Property] -> S.Set Text -> S.Set Text- insertProps props set = S.union set ((S.fromList . map propName) props)--genPropertyAttr :: Text -> CodeGen ()-genPropertyAttr pName = group $ do- line $ "-- Property \"" <> pName <> "\""- let name = hyphensToCamelCase pName- line $ "_" <> lcFirst name <> " :: Proxy \"" <> pName <> "\""- line $ "_" <> lcFirst name <> " = Proxy"- exportToplevel ("_" <> lcFirst name)--genAllAttributes :: [(Name, API)] -> CodeGen ()-genAllAttributes allAPIs = do- setLanguagePragmas ["DataKinds"]- setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]-- line $ "import Data.Proxy (Proxy(..))"- blank-- propNames <- findObjectPropNames allAPIs- forM_ propNames $ \name -> do- genPropertyAttr name- blank
src/GI/Cabal.hs view
@@ -117,8 +117,9 @@ -- | Try to generate the cabal project. In case of error return the -- corresponding error string.-genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> CodeGen (Maybe Text)-genCabalProject gir deps exposedModules =+genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> BaseVersion ->+ CodeGen (Maybe Text)+genCabalProject gir deps exposedModules minBaseVersion = handleCGExc (return . Just . describeCGError) $ do cfg <- config let pkMap = pkgConfigMap (overrides cfg)@@ -148,15 +149,16 @@ line $ "library" indent $ do line $ padTo 20 "default-language:" <> "Haskell2010"- line $ padTo 20 "default-extensions:" <> "OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts"- line $ padTo 20 "other-extensions:" <> "PatternSynonyms ScopedTypeVariables, ViewPatterns"+ line $ padTo 20 "default-extensions:" <> "ScopedTypeVariables, CPP, OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts"+ line $ padTo 20 "other-extensions:" <> "PatternSynonyms ViewPatterns" line $ padTo 20 "ghc-options:" <> "-fno-warn-unused-imports -fno-warn-warnings-deprecations" line $ padTo 20 "exposed-modules:" <> head exposedModules forM_ (tail exposedModules) $ \mod -> line $ padTo 20 "" <> mod line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= " <> tshow major <> "." <> tshow minor- line $ padTo 20 "build-depends: base >= 4.7 && <5,"+ line $ padTo 20 "build-depends: base >= "+ <> showBaseVersion minBaseVersion <> " && <5," indent $ do line $ "haskell-gi-base >= " <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor
src/GI/Callable.hs view
@@ -5,6 +5,8 @@ , hOutType , arrayLengths , arrayLengthsMap+ , callableSignature+ , fixupCallerAllocates , wrapMaybe , inArgInterfaces@@ -17,6 +19,7 @@ import Data.Bool (bool) import Data.List (nub, (\\)) import Data.Maybe (isJust)+import Data.Tuple (swap) import Data.Typeable (TypeRep, typeOf) import qualified Data.Map as Map import qualified Data.Text as T@@ -65,12 +68,14 @@ fArgStr arg = do ft <- foreignType $ argType arg weAlloc <- isJust <$> requiresAlloc (argType arg)- let ft' = if direction arg == DirectionIn || weAlloc then+ let ft' = if direction arg == DirectionIn || weAlloc+ || argCallerAllocates arg+ then ft else ptr ft let start = tshow ft' <> " -> "- return $ padTo 40 start <> "-- " <> (argName arg)+ return $ padTo 40 start <> "-- " <> (argCName arg) <> " : " <> tshow (argType arg) last = tshow <$> io <$> case returnType callable of TBasicType TVoid -> return $ typeOf ()@@ -94,7 +99,7 @@ nullable <- isNullable (argType arg) if nullable then return True- else badIntroError $ "argument \"" <> (argName arg)+ else badIntroError $ "argument \"" <> (argCName arg) <> "\" is not of nullable type (" <> tshow (argType arg) <> "), but it is marked as such." else return False@@ -171,8 +176,8 @@ -- Read the length of an array into the corresponding variable. readInArrayLength :: Arg -> Arg -> ExcCodeGen () readInArrayLength array length = do- let lvar = escapeReserved $ argName length- avar = escapeReserved $ argName array+ let lvar = escapedArgName length+ avar = escapedArgName array wrapMaybe array >>= bool (do al <- computeArrayLength avar (argType array)@@ -189,12 +194,12 @@ -- variable. checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen () checkInArrayLength n array length previous = do- name <- lowerName n- let funcName = namespace n <> "." <> name- lvar = escapeReserved $ argName length- avar = escapeReserved $ argName array+ let name = lowerName n+ funcName = namespace n <> "." <> name+ lvar = escapedArgName length+ avar = escapedArgName array expectedLength = avar <> "_expected_length_"- pvar = escapeReserved $ argName previous+ pvar = escapedArgName previous wrapMaybe array >>= bool (do al <- computeArrayLength avar (argType array)@@ -229,13 +234,13 @@ where actions :: ExcCodeGen [[Text]] actions = forM (args callable) $ \arg ->- case Map.lookup (escapeReserved $ argName arg) nameMap of+ case Map.lookup (escapedArgName arg) nameMap of Just name -> freeFn arg name $ -- Pass in the length argument in case it's needed. case argType arg of TCArray False (-1) (-1) _ -> undefined TCArray False (-1) length _ ->- escapeReserved $ argName $ (args callable)!!length+ escapedArgName $ (args callable)!!length _ -> undefined Nothing -> badIntroError $ "freeInArgs: do not understand " <> tshow arg @@ -263,7 +268,7 @@ case direction arg of DirectionIn -> if arg `elem` omitted- then return . escapeReserved . argName $ arg+ then return . escapedArgName $ arg else if isCallback then prepareInCallback arg else prepareInArg arg@@ -272,7 +277,7 @@ prepareInArg :: Arg -> ExcCodeGen Text prepareInArg arg = do- let name = escapeReserved $ argName arg+ let name = escapedArgName arg wrapMaybe arg >>= bool (convert name $ hToF (argType arg) (transfer arg)) (do@@ -291,7 +296,7 @@ -- Callbacks are a fairly special case, we treat them separately. prepareInCallback :: Arg -> ExcCodeGen Text prepareInCallback arg = do- let name = escapeReserved $ argName arg+ let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg @@ -358,14 +363,17 @@ -- The semantics of this case are somewhat undefined. (notImplementedError "Nullable inout structs not supported") Nothing -> do- name'' <- genConversion (prime name') $- literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)- line $ "poke " <> name'' <> " " <> name'- return name''+ if argCallerAllocates arg+ then return name'+ else do+ name'' <- genConversion (prime name') $+ literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)+ line $ "poke " <> name'' <> " " <> name'+ return name'' prepareOutArg :: Arg -> CodeGen Text prepareOutArg arg = do- let name = escapeReserved $ argName arg+ let name = escapedArgName arg ft <- foreignType $ argType arg allocInfo <- requiresAlloc (argType arg) case allocInfo of@@ -382,9 +390,9 @@ -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object. convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text ->- Transfer -> ExcCodeGen Text+ Transfer -> (Text -> Text) -> ExcCodeGen Text convertOutCArray callable t@(TCArray False fixed length _) aname- nameMap transfer = do+ nameMap transfer primeLength = do if fixed > -1 then do unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer@@ -394,26 +402,26 @@ else do when (length == -1) $ badIntroError $ "Unknown length for \"" <> aname <> "\""- let lname = escapeReserved $ argName $ (args callable)!!length+ let lname = escapedArgName $ (args callable)!!length lname' <- case Map.lookup lname nameMap of Just n -> return n Nothing -> badIntroError $ "Couldn't find out array length " <> lname- let lname'' = prime lname'+ let lname'' = primeLength lname' unpacked <- convert aname $ unpackCArray lname'' t transfer -- Free the memory associated with the array freeContainerType transfer t aname lname'' return unpacked -- Remove the warning, this should never be reached.-convertOutCArray _ t _ _ _ =+convertOutCArray _ t _ _ _ _ = terror $ "convertOutCArray : unexpected " <> tshow t -- Read the array lengths for out arguments. readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen () readOutArrayLengths callable nameMap = do- let lNames = nub $ map (escapeReserved . argName) $+ let lNames = nub $ map escapedArgName $ filter ((/= DirectionIn) . direction) $ arrayLengths callable forM_ lNames $ \lname -> do@@ -428,7 +436,7 @@ -- C function was called. touchInArg :: Arg -> ExcCodeGen () touchInArg arg = when (direction arg /= DirectionOut) $ do- let name = escapeReserved $ argName arg+ let name = escapedArgName arg case elementType (argType arg) of Just a -> do managed <- isManaged a@@ -480,8 +488,8 @@ <> "\n" <> T.pack (ppShow m) <> "\n" <> tshow closure Just cb -> do- let closureName = escapeReserved $ argName $ (args callable)!!closure- n = escapeReserved $ argName cb+ let closureName = escapedArgName $ (args callable)!!closure+ n = escapedArgName cb n' <- case Map.lookup n nameMap of Just n -> return n Nothing -> badIntroError $ "Cannot find closure name!! "@@ -497,7 +505,7 @@ "ScopeTypeNotified without destructor! " <> T.pack (ppShow callable) k -> let destroyName =- escapeReserved . argName $ (args callable)!!k in+ escapedArgName $ (args callable)!!k in line $ "let " <> destroyName <> " = safeFreeFunPtrPtr" ScopeTypeAsync -> line $ "let " <> closureName <> " = nullPtr"@@ -506,7 +514,7 @@ freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen () freeCallCallbacks callable nameMap = forM_ (args callable) $ \arg -> do- let name = escapeReserved $ argName arg+ let name = escapedArgName arg name' <- case Map.lookup name nameMap of Just n -> return n Nothing -> badIntroError $ "Could not find " <> name@@ -515,123 +523,70 @@ when (argScope arg == ScopeTypeCall) $ line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' -hSignature :: [Arg] -> TypeRep -> ExcCodeGen ()-hSignature hInArgs retType = do- (argConstraints, types) <- inArgInterfaces hInArgs+formatHSignature :: Callable -> Bool -> ExcCodeGen ()+formatHSignature callable throwsGError = do+ (constraints, vars) <- callableSignature callable throwsGError indent $ do- line $ "(" <> T.intercalate ", " ("MonadIO m" : argConstraints) <> ") =>"- forM_ (zip types hInArgs) $ \(t, a) ->- line $ withComment (t <> " ->") $ (argName a)- line . tshow $ "m" `con` [retType]+ line $ "(" <> T.intercalate ", " constraints <> ") =>"+ forM_ (zip ("" : repeat "-> ") vars) $ \(prefix, (t, name)) ->+ line $ withComment (prefix <> t) name -genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()-genCallable n symbol callable throwsGError = do- group $ do- line $ "-- Args : " <> (tshow $ args callable)- line $ "-- Lengths : " <> (tshow $ arrayLengths callable)- line $ "-- hInArgs : " <> tshow hInArgs- line $ "-- returnType : " <> (tshow $ returnType callable)- line $ "-- throws : " <> (tshow throwsGError)- line $ "-- Skip return : " <> (tshow $ skipReturn callable)- when (skipReturn callable && returnType callable /= TBasicType TBoolean) $- do line "-- XXX return value ignored, but it is not a boolean."- line "-- This may be a memory leak?"- mkForeignImport symbol callable throwsGError- blank- wrapper+-- | 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+ let (hInArgs, _) = callableHInArgs callable+ (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) - where- 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- hInArgs = filter (`notElem` omitted) inArgs- outArgs = filter ((/= DirectionIn) . direction) $ args callable- hOutArgs = filter (`notElem` (arrayLengths callable)) outArgs+-- | "In" arguments for the given callable on the Haskell side,+-- together with the omitted arguments.+callableHInArgs :: Callable -> ([Arg], [Arg])+callableHInArgs callable =+ 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+ in (filter (`notElem` omitted) inArgs, omitted) - ignoreReturn = skipRetVal callable throwsGError+-- | "Out" arguments for the given callable on the Haskell side.+callableHOutArgs :: Callable -> [Arg]+callableHOutArgs callable =+ let outArgs = filter ((/= DirectionIn) . direction) $ args callable+ in filter (`notElem` (arrayLengths callable)) outArgs - wrapper = group $ do- let argName' = escapeReserved . argName- name <- lowerName n- exportMethod name name- line $ deprecatedPragma name $ callableDeprecated callable- line $ name <> " ::"- hSignature hInArgs =<< hOutType callable hOutArgs ignoreReturn- line $ name <> " " <> T.intercalate " " (map argName' hInArgs) <> " = liftIO $ do"+-- | Convert the result of the foreign call to Haskell.+convertResult :: Callable -> Text -> Bool -> Map.Map Text Text ->+ ExcCodeGen Text+convertResult callable symbol ignoreReturn nameMap =+ if ignoreReturn || returnType callable == TBasicType TVoid+ then return (error "convertResult: unreachable code reached, bug!")+ else do+ if returnMayBeNull callable+ then do+ line $ "maybeResult <- convertIfNonNull result $ \\result' -> do" indent $ do- readInArrayLengths n callable hInArgs- inArgNames <- forM (args callable) $ \arg ->- prepareArgForCall omitted arg- -- Map from argument names to names passed to the C function- let nameMap = Map.fromList $ flip zip inArgNames- $ map argName' $ args callable- prepareClosures callable nameMap- if throwsGError- then do- line "onException (do"- indent $ do- invokeCFunction inArgNames- readOutArrayLengths callable nameMap- result <- convertResult nameMap- pps <- convertOut nameMap- freeCallCallbacks callable nameMap- forM_ (args callable) touchInArg- mapM_ line =<< freeInArgs callable nameMap- returnResult result pps- line " ) (do"- indent $ do- freeCallCallbacks callable nameMap- actions <- freeInArgsOnError callable nameMap- case actions of- [] -> line $ "return ()"- _ -> mapM_ line actions- line " )"- else do- invokeCFunction inArgNames- readOutArrayLengths callable nameMap- result <- convertResult nameMap- pps <- convertOut nameMap- freeCallCallbacks callable nameMap- forM_ (args callable) touchInArg- mapM_ line =<< freeInArgs callable nameMap- returnResult result pps-- invokeCFunction argNames = do- let returnBind = case returnType callable of- TBasicType TVoid -> ""- _ -> if ignoreReturn- then "_ <- "- else "result <- "- maybeCatchGErrors = if throwsGError- then "propagateGError $ "- else ""- line $ returnBind <> maybeCatchGErrors- <> symbol <> (T.concat . map (" " <>)) argNames-- convertResult :: Map.Map Text Text -> ExcCodeGen Text- convertResult nameMap =- if ignoreReturn || returnType callable == TBasicType TVoid- then return (error "convertResult: unreachable code reached, bug!")- else do- if returnMayBeNull callable- then do- line $ "maybeResult <- convertIfNonNull result $ \\result' -> do"- indent $ do- converted <- unwrappedConvertResult "result'"- line $ "return " <> converted- return "maybeResult"- else do- nullable <- isNullable (returnType callable)- when nullable $- line $ "checkUnexpectedReturnNULL \"" <> symbol- <> "\" result"- unwrappedConvertResult "result"+ converted <- unwrappedConvertResult "result'"+ line $ "return " <> converted+ return "maybeResult"+ else do+ nullable <- isNullable (returnType callable)+ when nullable $+ line $ "checkUnexpectedReturnNULL \"" <> symbol+ <> "\" result"+ unwrappedConvertResult "result" - where- unwrappedConvertResult rname = case returnType callable of+ where+ unwrappedConvertResult rname =+ case returnType callable of -- Arrays without length information are just passed -- along. TCArray False (-1) (-1) _ -> return rname@@ -639,69 +594,218 @@ -- length, so we deal with them directly. t@(TCArray False _ _ _) -> convertOutCArray callable t rname nameMap- (returnTransfer callable)+ (returnTransfer callable) prime t -> do result <- convert rname $ fToH (returnType callable) (returnTransfer callable) freeContainerType (returnTransfer callable) t rname undefined return result - convertOut :: Map.Map Text Text -> ExcCodeGen [Text]- convertOut nameMap = do- -- Convert out parameters and result- forM hOutArgs $ \arg -> do- let name = escapeReserved $ argName arg- inName <- case Map.lookup name nameMap of- Just name' -> return name'- Nothing -> badIntroError $ "Parameter " <> name <> " not found!"- case argType arg of- -- Passed along as a raw pointer- TCArray False (-1) (-1) _ -> genConversion inName $ apply $ M "peek"- t@(TCArray False _ _ _) -> do- aname' <- genConversion inName $ apply $ M "peek"- let wrapArray a = convertOutCArray callable t a- nameMap (transfer arg)- wrapMaybe arg >>= bool- (wrapArray aname')- (do line $ "maybe" <> ucFirst aname'- <> " <- convertIfNonNull " <> aname'- <> " $ \\" <> prime aname' <> " -> do"- indent $ do- wrapped <- wrapArray (prime aname')- line $ "return " <> wrapped- return $ "maybe" <> ucFirst aname')- t -> do- weAlloc <- isJust <$> requiresAlloc t- peeked <- if weAlloc- 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- then TransferEverything- else transfer arg- result <- do- let wrap ptr = convert ptr $ fToH (argType arg) transfer'- wrapMaybe arg >>= bool- (wrap peeked)- (do line $ "maybe" <> ucFirst peeked- <> " <- convertIfNonNull " <> peeked- <> " $ \\" <> prime peeked <> " -> do"- indent $ do- wrapped <- wrap (prime peeked)- line $ "return " <> wrapped- return $ "maybe" <> ucFirst peeked)- -- Free the memory associated with the out argument- freeContainerType transfer' t peeked undefined- return result+-- | Marshal a foreign out argument to Haskell, returning the name of+-- the variable containing the converted Haskell value.+convertOutArg :: Callable -> Map.Map Text Text -> Arg -> ExcCodeGen Text+convertOutArg callable nameMap arg = do+ let name = escapedArgName arg+ inName <- case Map.lookup name nameMap of+ Just name' -> return name'+ Nothing -> badIntroError $ "Parameter " <> name <> " not found!"+ case argType arg of+ -- Passed along as a raw pointer+ TCArray False (-1) (-1) _ ->+ if argCallerAllocates arg+ then return inName+ else genConversion inName $ apply $ M "peek"+ t@(TCArray False _ _ _) -> do+ aname' <- if argCallerAllocates arg+ then return inName+ else genConversion inName $ apply $ M "peek"+ let arrayLength = if argCallerAllocates arg+ then id+ else prime+ wrapArray a = convertOutCArray callable t a+ nameMap (transfer arg) arrayLength+ wrapMaybe arg >>= bool+ (wrapArray aname')+ (do line $ "maybe" <> ucFirst aname'+ <> " <- convertIfNonNull " <> aname'+ <> " $ \\" <> prime aname' <> " -> do"+ indent $ do+ wrapped <- wrapArray (prime aname')+ line $ "return " <> wrapped+ return $ "maybe" <> ucFirst aname')+ t -> do+ weAlloc <- isJust <$> requiresAlloc t+ peeked <- if weAlloc || 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+ then TransferEverything+ else transfer arg+ result <- do+ let wrap ptr = convert ptr $ fToH (argType arg) transfer'+ wrapMaybe arg >>= bool+ (wrap peeked)+ (do line $ "maybe" <> ucFirst peeked+ <> " <- convertIfNonNull " <> peeked+ <> " $ \\" <> prime peeked <> " -> do"+ indent $ do+ wrapped <- wrap (prime peeked)+ line $ "return " <> wrapped+ return $ "maybe" <> ucFirst peeked)+ -- Free the memory associated with the out argument+ freeContainerType transfer' t peeked undefined+ return result - returnResult :: Text -> [Text] -> CodeGen ()- returnResult result pps =- if ignoreReturn || returnType callable == TBasicType TVoid- then case pps of- [] -> line "return ()"- (pp:[]) -> line $ "return " <> pp- _ -> line $ "return (" <> T.intercalate ", " pps <> ")"- else case pps of- [] -> line $ "return " <> result- _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")"+-- | Convert the list of out arguments to Haskell, returning the+-- names of the corresponding variables containing the marshaled values.+convertOutArgs :: Callable -> Map.Map Text Text -> [Arg] -> ExcCodeGen [Text]+convertOutArgs callable nameMap hOutArgs =+ forM hOutArgs (convertOutArg callable nameMap)++-- | Invoke the given C function, taking care of errors.+invokeCFunction :: Callable -> Text -> Bool -> Bool -> [Text] -> CodeGen ()+invokeCFunction callable symbol throwsGError ignoreReturn argNames = do+ let returnBind = case returnType callable of+ TBasicType TVoid -> ""+ _ -> if ignoreReturn+ then "_ <- "+ else "result <- "+ maybeCatchGErrors = if throwsGError+ then "propagateGError $ "+ else ""+ line $ returnBind <> maybeCatchGErrors+ <> symbol <> (T.concat . map (" " <>)) argNames++-- | Return the result of the call, possibly including out arguments.+returnResult :: Callable -> Bool -> Text -> [Text] -> CodeGen ()+returnResult callable ignoreReturn result pps =+ if ignoreReturn || returnType callable == TBasicType TVoid+ then case pps of+ [] -> line "return ()"+ (pp:[]) -> line $ "return " <> pp+ _ -> line $ "return (" <> T.intercalate ", " pps <> ")"+ else case pps of+ [] -> line $ "return " <> result+ _ -> 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+ hOutArgs = callableHOutArgs callable+ ignoreReturn = skipRetVal callable throwsGError++ line $ name <> " ::"+ formatHSignature callable ignoreReturn+ line $ name <> " " <> T.intercalate " " (map escapedArgName hInArgs) <> " = liftIO $ do"+ indent (genWrapperBody n symbol callable throwsGError+ ignoreReturn hInArgs hOutArgs omitted)++-- | Generate the body of the Haskell wrapper for the given foreign symbol.+genWrapperBody :: Name -> Text -> Callable -> Bool ->+ Bool -> [Arg] -> [Arg] -> [Arg] ->+ ExcCodeGen ()+genWrapperBody n symbol callable throwsGError+ ignoreReturn hInArgs hOutArgs omitted = do+ readInArrayLengths n callable hInArgs+ inArgNames <- forM (args callable) $ \arg ->+ prepareArgForCall omitted arg+ -- Map from argument names to names passed to the C function+ let nameMap = Map.fromList $ flip zip inArgNames+ $ map escapedArgName $ args callable+ prepareClosures callable nameMap+ if throwsGError+ then do+ line "onException (do"+ indent $ do+ invokeCFunction callable symbol throwsGError+ ignoreReturn inArgNames+ readOutArrayLengths callable nameMap+ result <- convertResult callable symbol ignoreReturn nameMap+ pps <- convertOutArgs callable nameMap hOutArgs+ freeCallCallbacks callable nameMap+ forM_ (args callable) touchInArg+ mapM_ line =<< freeInArgs callable nameMap+ returnResult callable ignoreReturn result pps+ line " ) (do"+ indent $ do+ freeCallCallbacks callable nameMap+ actions <- freeInArgsOnError callable nameMap+ case actions of+ [] -> line $ "return ()"+ _ -> mapM_ line actions+ line " )"+ else do+ invokeCFunction callable symbol throwsGError+ ignoreReturn inArgNames+ readOutArrayLengths callable nameMap+ result <- convertResult callable symbol ignoreReturn nameMap+ pps <- convertOutArgs callable nameMap hOutArgs+ freeCallCallbacks callable nameMap+ forM_ (args callable) touchInArg+ mapM_ line =<< freeInArgs callable nameMap+ returnResult callable ignoreReturn result pps++-- | 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.+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++ lengthsMap :: Map.Map Arg Arg+ lengthsMap = Map.fromList (map swap (arrayLengthsMap c))++ -- Length arguments of caller-allocates arguments should be+ -- treated as "in".+ fixupLength :: Arg -> Arg+ fixupLength a = case Map.lookup a lengthsMap of+ Nothing -> a+ Just array ->+ if argCallerAllocates array+ 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}++genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()+genCallable n symbol callable throwsGError = do+ 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 /= 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++ mkForeignImport symbol callable' throwsGError++ blank++ line $ deprecatedPragma (lowerName n) (callableDeprecated callable)+ exportMethod (lowerName n) (lowerName n)+ genHaskellWrapper n symbol callable' throwsGError
src/GI/Code.hs view
@@ -13,6 +13,9 @@ , writeModuleCode , codeToText , transitiveModuleDeps+ , minBaseVersion+ , BaseVersion(..)+ , showBaseVersion , loadDependency , getDeps@@ -32,10 +35,13 @@ , hsBoot , submodule , setLanguagePragmas+ , setGHCOptions , setModuleFlags+ , setModuleMinBase , addModuleDocumentation , exportToplevel+ , exportModule , exportDecl , exportMethod , exportProperty@@ -137,8 +143,11 @@ , moduleDeps :: Deps -- ^ Set of dependencies for this module. , moduleExports :: Seq Export -- ^ Exports for the module. , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.+ , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module. , moduleFlags :: Set.Set ModuleFlag -- ^ Flags for the module. , moduleDoc :: Maybe Text -- ^ Documentation for the module.+ , moduleMinBase :: BaseVersion -- ^ Minimal version of base the+ -- module will work on. } -- | Flags for module code generation.@@ -149,6 +158,16 @@ | Reexport -- ^ Reexport the module (as is) from .Types deriving (Show, Eq, Ord) +-- | Minimal version of base supported by a given module.+data BaseVersion = Base47 -- ^ 4.7.0+ | Base48 -- ^ 4.8.0+ deriving (Show, Eq, Ord)++-- | A `Text` representation of the given base version bound.+showBaseVersion :: BaseVersion -> Text+showBaseVersion Base47 = "4.7"+showBaseVersion Base48 = "4.8"+ -- | Generate the empty module. emptyModule :: ModuleName -> ModuleInfo emptyModule m = ModuleInfo { moduleName = m@@ -158,8 +177,10 @@ , moduleDeps = Set.empty , moduleExports = S.empty , modulePragmas = Set.empty+ , moduleGHCOpts = Set.empty , moduleFlags = Set.empty , moduleDoc = Nothing+ , moduleMinBase = Base47 } -- | Information for the code generator.@@ -200,7 +221,7 @@ cleanInfo :: ModuleInfo -> ModuleInfo cleanInfo info = info { moduleCode = NoCode, submodules = M.empty, bootCode = NoCode, moduleExports = S.empty,- moduleDoc = Nothing }+ moduleDoc = Nothing, moduleMinBase = Base47 } -- | Run the given code generator using the state and config of an -- ambient CodeGen, but without adding the generated code to@@ -236,13 +257,16 @@ newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState) newExports = moduleExports oldState <> moduleExports newState newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState)+ newGHCOpts = Set.union (moduleGHCOpts oldState) (moduleGHCOpts newState) newFlags = Set.union (moduleFlags oldState) (moduleFlags newState) newBoot = bootCode oldState <> bootCode newState newDoc = moduleDoc oldState <> moduleDoc newState+ newMinBase = max (moduleMinBase oldState) (moduleMinBase newState) in oldState {moduleDeps = newDeps, submodules = newSubmodules, moduleExports = newExports, modulePragmas = newPragmas,- moduleFlags = newFlags, bootCode = newBoot,- moduleDoc = newDoc }+ moduleGHCOpts = newGHCOpts, moduleFlags = newFlags,+ bootCode = newBoot, moduleDoc = newDoc,+ moduleMinBase = newMinBase } -- | Merge the infos, including code too. mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo@@ -340,6 +364,13 @@ Set.unions (moduleDeps minfo : map transitiveModuleDeps (M.elems $ submodules minfo)) +-- | Return the minimal base version supported by the module and all+-- its submodules.+minBaseVersion :: ModuleInfo -> BaseVersion+minBaseVersion minfo =+ maximum (moduleMinBase minfo+ : map minBaseVersion (M.elems $ submodules minfo))+ -- | Give a friendly textual description of the error for presenting -- to the user. describeCGError :: CGError -> Text@@ -413,6 +444,10 @@ export e = modify' $ \s -> s{moduleExports = moduleExports s |> e} +-- | Reexport a whole module.+exportModule :: SymbolName -> CodeGen ()+exportModule m = export (Export ExportModule m)+ -- | Export a toplevel (i.e. belonging to no section) symbol. exportToplevel :: SymbolName -> CodeGen () exportToplevel t = export (Export ExportToplevel t)@@ -438,11 +473,21 @@ setLanguagePragmas ps = modify' $ \s -> s{modulePragmas = Set.fromList ps} +-- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma).+setGHCOptions :: [Text] -> CodeGen ()+setGHCOptions opts =+ modify' $ \s -> s{moduleGHCOpts = Set.fromList opts}+ -- | Set the given flags for the module. setModuleFlags :: [ModuleFlag] -> CodeGen () setModuleFlags flags = modify' $ \s -> s{moduleFlags = Set.fromList flags} +-- | Set the minimum base version supported by the current module.+setModuleMinBase :: BaseVersion -> CodeGen ()+setModuleMinBase v =+ modify' $ \s -> s{moduleMinBase = max v (moduleMinBase s)}+ -- | Add the given text to the module-level documentation for the -- module being generated. addModuleDocumentation :: Maybe Documentation -> CodeGen ()@@ -569,6 +614,11 @@ languagePragmas [] = "" languagePragmas ps = "{-# LANGUAGE " <> T.intercalate ", " ps <> " #-}\n" +-- | Write down the list of GHC options.+ghcOptions :: [Text] -> Text+ghcOptions [] = ""+ghcOptions opts = "{-# OPTIONS_GHC " <> T.intercalate ", " opts <> " #-}\n"+ -- | Standard fields for every module. standardFields :: Text standardFields = T.unlines [ "Copyright : " <> authors@@ -596,7 +646,7 @@ modulePrelude name exports reexportedModules = "module " <> name <> "\n ( " <> formatExportList (map (Export ExportModule) reexportedModules)- <> "\n , "+ <> "\n" <> formatExportList exports <> " ) where\n\n" <> T.unlines (map ("import " <>) reexportedModules)@@ -630,6 +680,7 @@ dirname = takeDirectory fname code = codeToText (moduleCode minfo) pragmas = languagePragmas (Set.toList $ modulePragmas minfo)+ optionsGHC = ghcOptions (Set.toList $ moduleGHCOpts minfo) prelude = modulePrelude (dotModuleName $ moduleName minfo) (F.toList (moduleExports minfo)) submoduleExports@@ -653,7 +704,7 @@ when verbose $ putStrLn ((T.unpack . dotModuleName . moduleName) minfo ++ " -> " ++ fname) createDirectoryIfMissing True dirname- TIO.writeFile fname (T.unlines [pragmas, haddock, prelude,+ TIO.writeFile fname (T.unlines [pragmas, optionsGHC, haddock, prelude, imports, types, callbacks, deps, code]) when (bootCode minfo /= NoCode) $ do let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot"
src/GI/CodeGen.hs view
@@ -11,7 +11,7 @@ import Control.Monad (forM, forM_, when, unless, filterM) import Data.List (nub) import Data.Tuple (swap)-import Data.Maybe (fromJust, fromMaybe)+import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe, isNothing) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text)@@ -24,24 +24,29 @@ import GI.Constant (genConstant) import GI.Code import GI.GObject-import GI.Inheritance (instanceTree)+import GI.Inheritance (instanceTree, fullObjectMethodList,+ fullInterfaceMethodList) import GI.Properties (genInterfaceProperties, genObjectProperties) import GI.OverloadedSignals (genInterfaceSignals, genObjectSignals)+import GI.OverloadedMethods (genMethodList, genMethodInfo,+ genUnsupportedMethodInfo) import GI.Signal (genSignal, genCallback) import GI.Struct (genStructOrUnionFields, extractCallbacksInStruct,- fixAPIStructs, ignoreStruct)+ fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion) import GI.SymbolNaming (upperName, classConstraint, noName) import GI.Type import GI.Util (tshow) genFunction :: Name -> Function -> CodeGen ()-genFunction n (Function symbol throws callable) =- submodule "Functions" $ group $ do- line $ "-- function " <> symbol- handleCGExc (\e -> line ("-- XXX Could not generate function "+genFunction n (Function symbol throws fnMovedTo callable) =+ -- Only generate the function if it has not been moved.+ when (Nothing == fnMovedTo) $+ submodule "Functions" $ group $ do+ line $ "-- function " <> symbol+ handleCGExc (\e -> line ("-- XXX Could not generate function " <> symbol <> "\n-- Error was : " <> describeCGError e))- (genCallable n symbol callable throws)+ (genCallable n symbol callable throws) genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do@@ -180,21 +185,30 @@ genBoxedObject n (fromJust $ structTypeInit s) exportDecl (name' <> ("(..)")) + -- Generate a builder for a structure filled with zeroes.+ genZeroStruct n s+ noName name' -- Generate code for fields. genStructOrUnionFields n (structFields s) -- Methods- forM_ (structMethods s) $ \(mn, f) ->- do isFunction <- symbolFromFunction (methodSymbol f)- unless isFunction $- handleCGExc+ methods <- forM (structMethods s) $ \f -> do+ let mn = methodName f+ isFunction <- symbolFromFunction (methodSymbol f)+ if not isFunction+ then handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e))- (genMethod n mn f)+ <> "-- Error was : " <> describeCGError e) >>+ return Nothing)+ (genMethod n f >> return (Just (n, f)))+ else return Nothing + -- Overloaded methods+ genMethodList n (catMaybes methods)+ genUnion :: Name -> Union -> CodeGen () genUnion n u = do name' <- upperName n@@ -208,21 +222,30 @@ genBoxedObject n (fromJust $ unionTypeInit u) exportDecl (name' <> "(..)") + -- Generate a builder for a structure filled with zeroes.+ genZeroUnion n u+ noName name' -- Generate code for fields. genStructOrUnionFields n (unionFields u) -- Methods- forM_ (unionMethods u) $ \(mn, f) ->- do isFunction <- symbolFromFunction (methodSymbol f)- unless isFunction $- handleCGExc+ methods <- forM (unionMethods u) $ \f -> do+ let mn = methodName f+ isFunction <- symbolFromFunction (methodSymbol f)+ if not isFunction+ then handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e))- (genMethod n mn f)+ <> "-- Error was : " <> describeCGError e)+ >> return Nothing)+ (genMethod n f >> return (Just (n, f)))+ else return Nothing + -- Overloaded methods+ 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.@@ -255,13 +278,14 @@ else arg objArg = Arg {- argName = "_obj",+ argCName = "_obj", argType = TInterface (namespace cn) (name cn), direction = DirectionIn, mayBeNull = False, argScope = ScopeTypeInvalid, argClosure = -1, argDestroy = -1,+ argCallerAllocates = False, transfer = TransferNothing } -- For constructors we want to return the actual type of the object,@@ -275,13 +299,14 @@ else returnType c -genMethod :: Name -> Name -> Method -> ExcCodeGen ()-genMethod cn mn (Method {- methodSymbol = sym,- methodCallable = c,- methodType = t,- methodThrows = throws- }) = do+genMethod :: Name -> Method -> ExcCodeGen ()+genMethod cn m@(Method {+ methodName = mn,+ methodSymbol = sym,+ methodCallable = c,+ methodType = t,+ methodThrows = throws+ }) = do name' <- upperName cn returnsGObject <- isGObject (returnType c) line $ "-- method " <> name' <> "::" <> name mn@@ -296,6 +321,8 @@ else c' genCallable mn' sym c'' throws + genMethodInfo cn (m {methodCallable = c''})+ -- Type casting with type checking genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen () genGObjectCasts isIU n cn_ parents = do@@ -356,6 +383,8 @@ noName name' + fullObjectMethodList n o >>= genMethodList n+ forM_ (objSignals o) $ \s -> handleCGExc (line . (T.concat ["-- XXX Could not generate signal ", name', "::"@@ -367,12 +396,13 @@ genObjectSignals n o -- Methods- forM_ (objMethods o) $ \(mn, f) ->- handleCGExc- (\e -> line ("-- XXX Could not generate method "- <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e))- (genMethod n mn f)+ forM_ (objMethods o) $ \f -> do+ let mn = methodName f+ handleCGExc (\e -> line ("-- XXX Could not generate method "+ <> name' <> "::" <> name mn <> "\n"+ <> "-- Error was : " <> describeCGError e)+ >> genUnsupportedMethodInfo n f)+ (genMethod n f) genInterface :: Name -> Interface -> CodeGen () genInterface n iface = do@@ -386,6 +416,8 @@ noName name' + fullInterfaceMethodList n iface >>= genMethodList n+ forM_ (ifSignals iface) $ \s -> handleCGExc (line . (T.concat ["-- XXX Could not generate signal ", name', "::" , sigName s@@ -415,32 +447,52 @@ line $ "type " <> parentObjectsType <> " = '[]" -- Methods- forM_ (ifMethods iface) $ \(mn, f) -> do+ forM_ (ifMethods iface) $ \f -> do+ let mn = methodName f isFunction <- symbolFromFunction (methodSymbol f) unless isFunction $ handleCGExc (\e -> line ("-- XXX Could not generate method " <> name' <> "::" <> name mn <> "\n"- <> "-- Error was : " <> describeCGError e))- (genMethod n mn f)+ <> "-- Error was : " <> describeCGError e)+ >> genUnsupportedMethodInfo n f)+ (genMethod n f) -- Some type libraries include spurious interface/struct methods, -- where a method Mod.Foo::func also appears as an ordinary function--- in the list of APIs. If we find a matching function, we don't--- generate the method.+-- in the list of APIs. If we find a matching function (without the+-- "moved-to" annotation), we don't generate the method. -- -- It may be more expedient to keep a map of symbol -> function.------ XXX Maybe the GIR helps here? Sometimes such functions are--- annotated with the "moved-to". symbolFromFunction :: Text -> CodeGen Bool symbolFromFunction sym = do apis <- getAPIs return $ any (hasSymbol sym . snd) $ M.toList apis where- hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2 })) = sym1 == sym2+ hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2,+ fnMovedTo = movedTo })) =+ sym1 == sym2 && movedTo == Nothing hasSymbol _ _ = False +-- | Remove functions and methods annotated with "moved-to".+dropMovedItems :: API -> Maybe API+dropMovedItems (APIFunction f) = if fnMovedTo f == Nothing+ then Just (APIFunction f)+ else Nothing+dropMovedItems (APIInterface i) =+ (Just . APIInterface) i {ifMethods = filterMovedMethods (ifMethods i)}+dropMovedItems (APIObject o) =+ (Just . APIObject) o {objMethods = filterMovedMethods (objMethods o)}+dropMovedItems (APIStruct s) =+ (Just . APIStruct) s {structMethods = filterMovedMethods (structMethods s)}+dropMovedItems (APIUnion u) =+ (Just . APIUnion) u {unionMethods = filterMovedMethods (unionMethods u)}+dropMovedItems a = Just a++-- | Drop the moved methods.+filterMovedMethods :: [Method] -> [Method]+filterMovedMethods = filter (isNothing . methodMovedTo)+ genAPI :: Name -> API -> CodeGen () genAPI n (APIConst c) = genConstant n c genAPI n (APIFunction f) = genFunction n f@@ -464,6 +516,7 @@ , Name "GLib" "Variant" , Name "GObject" "Value" , Name "GObject" "Closure"]) . fst)+ $ mapMaybe (traverse dropMovedItems) -- Some callback types are defined inside structs $ map fixAPIStructs $ M.toList@@ -475,6 +528,11 @@ genModule :: M.Map Name API -> CodeGen () genModule apis = do+ -- Reexport Data.GI.Base for convenience (so it does not need to be+ -- imported separately).+ line "import Data.GI.Base"+ exportModule "Data.GI.Base"+ -- Some API symbols are embedded into structures, extract these and -- inject them into the set of APIs loaded and being generated. let embeddedAPIs = (M.fromList
src/GI/Constant.hs view
@@ -32,9 +32,11 @@ writePattern name (SimpleSynonym value t) = line $ "pattern " <> name <> " = " <> value <> " :: " <> t writePattern name (ExplicitSynonym view expression value t) = do- line $- "pattern " <> name <> " <- (" <> view <> " -> " <> value <> ") :: " <> t <> " where"- indent $ line $+ -- Supported only on ghc >= 7.10+ setModuleMinBase Base48+ line $ "pattern " <> name <> " <- (" <> view <> " -> "+ <> value <> ") :: " <> t <> " where"+ indent $ line $ name <> " = " <> expression <> " " <> value <> " :: " <> t genConstant :: Name -> Constant -> CodeGen ()@@ -64,8 +66,12 @@ case api of Just (APIEnum _) -> writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht)- Just (APIFlags _) ->- writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" value ht)+ Just (APIFlags _) -> do+ -- gflagsToWord and wordToGFlags are polymorphic, so in this+ -- case we need to specialize so the type of the pattern is+ -- not ambiguous.+ let wordValue = "(" <> value <> " :: Word64)"+ writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" wordValue ht) _ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t @@ -91,5 +97,7 @@ showBasicType TFileName fn = return . tshow $ fn showBasicType TUniChar c = return $ "'" <> c <> "'" showBasicType TGType gtype = return $ "GType " <> gtype+showBasicType TIntPtr ptr = return ptr+showBasicType TUIntPtr ptr = return ptr -- We take care of this one separately above showBasicType TVoid _ = notImplementedError $ "Cannot directly show a pointer"
src/GI/Conversions.hs view
@@ -601,6 +601,8 @@ haskellBasicType TDouble = typeOf (0 :: Double) haskellBasicType TUniChar = typeOf ('\0' :: Char) haskellBasicType TFileName = "[Char]" `con` []+haskellBasicType TIntPtr = "CIntPtr" `con` []+haskellBasicType TUIntPtr = "CUIntPtr" `con` [] -- This translates GI types to the types used for generated Haskell code. haskellType :: Type -> CodeGen TypeRep
src/GI/GIR/Arg.hs view
@@ -26,13 +26,16 @@ deriving (Show, Eq, Ord) data Arg = Arg {- argName :: Text,+ argCName :: Text, -- ^ "C" name for the argument. For a+ -- escaped name valid in Haskell code, use+ -- `GI.SymbolNaming.escapedArgName`. argType :: Type, direction :: Direction, mayBeNull :: Bool, argScope :: Scope, argClosure :: Int, argDestroy :: Int,+ argCallerAllocates :: Bool, transfer :: Transfer } deriving (Show, Eq, Ord) @@ -64,13 +67,15 @@ closure <- optionalAttr "closure" (-1) parseIntegral destroy <- optionalAttr "destroy" (-1) parseIntegral nullable <- optionalAttr "nullable" False parseBool+ callerAllocates <- optionalAttr "caller-allocates" False parseBool t <- parseType- return $ Arg { argName = name+ return $ Arg { argCName = name , argType = t , direction = d , mayBeNull = nullable , argScope = scope , argClosure = closure , argDestroy = destroy+ , argCallerAllocates = callerAllocates , transfer = ownership }
src/GI/GIR/Function.hs view
@@ -9,9 +9,10 @@ import GI.GIR.Parser data Function = Function {- fnSymbol :: Text,- fnThrows :: Bool,- fnCallable :: Callable+ fnSymbol :: Text+ , fnThrows :: Bool+ , fnMovedTo :: Maybe Text+ , fnCallable :: Callable } deriving Show parseFunction :: Parser (Name, Function)@@ -24,9 +25,11 @@ callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier" throws <- optionalAttr "throws" False parseBool+ movedTo <- queryAttr "moved-to" return $ (exposedName, Function { fnSymbol = symbol , fnCallable = callable , fnThrows = throws+ , fnMovedTo = movedTo })
src/GI/GIR/Interface.hs view
@@ -15,7 +15,7 @@ ifPrerequisites :: [Name], ifProperties :: [Property], ifSignals :: [Signal],- ifMethods :: [(Name, Method)],+ ifMethods :: [Method], ifDeprecated :: Maybe DeprecationInfo } deriving Show
src/GI/GIR/Method.hs view
@@ -16,13 +16,15 @@ deriving (Eq, Show) data Method = Method {+ methodName :: Name, methodSymbol :: Text, methodThrows :: Bool, methodType :: MethodType,+ methodMovedTo :: Maybe Text, methodCallable :: Callable- } deriving Show+ } deriving (Eq, Show) -parseMethod :: MethodType -> Parser (Name, Method)+parseMethod :: MethodType -> Parser Method parseMethod mType = do name <- parseName shadows <- queryAttr "shadows"@@ -32,10 +34,12 @@ callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier" throws <- optionalAttr "throws" False parseBool- return $ (exposedName,- Method {- methodSymbol = symbol+ movedTo <- queryAttr "moved-to"+ return $ Method {+ methodName = exposedName+ , methodSymbol = symbol , methodThrows = throws , methodType = mType+ , methodMovedTo = movedTo , methodCallable = callable- })+ }
src/GI/GIR/Object.hs view
@@ -18,7 +18,7 @@ objInterfaces :: [Name], objDeprecated :: Maybe DeprecationInfo, objDocumentation :: Maybe Documentation,- objMethods :: [(Name, Method)],+ objMethods :: [Method], objProperties :: [Property], objSignals :: [Signal] } deriving Show
src/GI/GIR/Struct.hs view
@@ -18,7 +18,7 @@ -- https://bugzilla.gnome.org/show_bug.cgi?id=560248 structIsDisguised :: Bool, structFields :: [Field],- structMethods :: [(Name, Method)],+ structMethods :: [Method], structDeprecated :: Maybe DeprecationInfo, structDocumentation :: Maybe Documentation } deriving Show@@ -36,6 +36,7 @@ fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+ functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) return (name, Struct { structIsBoxed = error ("[boxed] unfixed struct " ++ show name)@@ -44,7 +45,7 @@ , gtypeStructFor = structFor , structIsDisguised = disguised , structFields = fields- , structMethods = constructors ++ methods+ , structMethods = constructors ++ methods ++ functions , structDeprecated = deprecated , structDocumentation = doc })
src/GI/GIR/Type.hs view
@@ -39,6 +39,8 @@ nameToBasicType "GType" = Just TGType nameToBasicType "utf8" = Just TUTF8 nameToBasicType "filename" = Just TFileName+nameToBasicType "gintptr" = Just TIntPtr+nameToBasicType "guintptr" = Just TUIntPtr nameToBasicType "gshort" = case sizeOf (0 :: CShort) of 2 -> Just TInt16 4 -> Just TInt32
src/GI/GIR/Union.hs view
@@ -16,7 +16,7 @@ unionSize :: Int, unionTypeInit :: Maybe Text, unionFields :: [Field],- unionMethods :: [(Name, Method)],+ unionMethods :: [Method], unionDeprecated :: Maybe DeprecationInfo } deriving Show @@ -28,13 +28,14 @@ fields <- parseFields constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+ functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction) return (name, Union { unionIsBoxed = isJust typeInit , unionTypeInit = typeInit , unionSize = error ("unfixed union size " ++ show name) , unionFields = fields- , unionMethods = constructors ++ methods+ , unionMethods = constructors ++ methods ++ functions , unionDeprecated = deprecated })
src/GI/Inheritance.hs view
@@ -4,13 +4,15 @@ , fullInterfacePropertyList , fullObjectSignalList , fullInterfaceSignalList+ , fullObjectMethodList+ , fullInterfaceMethodList , instanceTree ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif-import Control.Monad (foldM)+import Control.Monad (foldM, when) import qualified Data.Map as M import Data.Text (Text) @@ -55,6 +57,11 @@ objInheritables = objSignals iName = sigName +instance Inheritable Method where+ ifInheritables = ifMethods+ objInheritables = objMethods+ iName = name . methodName+ -- Returns a list of all inheritables defined for this object -- (including those defined by its ancestors and the interfaces it -- implements), together with the name of the interface defining the@@ -96,8 +103,8 @@ -- they are not isomorphic we refuse to set either, and print a -- warning in the generated code. removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) =>- [(Name, i)] -> CodeGen [(Name, i)]-removeDuplicates inheritables =+ Bool -> [(Name, i)] -> CodeGen [(Name, i)]+removeDuplicates verbose inheritables = (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables where filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) ->@@ -108,9 +115,10 @@ | tainted -> return m | (p == prop) -> return m -- Duplicated, but isomorphic property | otherwise ->- do line "--- XXX Duplicated object with different types:"- line $ " --- " <> tshow n <> " -> " <> tshow p- line $ " --- " <> tshow name <> " -> " <> tshow prop+ do when verbose $ do+ line "--- XXX Duplicated object with different types:"+ line $ " --- " <> tshow n <> " -> " <> tshow p+ line $ " --- " <> tshow name <> " -> " <> tshow prop -- Tainted return $ M.insert (iName prop) (True, n, p) m Nothing -> return $ M.insert (iName prop) (False, name, prop) m@@ -122,22 +130,34 @@ -- defined by its ancestors. fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)] fullObjectPropertyList n o = fullObjectInheritableList n o >>=- removeDuplicates+ removeDuplicates True -- | List all properties defined for an interface, including those -- defined by its prerequisites. fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)] fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>=- removeDuplicates+ removeDuplicates True -- | List all signals defined for an object, including those -- defined by its ancestors. fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)] fullObjectSignalList n o = fullObjectInheritableList n o >>=- removeDuplicates+ removeDuplicates True -- | List all signals defined for an interface, including those -- defined by its prerequisites. fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)] fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>=- removeDuplicates+ removeDuplicates True++-- | List all methods defined for an object, including those defined+-- by its ancestors.+fullObjectMethodList :: Name -> Object -> CodeGen [(Name, Method)]+fullObjectMethodList n o = fullObjectInheritableList n o >>=+ removeDuplicates False++-- | List all methods defined for an interface, including those+-- defined by its prerequisites.+fullInterfaceMethodList :: Name -> Interface -> CodeGen [(Name, Method)]+fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>=+ removeDuplicates False
+ src/GI/OverloadedLabels.hs view
@@ -0,0 +1,84 @@+module GI.OverloadedLabels+ ( genOverloadedLabels+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Data.Maybe (isNothing)+import Control.Monad (forM_)+import qualified Data.Set as S+import Data.Text (Text)++import GI.API+import GI.Code+import GI.SymbolNaming+import GI.Util (lcFirst)++-- | A list of all overloadable identifiers in the set of APIs (current+-- properties and methods).+findOverloaded :: [(Name, API)] -> CodeGen [Text]+findOverloaded apis = S.toList <$> go apis S.empty+ where+ go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)+ go [] set = return set+ go ((_, api):apis) set =+ case api of+ APIInterface iface -> go apis (scanInterface iface set)+ APIObject object -> go apis (scanObject object set)+ APIStruct s -> go apis (scanStruct s set)+ APIUnion u -> go apis (scanUnion u set)+ _ -> go apis set++ scanObject :: Object -> S.Set Text -> S.Set Text+ scanObject o set =+ let props = (map propToLabel . objProperties) o+ methods = (map methodToLabel . filterMethods . objMethods) o+ in S.unions [set, S.fromList props, S.fromList methods]++ scanInterface :: Interface -> S.Set Text -> S.Set Text+ scanInterface i set =+ let props = (map propToLabel . ifProperties) i+ methods = (map methodToLabel . filterMethods . ifMethods) i+ in S.unions [set, S.fromList props, S.fromList methods]++ scanStruct :: Struct -> S.Set Text -> S.Set Text+ scanStruct s set =+ let methods = (map methodToLabel . filterMethods . structMethods) s+ in S.unions [set, S.fromList methods]++ scanUnion :: Union -> S.Set Text -> S.Set Text+ scanUnion u set =+ let methods = (map methodToLabel . filterMethods . unionMethods) u+ in S.unions [set, S.fromList methods]++ propToLabel :: Property -> Text+ propToLabel = lcFirst . hyphensToCamelCase . propName++ methodToLabel :: Method -> Text+ methodToLabel = lowerName . methodName++ filterMethods :: [Method] -> [Method]+ filterMethods = filter (\m -> (isNothing . methodMovedTo) m &&+ methodType m == OrdinaryMethod)++genOverloadedLabel :: Text -> CodeGen ()+genOverloadedLabel l = group $ do+ line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a"+ line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \""+ <> l <> "\")"+ exportToplevel ("_" <> l)++genOverloadedLabels :: [(Name, API)] -> CodeGen ()+genOverloadedLabels allAPIs = do+ setLanguagePragmas ["DataKinds", "FlexibleContexts"]+ setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]++ line $ "import Data.Proxy (Proxy(..))"+ line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))"+ blank++ labels <- findOverloaded allAPIs+ forM_ labels $ \l -> do+ genOverloadedLabel l+ blank
+ src/GI/OverloadedMethods.hs view
@@ -0,0 +1,106 @@+module GI.OverloadedMethods+ ( genMethodList+ , genMethodInfo+ , genUnsupportedMethodInfo+ ) where++import Control.Monad (forM, forM_, when)+import Data.Text (Text)+import qualified Data.Text as T++import GI.API+import GI.Callable (callableSignature, fixupCallerAllocates)+import GI.Code+import GI.SymbolNaming (lowerName, upperName)+import GI.Util (ucFirst)++-- | Qualified name for the info for a given method.+methodInfoName :: Name -> Method -> CodeGen Text+methodInfoName n method = do+ n' <- upperName n+ let mn' = (ucFirst . lowerName . methodName) method+ return $ n' <> mn' <> "MethodInfo"++-- | Appropriate instances so overloaded labels are properly resolved.+genMethodResolver :: Text -> CodeGen ()+genMethodResolver n = do+ group $ do+ line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "+ <> "MethodInfo info " <> n <> " p) => IsLabelProxy t ("+ <> n <> " -> p) where"+ indent $ line $ "fromLabelProxy _ = overloadedMethod (MethodProxy :: MethodProxy info)"+ group $ do+ line $ "#if MIN_VERSION_base(4,9,0)"+ line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "+ <> "MethodInfo info " <> n <> " p) => IsLabel t ("+ <> n <> " -> p) where"+ indent $ line $ "fromLabel _ = overloadedMethod (MethodProxy :: MethodProxy info)"+ line $ "#endif"++-- | Generate the `MethodList` instance given the list of methods for+-- the given named type.+genMethodList :: Name -> [(Name, Method)] -> CodeGen ()+genMethodList n methods = do+ name <- upperName n+ let filteredMethods = filter isOrdinaryMethod methods+ gets = filter isGet filteredMethods+ sets = filter isSet filteredMethods+ others = filter (\m -> not (isSet m || isGet m)) filteredMethods+ orderedMethods = others ++ gets ++ sets+ infos <- forM orderedMethods $ \(owner, method) ->+ do mi <- methodInfoName owner method+ return ((lowerName . methodName) method, mi)+ group $ do+ let resolver = "Resolve" <> name <> "Method"+ line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where"+ indent $ forM_ infos $ \(label, info) -> do+ line $ resolver <> " \"" <> label <> "\" o = " <> info+ indent $ line $ resolver <> " l o = MethodResolutionFailed l o"++ genMethodResolver name++ where isOrdinaryMethod :: (Name, Method) -> Bool+ isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod++ isGet :: (Name, Method) -> Bool+ isGet (_, m) = "get_" `T.isPrefixOf` (name . methodName) m++ isSet :: (Name, Method) -> Bool+ isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m++-- | Generate the `MethodInfo` type and instance for the given method.+genMethodInfo :: Name -> Method -> ExcCodeGen ()+genMethodInfo n m =+ when (methodType m == OrdinaryMethod) $+ group $ do+ infoName <- methodInfoName n m+ let callable = fixupCallerAllocates (methodCallable m)+ (constraints, types) <- callableSignature callable (methodThrows m)+ bline $ "data " <> infoName+ -- This should not happen, since ordinary methods always+ -- have the instance as first argument.+ when (null types) $+ error $ "Internal error: too few parameters! " ++ show m+ let (obj:otherTypes) = map fst types+ sigConstraint = "signature ~ (" <> T.intercalate " -> " otherTypes+ <> ")"+ line $ "instance (" <> T.intercalate ", " (sigConstraint : constraints)+ <> ") => MethodInfo " <> infoName <> " " <> obj <> " signature where"+ let mn = methodName m+ mangled = lowerName (mn {name = name n <> "_" <> name mn})+ indent $ line $ "overloadedMethod _ = " <> mangled+ exportMethod mangled infoName++-- | Generate a method info that is not actually callable, but rather+-- gives a type error when trying to use it.+genUnsupportedMethodInfo :: Name -> Method -> CodeGen ()+genUnsupportedMethodInfo n m = do+ infoName <- methodInfoName n m+ line $ "-- XXX: Dummy instance, since code generation failed.\n"+ <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi."+ bline $ "data " <> infoName+ line $ "instance (p ~ (), o ~ MethodResolutionFailed \""+ <> lowerName (methodName m) <> "\" " <> name n+ <> ") => MethodInfo " <> infoName <> " o p where"+ indent $ line $ "overloadedMethod _ = undefined"+ exportMethod "Unsupported methods" infoName
src/GI/OverloadedSignals.hs view
@@ -18,8 +18,8 @@ import GI.Inheritance (fullObjectSignalList, fullInterfaceSignalList) import GI.GObject (apiIsGObject) import GI.Signal (signalHaskellName)-import GI.SymbolNaming (upperName)-import GI.Util (padTo, ucFirst)+import GI.SymbolNaming (upperName, hyphensToCamelCase)+import GI.Util (lcFirst, ucFirst) -- A list of distinct signal names for all GObjects appearing in the -- given list of APIs.@@ -42,23 +42,28 @@ -- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ... genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen () genOverloadedSignalConnectors allAPIs = do- setLanguagePragmas ["DataKinds", "GADTs", "KindSignatures", "FlexibleInstances"]+ setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP",+ -- For ghc 7.8 support+ "RankNTypes", "ScopedTypeVariables", "TypeFamilies"] setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport] - line "import GHC.TypeLits"- line "import GHC.Exts (Constraint)"- blank- line "class NoConstraint a"- line "instance NoConstraint a"+ line "import Data.GI.Base.Signals (SignalProxy(..))"+ line "import Data.GI.Base.Overloading (ResolveSignal)" blank- line "data SignalProxy (a :: Symbol) (b :: Symbol) (c :: * -> Constraint) where"- indent $ do- signalNames <- findSignalNames allAPIs- let maxLength = maximum $ map (T.length . signalHaskellName) signalNames- forM_ signalNames $ \sn ->- line $ padTo (maxLength + 1) (ucFirst (signalHaskellName sn)) <>- ":: SignalProxy \"" <> sn <> "\" \"\" NoConstraint"- exportToplevel "SignalProxy(..)"+ signalNames <- findSignalNames allAPIs+ forM_ signalNames $ \sn -> group $ do+ let camelName = hyphensToCamelCase sn+ line $ "#if MIN_VERSION_base(4,8,0)"+ line $ "pattern " <> camelName <>+ " :: SignalProxy object (ResolveSignal \""+ <> lcFirst camelName <> "\" object)"+ line $ "pattern " <> camelName <> " = SignalProxy"+ line $ "#else"+ line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. "+ <> "info ~ ResolveSignal \"" <> lcFirst camelName+ <> "\" object => SignalProxy object info"+ line $ "#endif"+ exportDecl $ "pattern " <> camelName -- | Qualified name for the "(sigName, info)" tag for a given signal. signalInfoName :: Name -> Signal -> CodeGen Text@@ -92,17 +97,13 @@ infos <- fullObjectSignalList n o >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal- return $ "'(\"" <> sigName signal+ return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal <> "\", " <> si <> ")")- -- The "notify::[property]" signal is a generic signal used for- -- connecting to property notifications.- let allSignals = infos <>- ["'(\"notify::[property]\", GObjectNotifySignalInfo)"] group $ do let signalListType = name <> "SignalList" line $ "type instance SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ "- <> T.intercalate ", " allSignals <> "] :: [(Symbol, *)])"+ <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen ()@@ -112,17 +113,10 @@ infos <- fullInterfaceSignalList n iface >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal- return $ "'(\"" <> sigName signal+ return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal <> "\", " <> si <> ")")- isGO <- apiIsGObject n (APIInterface iface)- -- The "notify::[property]" signal is a generic signal used for- -- connecting to property notifications of a GObject.- let allSignals =- if isGO- then infos <> ["'(\"notify::[property]\", GObjectNotifySignalInfo)"]- else infos group $ do let signalListType = name <> "SignalList" line $ "type instance SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ "- <> T.intercalate ", " allSignals <> "] :: [(Symbol, *)])"+ <> T.intercalate ", " infos <> "] :: [(Symbol, *)])"
src/GI/Overrides.hs view
@@ -137,15 +137,15 @@ -- | Filter a set of named objects based on a lookup list of names to -- ignore.-filterNamed :: [(Name, a)] -> S.Set Text -> [(Name, a)]-filterNamed set ignores =- filter ((`S.notMember` ignores) . name . fst) set+filterMethods :: [Method] -> S.Set Text -> [Method]+filterMethods set ignores =+ filter ((`S.notMember` ignores) . name . methodName) set -- | Filter one API according to the given config. filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API) filterOneAPI ovs (n, APIStruct s, maybeIgnores) = (n, APIStruct s {structMethods = maybe (structMethods s)- (filterNamed (structMethods s))+ (filterMethods (structMethods s)) maybeIgnores, structFields = if n `S.member` sealedStructs ovs then []@@ -153,17 +153,17 @@ -- The rest only apply if there are ignores. filterOneAPI _ (n, api, Nothing) = (n, api) filterOneAPI _ (n, APIObject o, Just ignores) =- (n, APIObject o {objMethods = filterNamed (objMethods o) ignores,+ (n, APIObject o {objMethods = filterMethods (objMethods o) ignores, objSignals = filter ((`S.notMember` ignores) . sigName) (objSignals o) }) filterOneAPI _ (n, APIInterface i, Just ignores) =- (n, APIInterface i {ifMethods = filterNamed (ifMethods i) ignores,+ (n, APIInterface i {ifMethods = filterMethods (ifMethods i) ignores, ifSignals = filter ((`S.notMember` ignores) . sigName) (ifSignals i) }) filterOneAPI _ (n, APIUnion u, Just ignores) =- (n, APIUnion u {unionMethods = filterNamed (unionMethods u) ignores})+ (n, APIUnion u {unionMethods = filterMethods (unionMethods u) ignores}) filterOneAPI _ (n, api, _) = (n, api) -- | Given a list of APIs modify them according to the given config.
src/GI/Properties.hs view
@@ -121,6 +121,13 @@ line $ "construct" <> pName <> " val = constructObjectProperty" <> tStr <> " \"" <> propName prop <> "\" val" +-- | The property name as a lexically valid Haskell identifier. Note+-- that this is not escaped, since it is assumed that it will be used+-- with a prefix, so if a property is named "class", for example, this+-- will return "class".+hPropName :: Property -> Text+hPropName = lcFirst . hyphensToCamelCase . propName+ genObjectProperties :: Name -> Object -> CodeGen () genObjectProperties n o = do isGO <- apiIsGObject n (APIObject o)@@ -129,7 +136,7 @@ allProps <- fullObjectPropertyList n o >>= mapM (\(owner, prop) -> do pi <- infoType owner prop- return $ "'(\"" <> propName prop+ return $ "'(\"" <> hPropName prop <> "\", " <> pi <> ")") genProperties n (objProperties o) allProps @@ -138,7 +145,7 @@ allProps <- fullInterfacePropertyList n iface >>= mapM (\(owner, prop) -> do pi <- infoType owner prop- return $ "'(\"" <> propName prop+ return $ "'(\"" <> hPropName prop <> "\", " <> pi <> ")") genProperties n (ifProperties iface) allProps @@ -242,8 +249,7 @@ line $ "type AttrBaseTypeConstraint " <> it <> " = " <> classConstraint name line $ "type AttrGetType " <> it <> " = " <> outType- line $ "type AttrLabel " <> it <> " = \""- <> name <> "::" <> propName prop <> "\""+ line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\"" line $ "attrGet _ = " <> getter line $ "attrSet _ = " <> setter line $ "attrConstruct _ = " <> constructor
src/GI/Signal.hs view
@@ -17,13 +17,14 @@ import Text.Show.Pretty (ppShow) import GI.API-import GI.Callable (hOutType, arrayLengths, wrapMaybe)+import GI.Callable (hOutType, arrayLengths, wrapMaybe, fixupCallerAllocates) import GI.Code import GI.Conversions import GI.SymbolNaming import GI.Transfer (freeContainerType) import GI.Type-import GI.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst)+import GI.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst,+ prime) -- The prototype of the callback on the Haskell side (what users of -- the binding will see)@@ -119,7 +120,7 @@ -- the callback deal with it. return aname where- lname = escapeReserved $ argName $ args callable !! length+ lname = escapedArgName $ args callable !! length convertAndFree :: ExcCodeGen Text convertAndFree = do@@ -141,7 +142,7 @@ prepareInArg :: Callable -> Arg -> ExcCodeGen Text prepareInArg cb arg = do- let name = (escapeReserved . argName) arg+ let name = escapedArgName arg case argType arg of t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name _ -> do@@ -150,17 +151,29 @@ prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do- let name = (escapeReserved . argName) arg+ let name = escapedArgName arg name' <- genConversion name $ apply $ M "peek" convert name' $ fToH (argType arg) (transfer arg) saveOutArg :: Arg -> ExcCodeGen () saveOutArg arg = do- let name = (escapeReserved . argName) arg+ let name = escapedArgName arg name' = "out" <> name when (transfer arg /= TransferEverything) $ notImplementedError $ "Unexpected transfer type for \"" <> name <> "\""- name'' <- convert name' $ hToF (argType arg) TransferEverything+ isMaybe <- wrapMaybe arg+ name'' <- if isMaybe+ then do+ let name'' = prime name'+ line $ name'' <> " <- case " <> name' <> " of"+ indent $ do+ line "Nothing -> return nullPtr"+ line $ "Just " <> name'' <> " -> do"+ indent $ do+ converted <- convert name'' $ hToF (argType arg) TransferEverything+ line $ "return " <> converted+ return name''+ else convert name' $ hToF (argType arg) TransferEverything line $ "poke " <> name <> " " <> name'' -- The wrapper itself, marshalling to and from Haskell. The first@@ -174,7 +187,7 @@ genCallbackWrapper subsec cb name' dataptrs hInArgs hOutArgs isSignal = do let cName arg = if arg `elem` dataptrs then "_"- else (escapeReserved . argName) arg+ else escapedArgName arg cArgNames = map cName (args cb) wrapperName = lcFirst name' <> "Wrapper" @@ -209,8 +222,7 @@ let maybeReturn = case returnType cb of TBasicType TVoid -> [] _ -> ["result"]- argName' = escapeReserved . argName- returnVars = maybeReturn <> map (("out"<>) . argName') hOutArgs+ returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs returnBind = case returnVars of [] -> "" [r] -> r <> " <- "@@ -253,15 +265,16 @@ <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb) else do let closure = lcFirst name' <> "Closure"+ 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 >>+ genCCallbackPrototype name' cb' name' False >> genCallbackWrapperFactory name' name' >>- genHaskellCallbackPrototype name' cb name' hInArgs hOutArgs >>- genCallbackWrapper name' cb name' dataptrs hInArgs hOutArgs False)+ genHaskellCallbackPrototype name' cb' name' hInArgs hOutArgs >>+ genCallbackWrapper name' cb' name' dataptrs hInArgs hOutArgs False) -- | Return the name for the signal in Haskell CamelCase conventions. signalHaskellName :: Text -> Text
src/GI/Struct.hs view
@@ -1,4 +1,6 @@ module GI.Struct ( genStructOrUnionFields+ , genZeroStruct+ , genZeroUnion , extractCallbacksInStruct , fixAPIStructs , ignoreStruct)@@ -101,3 +103,27 @@ ":" <> fieldName field <> "\" :: " <> describeCGError e)) (buildFieldGetter n field)++-- | Generate a constructor for a zero-filled struct/union of the given+-- type, using the boxed (or GLib, for unboxed types) allocator.+genZeroSU :: Name -> Int -> Bool -> CodeGen ()+genZeroSU n size isBoxed =+ when (size /= 0) $ group $ do+ name <- upperName n+ let builder = "newZero" <> name+ tsize = tshow size+ line $ "-- | Construct a `" <> name <> "` struct initialized to zero."+ line $ builder <> " :: MonadIO m => m " <> name+ line $ builder <> " = liftIO $ " <>+ if isBoxed+ then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name+ else "callocBytes " <> tsize <> " >>= wrapPtr " <> name+ exportDecl builder++-- | Specialization for structs of `genZeroSU`.+genZeroStruct :: Name -> Struct -> CodeGen ()+genZeroStruct n s = genZeroSU n (structSize s) (structIsBoxed s)++-- | Specialization for unions of `genZeroSU`.+genZeroUnion :: Name -> Union -> CodeGen ()+genZeroUnion n u = genZeroSU n (unionSize u) (unionIsBoxed u)
src/GI/SymbolNaming.hs view
@@ -4,15 +4,12 @@ , lowerName , upperName , noName- , escapeReserved+ , escapedArgName , classConstraint , hyphensToCamelCase , underscoresToCamelCase ) where -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid)-#endif import Data.Text (Text) import qualified Data.Text as T @@ -24,8 +21,8 @@ classConstraint :: Text -> Text classConstraint n = n <> "K" -lowerName :: Name -> CodeGen Text-lowerName (Name _ s) = return . T.concat . rename . T.split (== '_') $ s+lowerName :: Name -> Text+lowerName (Name _ s) = T.concat . rename . T.split (== '_') $ s where rename [w] = [lcFirst w] rename (w:ws) = lcFirst w : map ucFirst' ws@@ -85,6 +82,16 @@ underscoresToCamelCase :: Text -> Text underscoresToCamelCase = T.concat . map ucFirst . T.split (== '_') +-- | Name for the given argument, making sure it is a valid Haskell+-- argument name (and escaping it if not).+escapedArgName :: Arg -> Text+escapedArgName arg+ | "_" `T.isPrefixOf` argCName arg = argCName arg+ | otherwise =+ escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg++-- | Reserved symbols, either because they are Haskell syntax or+-- because the clash with symbols in scope for the generated bindings. escapeReserved :: Text -> Text escapeReserved "type" = "type_" escapeReserved "in" = "in_"
src/GI/Transfer.hs view
@@ -233,7 +233,12 @@ then case direction arg of DirectionIn -> freeIn (transfer arg) (argType arg) label len DirectionOut -> freeOut label- DirectionInout -> 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 else return [] -- | Same thing as freeInArg, but called in case the call to C didn't@@ -244,4 +249,9 @@ case direction arg of DirectionIn -> freeInOnError (transfer arg) (argType arg) label len DirectionOut -> freeOut label- DirectionInout -> freeOut label+ DirectionInout ->+ -- Caller-allocates arguments are like "in" arguments for+ -- memory management purposes.+ if argCallerAllocates arg+ then freeInOnError (transfer arg) (argType arg) label len+ else freeOut label
src/GI/Type.hs view
@@ -1,6 +1,7 @@ module GI.Type ( BasicType(..)+ , isBasicScalar , Type(..) , io , ptr@@ -13,7 +14,6 @@ import qualified Data.Text as T import Data.Text (Text) --- This enum mirrors the definition in gitypes.h. data BasicType = TVoid | TBoolean@@ -31,6 +31,8 @@ | TGType | TUTF8 | TFileName+ | TIntPtr+ | TUIntPtr deriving (Eq, Enum, Show, Ord) -- This type represents the types found in GObject Introspection@@ -50,6 +52,20 @@ | TVariant | TParamSpec deriving (Eq, Show, Ord)++-- | Whether the given type is a basic scalar, i.e. everything that is+-- not a pointer to a memory region.+isBasicScalar :: Type -> Bool+isBasicScalar (TBasicType b) = basicIsScalar b+isBasicScalar _ = False++-- | Whether the given basic type is a scalar, i.e. not a pointer to a+-- memory region.+basicIsScalar :: BasicType -> Bool+basicIsScalar TVoid = False+basicIsScalar TUTF8 = False+basicIsScalar TFileName = False+basicIsScalar _ = True con :: Text -> [TypeRep] -> TypeRep con "[]" xs = mkTyConApp listCon xs
src/GI/Util.hs view
@@ -39,10 +39,10 @@ -- | Capitalize the first character of the given string. ucFirst :: Text -> Text-ucFirst "" = terror "ucFirst: empty text!"+ucFirst "" = "" ucFirst t = T.cons (toUpper $ T.head t) (T.tail t) -- | Make the first character of the given string lowercase. lcFirst :: Text -> Text-lcFirst "" = terror "lcFirst: empty string"+lcFirst "" = "" lcFirst t = T.cons (toLower $ T.head t) (T.tail t)
src/haskell-gi.hs view
@@ -27,16 +27,16 @@ import GI.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API) import GI.Cabal (cabalConfig, setupHs, genCabalProject)-import GI.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText)+import GI.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText, minBaseVersion) import GI.Config (Config(..)) import GI.CodeGen (genModule)-import GI.Attributes (genAllAttributes)+import GI.OverloadedLabels (genOverloadedLabels) import GI.OverloadedSignals (genOverloadedSignalConnectors) import GI.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps) import GI.ProjectInfo (licenseText) import GI.Util (ucFirst) -data Mode = GenerateCode | Dump | Attributes | Signals | Help+data Mode = GenerateCode | Dump | Labels | Signals | Help data Options = Options { optMode :: Mode,@@ -62,12 +62,12 @@ optDescrs = [ Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help }) "\tprint this gentle help text",- Option "a" ["attributes"] (NoArg $ \opt -> opt {optMode = Attributes})- "generate generic attribute accesors", Option "c" ["connectors"] (NoArg $ \opt -> opt {optMode = Signals}) "generate generic signal connectors", Option "d" ["dump"] (NoArg $ \opt -> opt { optMode = Dump }) "\tdump internal representation",+ Option "l" ["labels"] (NoArg $ \opt -> opt {optMode = Labels})+ "generate overloaded labels", Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False}) "\tdo not generate .cabal file", Option "o" ["overrides"] (ReqArg@@ -98,16 +98,17 @@ gir <- loadRawGIRInfo verbose name version extraPaths return (girAPIs gir) --- Generate all generic accessor functions ("_label", for example).-genGenericAttrs :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()-genGenericAttrs options ovs modules extraPaths = do+-- | Generate overloaded labels ("_label", for example).+genLabels :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()+genLabels options ovs modules extraPaths = do apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules let allAPIs = M.unions (map M.fromList apis) cfg = Config {modName = Nothing, verbose = optVerbose options, overrides = ovs}- putStrLn $ "\t* Generating GI.Properties"- m <- genCode cfg allAPIs ["GI", "Properties"] (genAllAttributes (M.toList allAPIs))+ putStrLn $ "\t* Generating GI.OverloadedLabels"+ m <- genCode cfg allAPIs ["GI", "OverloadedLabels"]+ (genOverloadedLabels (M.toList allAPIs)) _ <- writeModuleCode (optVerbose options) (optOutputDir options) m return () @@ -154,11 +155,11 @@ putStrLn $ "\t\t+ " ++ fname -- The module is not a dep of itself let usedDeps = S.delete name modDeps- -- We only list as dependencies in the cabal file the -- dependencies that we use, disregarding what the .gir file says. actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps- (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList)+ baseVersion = minBaseVersion m+ (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList baseVersion) case err of Nothing -> do TIO.writeFile fname (codeToText (moduleCode m))@@ -189,7 +190,7 @@ Right ovs -> case optMode options of GenerateCode -> forM_ names (processMod options ovs extraPaths)- Attributes -> genGenericAttrs options ovs names extraPaths+ Labels -> genLabels options ovs names extraPaths Signals -> genGenericConnectors options ovs names extraPaths Dump -> forM_ names (dump options ovs) Help -> putStr showHelp