haskell-gi 0.21.4 → 0.21.5
raw patch · 5 files changed
+58/−307 lines, 5 filesdep −haskell-gidep ~basedep ~haskell-gi-basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: haskell-gi
Dependency ranges changed: base, haskell-gi-base
API changes (from Hackage documentation)
+ Data.GI.CodeGen.Conversions: typeIsCallback :: Type -> CodeGen Bool
- Data.GI.CodeGen.GtkDoc: CodeBlock :: (Maybe Language) -> Text -> Token
+ Data.GI.CodeGen.GtkDoc: CodeBlock :: Maybe Language -> Text -> Token
Files
- ChangeLog.md +4/−0
- cmdline/haskell-gi.hs +0/−269
- haskell-gi.cabal +2/−21
- lib/Data/GI/CodeGen/Conversions.hs +10/−0
- lib/Data/GI/CodeGen/Properties.hs +42/−17
ChangeLog.md view
@@ -1,3 +1,7 @@+### 0.21.5+++ Add support for callback-valued properties.+ ### 0.21.4 + Try to guess signedness of enums and flags on the C side, fixes [#184](https://github.com/haskell-gi/haskell-gi/issues/184).
− cmdline/haskell-gi.hs
@@ -1,269 +0,0 @@-module Main where--#if !MIN_VERSION_base(4,8,0)-import Data.Traversable (traverse)-#endif-import Control.Monad (forM_, forM, when, (>=>))-import Control.Exception (handle)-import Control.Applicative ((<|>))--import Data.Char (toLower)-import Data.Bool (bool)-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import Data.Text (Text)--import System.Directory (doesFileExist)-import System.Console.GetOpt-import System.Environment (getArgs)-import System.Exit-import System.FilePath (joinPath)-import System.IO (hPutStr, hPutStrLn, stderr)--import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Set as S--import Data.GI.Base.GError-import Text.Show.Pretty (ppShow)--import Data.GI.CodeGen.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API)-import Data.GI.CodeGen.Cabal (cabalConfig, setupHs, genCabalProject, tryPkgConfig)-import Data.GI.CodeGen.Code (genCode, transitiveModuleDeps, writeModuleTree, moduleCode, codeToText, minBaseVersion)-import Data.GI.CodeGen.Config (Config(..))-import Data.GI.CodeGen.CodeGen (genModule)-import Data.GI.CodeGen.LibGIRepository (setupTypelibSearchPath)-import Data.GI.CodeGen.ModulePath (toModulePath)-import Data.GI.CodeGen.OverloadedLabels (genOverloadedLabels)-import Data.GI.CodeGen.OverloadedSignals (genOverloadedSignalConnectors)-import Data.GI.CodeGen.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps, girFixups, pkgConfigMap)-import Data.GI.CodeGen.ProjectInfo (licenseText)-import Data.GI.CodeGen.Util (ucFirst, utf8WriteFile, terror)--data Mode = GenerateCode | Dump | Labels | Signals | Help--data Options = Options {- optMode :: Mode,- optOutputDir :: Maybe String,- optOverridesFiles :: [String],- optSearchPaths :: [String],- optVerbose :: Bool,- optCabal :: Bool,- optOvMethods :: Bool,- optOvProperties :: Bool,- optOvSignals :: Bool-}--defaultOptions :: Options-defaultOptions = Options {- optMode = GenerateCode,- optOutputDir = Nothing,- optOverridesFiles = [],- optSearchPaths = [],- optVerbose = False,- optCabal = True,- optOvMethods = True,- optOvProperties = True,- optOvSignals = True-}--parseKeyValue :: String -> (String, String)-parseKeyValue s =- let (a, '=':b) = break (=='=') s- in (a, b)--solveNameVersion::Overrides -> Text -> (Text, Maybe Text)-solveNameVersion ovs name = (nameWithoutVersion, version)- where- namePieces = T.splitOn "-" name- nameWithoutVersion = head namePieces- versionInName = if length namePieces == 2- then Just (last namePieces)- else Nothing- versionInOverride = M.lookup nameWithoutVersion (nsChooseVersion ovs)- version = versionInOverride <|> versionInName--optDescrs :: [OptDescr (Options -> Options)]-optDescrs = [- Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help })- "\tprint this gentle help text",- 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})- "\tgenerate overloaded labels",- Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False})- ("\tdo not generate cabal project structure\n" ++- "\t\t\t(note: if you do not generate a cabal project, make sure\n" ++- "\t\t\tto still activate the necessary GHC extensions when\n" ++- "\t\t\tcompiling the generated bindings.)"),- Option "o" ["overrides"] (ReqArg- (\arg opt -> opt {optOverridesFiles =- arg : optOverridesFiles opt})- "OVERRIDES")- "specify a file with overrides info",- Option "O" ["output"] (ReqArg- (\arg opt -> opt {optOutputDir = Just arg}) "DIR")- "\tset the output directory",- Option "s" ["search"] (ReqArg- (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt}) "PATH")- "\tprepend a directory to the GIR and typelib search path",- Option "M" ["noMethodOverloading"] (NoArg $ \opt -> opt {optOvMethods = False})- "\tdo not generate method overloading support",- Option "P" ["noPropertyOverloading"] (NoArg $ \opt -> opt {optOvProperties = False})- "\tdo not generate property overloading support",- Option "S" ["noSignalOverloading"] (NoArg $ \opt -> opt {optOvSignals = False})- "\tdo not generate signal overloading support",- Option "v" ["verbose"] (NoArg $ \opt -> opt { optVerbose = True })- "\tprint extra info while processing"]--showHelp :: String-showHelp = concatMap optAsLine optDescrs- where optAsLine (Option flag (long:_) _ desc) =- " -" ++ flag ++ "|--" ++ long ++ "\t" ++ desc ++ "\n"- optAsLine _ = error "showHelp"--printGError :: IO () -> IO ()-printGError = handle (gerrorMessage >=> putStrLn . T.unpack)---- | Load a dependency without further postprocessing.-loadRawAPIs :: Bool -> Overrides -> [FilePath] -> Text -> IO [(Name, API)]-loadRawAPIs verbose ovs extraPaths name = do- let (nameWithoutVersion, version) = solveNameVersion ovs name- gir <- loadRawGIRInfo verbose nameWithoutVersion version extraPaths- return (girAPIs gir)---- | 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 = "<<GI autogenerated labels>>",- verbose = optVerbose options,- overrides = ovs- }- putStrLn $ "\t* Generating GI.OverloadedLabels"- let m = genCode cfg allAPIs "OverloadedLabels"- (genOverloadedLabels (M.toList allAPIs))- _ <- writeModuleTree (optVerbose options) (optOutputDir options) m- return ()---- | Generate generic signal connectors ("Clicked", "Activate", ...)-genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()-genGenericConnectors options ovs modules extraPaths = do- apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules- let allAPIs = M.unions (map M.fromList apis)- cfg = Config {modName = "<<GI autogenerated connectors>>",- verbose = optVerbose options,- overrides = ovs}- putStrLn $ "\t* Generating GI.Signals"- let m = genCode cfg allAPIs "Signals" (genOverloadedSignalConnectors (M.toList allAPIs))- _ <- writeModuleTree (optVerbose options) (optOutputDir options) m- return ()---- | Generate the code for the given module, and return the dependencies--- for this module.-processMod :: Options -> Overrides -> [FilePath] -> Text -> IO ()-processMod options ovs extraPaths name = do- let (nameWithoutVersion, version) = solveNameVersion ovs name- cfg = Config {modName = nameWithoutVersion,- verbose = optVerbose options,- overrides = ovs}- nm = ucFirst nameWithoutVersion- mp = T.unpack . ("GI." <>)-- putStrLn $ "\t* Generating " ++ mp nm-- (gir, girDeps) <- loadGIRInfo (optVerbose options) nameWithoutVersion version extraPaths- (girFixups ovs)- let (apis, deps) = filterAPIsAndDeps ovs gir girDeps- allAPIs = M.union apis deps- m = genCode cfg allAPIs (toModulePath nm) (genModule apis)- modDeps = transitiveModuleDeps m-- moduleList <- writeModuleTree (optVerbose options) (optOutputDir options) m-- when (optCabal options) $ do- let cabal = "gi-" ++ map toLower (T.unpack nm) ++ ".cabal"- fname <- doesFileExist cabal >>=- bool (return cabal)- (putStrLn (cabal ++ " exists, writing "- ++ cabal ++ ".new instead") >>- return (cabal ++ ".new"))-- let pkMap = pkgConfigMap (overrides cfg)-- pkgInfo <- tryPkgConfig gir (verbose cfg) pkMap >>= \case- Left err -> terror err- Right info -> return info-- -- The module is not a dep of itself- let usedDeps = S.delete nameWithoutVersion 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- baseVersion = minBaseVersion m- p = \n -> joinPath [fromMaybe "" (optOutputDir options), n]-- resolvedDeps <- forM actualDeps $ \dep -> do- tryPkgConfig dep (verbose cfg) pkMap >>= \case- Left err -> terror err- Right info -> return (dep, info)-- let m = genCode cfg allAPIs (error "undefined module path")- (genCabalProject (gir, pkgInfo) resolvedDeps moduleList baseVersion)-- putStrLn $ "\t\t+ " ++ fname- utf8WriteFile (p fname) (codeToText (moduleCode m))- putStrLn "\t\t+ cabal.config"- utf8WriteFile (p "cabal.config") cabalConfig- putStrLn "\t\t+ Setup.hs"- utf8WriteFile (p "Setup.hs") setupHs- putStrLn "\t\t+ LICENSE"- utf8WriteFile (p "LICENSE") licenseText--dump :: Options -> Overrides -> Text -> IO ()-dump options ovs name = do- let (nameWithoutVersion, version) = solveNameVersion ovs name- (doc, _) <- loadGIRInfo (optVerbose options) nameWithoutVersion version (optSearchPaths options) []- mapM_ (putStrLn . ppShow) (girAPIs doc)--process :: Options -> [Text] -> IO ()-process options names = do- let extraPaths = optSearchPaths options- setupTypelibSearchPath (optSearchPaths options)- configs <- traverse parseOverridesFile (optOverridesFiles options)- case mconcat <$> sequence configs of- Left errorMsg -> do- hPutStr stderr "Error when parsing the config file(s):\n"- hPutStr stderr (T.unpack errorMsg)- exitFailure- Right ovs ->- case optMode options of- GenerateCode -> forM_ names (processMod options ovs extraPaths)- Labels -> genLabels options ovs names extraPaths- Signals -> genGenericConnectors options ovs names extraPaths- Dump -> forM_ names (dump options ovs)- Help -> putStr showHelp--main :: IO ()-main = printGError $ do- args <- getArgs- let (actions, nonOptions, errors) = getOpt RequireOrder optDescrs args- options = foldl (.) id actions defaultOptions-- case errors of- [] -> return ()- _ -> do- mapM_ (hPutStr stderr) errors- exitFailure-- case nonOptions of- [] -> failWithUsage- names -> process options (map T.pack names)- where- failWithUsage = do- hPutStrLn stderr "usage: haskell-gi [options] module1 [module2 [...]]"- hPutStr stderr showHelp- exitFailure
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name: haskell-gi-version: 0.21.4+version: 0.21.5 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too.@@ -14,7 +14,7 @@ stability: Experimental category: Development build-type: Simple-tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.1+tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.4.1, GHC == 8.6.1 cabal-version: >=1.8 extra-source-files: ChangeLog.md@@ -122,22 +122,3 @@ build-depends: base , process , doctest >= 0.8--executable haskell-gi- main-is: haskell-gi.hs- hs-source-dirs: cmdline-- extensions: CPP, OverloadedStrings, LambdaCase- ghc-options: -Wall -fno-warn-name-shadowing-- if impl(ghc >= 8.0)- ghc-options: -Wcompat-- build-depends: base >= 4.7 && < 5,- text >= 1.0,- filepath,- containers,- directory,- pretty-show,- haskell-gi,- haskell-gi-base
lib/Data/GI/CodeGen/Conversions.hs view
@@ -23,6 +23,7 @@ , isManaged , typeIsNullable , typeIsPtr+ , typeIsCallback , maybeNullConvert , nullPtrForType @@ -775,6 +776,15 @@ -- style arguments). callableHasClosures :: Callable -> Bool callableHasClosures = any (/= -1) . map argClosure . args++-- | Check whether the given type corresponds to a callback.+typeIsCallback :: Type -> CodeGen Bool+typeIsCallback t@(TInterface _) = do+ api <- findAPI t+ case api of+ Just (APICallback _) -> return True+ _ -> return False+typeIsCallback _ = return False -- | Basically like `haskellType`, but for types which admit a "isomorphic" -- version of the Haskell type distinct from the usual Haskell type.
lib/Data/GI/CodeGen/Properties.hs view
@@ -25,7 +25,8 @@ import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList) import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, classConstraint, typeConstraint,- hyphensToCamelCase, qualifiedSymbol)+ hyphensToCamelCase, qualifiedSymbol,+ callbackDynamicWrapper) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -64,6 +65,7 @@ case api of APIEnum _ -> return "Enum" APIFlags _ -> return "Flags"+ APICallback _ -> return "Callback" APIStruct s -> if structIsBoxed s then return "Boxed" else error $ "Unboxed struct property : " ++ show t@@ -87,8 +89,14 @@ -- the type variables for the object and its value. attrType :: Property -> CodeGen ([Text], Text) attrType prop = do- (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop- return (constraints, t)+ isCallback <- typeIsCallback (propType prop)+ if isCallback+ then do+ ftype <- foreignType (propType prop)+ return ([], typeShow ftype)+ else do+ (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop+ return (constraints, t) -- | Generate documentation for the given setter. setterDoc :: Name -> Property -> Text@@ -105,6 +113,7 @@ genPropertySetter setter n docSection prop = group $ do (constraints, t) <- attrType prop isNullable <- typeIsNullable (propType prop)+ isCallback <- typeIsCallback (propType prop) cls <- classConstraint n let constraints' = "MonadIO m":(cls <> " o"):constraints tStr <- propTypeStr $ propType prop@@ -113,7 +122,7 @@ <> ") => o -> " <> t <> " -> m ()" line $ setter <> " obj val = liftIO $ setObjectProperty" <> tStr <> " obj \"" <> propName prop- <> if isNullable+ <> if isNullable && (not isCallback) then "\" (Just val)" else "\" val" export docSection setter@@ -132,25 +141,34 @@ genPropertyGetter getter n docSection prop = group $ do isNullable <- typeIsNullable (propType prop) let isMaybe = isNullable && propReadNullable prop /= Just False- constructorType <- haskellType (propType prop)+ constructorType <- isoHaskellType (propType prop) tStr <- propTypeStr $ propType prop cls <- classConstraint n let constraints = "(MonadIO m, " <> cls <> " o)" outType = if isMaybe then maybeT constructorType else constructorType+ returnType = typeShow $ "m" `con` [outType] getProp = if isNullable && not isMaybe then "checkUnexpectedNothing \"" <> getter <> "\" $ getObjectProperty" <> tStr else "getObjectProperty" <> tStr+ -- Some property getters require in addition a constructor, which+ -- will convert the foreign value to the wrapped Haskell one.+ constructorArg <-+ if tStr `elem` ["Object", "Boxed"]+ then return $ " " <> typeShow constructorType+ else (if tStr == "Callback"+ then do+ callbackType <- haskellType (propType prop)+ return $ " " <> callbackDynamicWrapper (typeShow callbackType)+ else return "")+ writeHaddock DocBeforeSymbol (getterDoc n prop) line $ getter <> " :: " <> constraints <>- " => o -> " <> typeShow ("m" `con` [outType])+ " => o -> " <> returnType line $ getter <> " obj = liftIO $ " <> getProp- <> " obj \"" <> propName prop <> "\"" <>- if tStr `elem` ["Object", "Boxed"]- then " " <> typeShow constructorType -- These require the constructor.- else ""+ <> " obj \"" <> propName prop <> "\"" <> constructorArg export docSection getter -- | Generate documentation for the given constructor.@@ -164,6 +182,7 @@ (constraints, t) <- attrType prop tStr <- propTypeStr $ propType prop isNullable <- typeIsNullable (propType prop)+ isCallback <- typeIsCallback (propType prop) cls <- classConstraint n let constraints' = (cls <> " o") : constraints pconstraints = parenthesize (T.intercalate ", " constraints') <> " => "@@ -172,7 +191,7 @@ <> t <> " -> IO (GValueConstruct o)" line $ constructor <> " val = constructObjectProperty" <> tStr <> " \"" <> propName prop- <> if isNullable+ <> if isNullable && (not isCallback) then "\" (Just val)" else "\" val" export docSection constructor@@ -189,16 +208,19 @@ genPropertyClear :: Text -> Name -> HaddockSection -> Property -> CodeGen () genPropertyClear clear n docSection prop = group $ do- nothingType <- typeShow . maybeT <$> haskellType (propType prop) cls <- classConstraint n let constraints = ["MonadIO m", cls <> " o"] tStr <- propTypeStr $ propType prop writeHaddock DocBeforeSymbol (clearDoc prop)+ nothingType <- typeShow . maybeT <$> haskellType (propType prop)+ isCallback <- typeIsCallback (propType prop)+ let nothing = if isCallback+ then "FP.nullFunPtr"+ else "(Nothing :: " <> nothingType <> ")" line $ clear <> " :: (" <> T.intercalate ", " constraints <> ") => o -> m ()" line $ clear <> " obj = liftIO $ setObjectProperty" <> tStr- <> " obj \"" <> propName prop <> "\" (Nothing :: "- <> nothingType <> ")"+ <> " obj \"" <> propName prop <> "\" " <> nothing export docSection clear -- | The property name as a lexically valid Haskell identifier. Note@@ -300,8 +322,8 @@ then return "()" else do sOutType <- if isNullable && propReadNullable prop /= Just False- then typeShow . maybeT <$> haskellType (propType prop)- else typeShow <$> haskellType (propType prop)+ then typeShow . maybeT <$> isoHaskellType (propType prop)+ else typeShow <$> isoHaskellType (propType prop) return $ if T.any (== ' ') sOutType then parenthesize sOutType else sOutType@@ -312,7 +334,10 @@ inConstraint <- if writable || constructOnly then do inIsGO <- isGObject (propType prop)- hInType <- typeShow <$> haskellType (propType prop)+ isCallback <- typeIsCallback (propType prop)+ hInType <- if isCallback+ then typeShow <$> foreignType (propType prop)+ else typeShow <$> haskellType (propType prop) if inIsGO then typeConstraint (propType prop) else return $ "(~) " <> if T.any (== ' ') hInType