diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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). diff --git a/cmdline/haskell-gi.hs b/cmdline/haskell-gi.hs deleted file mode 100644 --- a/cmdline/haskell-gi.hs +++ /dev/null @@ -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 = "<>", - 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 = "<>", - 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 diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -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 diff --git a/lib/Data/GI/CodeGen/Conversions.hs b/lib/Data/GI/CodeGen/Conversions.hs --- a/lib/Data/GI/CodeGen/Conversions.hs +++ b/lib/Data/GI/CodeGen/Conversions.hs @@ -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. diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -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