haskell-gi 0.17.4 → 0.18
raw patch · 21 files changed
+1083/−477 lines, 21 filesdep −file-embeddep ~haskell-gi-base
Dependencies removed: file-embed
Dependency ranges changed: haskell-gi-base
Files
- cmdline/haskell-gi.hs +37/−9
- haskell-gi.cabal +2/−3
- lib/Data/GI/CodeGen/Cabal.hs +1/−0
- lib/Data/GI/CodeGen/CabalHooks.hs +65/−6
- lib/Data/GI/CodeGen/Callable.hs +7/−5
- lib/Data/GI/CodeGen/Code.hs +95/−103
- lib/Data/GI/CodeGen/CodeGen.hs +172/−161
- lib/Data/GI/CodeGen/Config.hs +16/−2
- lib/Data/GI/CodeGen/Constant.hs +2/−1
- lib/Data/GI/CodeGen/Conversions.hs +24/−21
- lib/Data/GI/CodeGen/Inheritance.hs +2/−1
- lib/Data/GI/CodeGen/OverloadedLabels.hs +2/−1
- lib/Data/GI/CodeGen/OverloadedMethods.hs +15/−14
- lib/Data/GI/CodeGen/OverloadedSignals.hs +13/−11
- lib/Data/GI/CodeGen/PkgConfig.hs +3/−1
- lib/Data/GI/CodeGen/ProjectInfo.hs +460/−5
- lib/Data/GI/CodeGen/Properties.hs +86/−78
- lib/Data/GI/CodeGen/Signal.hs +5/−5
- lib/Data/GI/CodeGen/Struct.hs +26/−20
- lib/Data/GI/CodeGen/SymbolNaming.hs +49/−30
- lib/Data/GI/CodeGen/Transfer.hs +1/−0
cmdline/haskell-gi.hs view
@@ -29,8 +29,8 @@ import Data.GI.CodeGen.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API) import Data.GI.CodeGen.Cabal (cabalConfig, setupHs, genCabalProject)-import Data.GI.CodeGen.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText, minBaseVersion)-import Data.GI.CodeGen.Config (Config(..))+import Data.GI.CodeGen.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, moduleCode, codeToText, minBaseVersion)+import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.CodeGen (genModule) import Data.GI.CodeGen.OverloadedLabels (genOverloadedLabels) import Data.GI.CodeGen.OverloadedSignals (genOverloadedSignalConnectors)@@ -46,7 +46,11 @@ optOverridesFiles :: [String], optSearchPaths :: [String], optVerbose :: Bool,- optCabal :: Bool}+ optCabal :: Bool,+ optOvMethods :: Bool,+ optOvProperties :: Bool,+ optOvSignals :: Bool+} defaultOptions :: Options defaultOptions = Options {@@ -55,7 +59,11 @@ optOverridesFiles = [], optSearchPaths = [], optVerbose = False,- optCabal = True}+ optCabal = True,+ optOvMethods = True,+ optOvProperties = True,+ optOvSignals = True+} parseKeyValue :: String -> (String, String) parseKeyValue s =@@ -88,6 +96,12 @@ Option "s" ["search"] (ReqArg (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH") "\tprepend a directory to the 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"] @@ -107,6 +121,14 @@ gir <- loadRawGIRInfo verbose name version extraPaths return (girAPIs gir) +-- | Set up the flags for the code generator.+genFlags :: Options -> CodeGenFlags+genFlags opts = CodeGenFlags {+ cgOverloadedProperties = optOvProperties opts+ , cgOverloadedSignals = optOvSignals opts+ , cgOverloadedMethods = optOvMethods opts+ }+ -- | Generate overloaded labels ("_label", for example). genLabels :: Options -> Overrides -> [Text] -> [FilePath] -> IO () genLabels options ovs modules extraPaths = do@@ -114,11 +136,13 @@ let allAPIs = M.unions (map M.fromList apis) cfg = Config {modName = Nothing, verbose = optVerbose options,- overrides = ovs}+ overrides = ovs,+ cgFlags = genFlags options+ } putStrLn $ "\t* Generating GI.OverloadedLabels" m <- genCode cfg allAPIs ["GI", "OverloadedLabels"] (genOverloadedLabels (M.toList allAPIs))- _ <- writeModuleCode (optVerbose options) (optOutputDir options) m+ _ <- writeModuleTree (optVerbose options) (optOutputDir options) m return () -- Generate generic signal connectors ("Clicked", "Activate", ...)@@ -128,10 +152,12 @@ let allAPIs = M.unions (map M.fromList apis) cfg = Config {modName = Nothing, verbose = optVerbose options,- overrides = ovs}+ overrides = ovs,+ cgFlags = genFlags options+ } putStrLn $ "\t* Generating GI.Signals" m <- genCode cfg allAPIs ["GI", "Signals"] (genOverloadedSignalConnectors (M.toList allAPIs))- _ <- writeModuleCode (optVerbose options) (optOutputDir options) m+ _ <- writeModuleTree (optVerbose options) (optOutputDir options) m return () -- Generate the code for the given module, and return the dependencies@@ -141,7 +167,9 @@ let version = M.lookup name (nsChooseVersion ovs) cfg = Config {modName = Just name, verbose = optVerbose options,- overrides = ovs}+ overrides = ovs,+ cgFlags = genFlags options+ } nm = ucFirst name mp = T.unpack . ("GI." <>)
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name: haskell-gi-version: 0.17.4+version: 0.18 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.@@ -23,12 +23,11 @@ Library pkgconfig-depends: gobject-introspection-1.0 >= 1.32, gobject-2.0 >= 2.32 build-depends: base >= 4.7 && < 5,- haskell-gi-base == 0.17.*,+ haskell-gi-base == 0.18.*, Cabal >= 1.20, containers, directory, filepath,- file-embed >= 0.0.9, mtl >= 2.2, transformers >= 0.3, pretty-show,
lib/Data/GI/CodeGen/Cabal.hs view
@@ -10,6 +10,7 @@ import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T
lib/Data/GI/CodeGen/CabalHooks.hs view
@@ -8,19 +8,24 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Setup import Distribution.Simple (UserHooks(..), simpleUserHooks,- defaultMainWithHooks)+ defaultMainWithHooks, OptimisationLevel(..),+ Dependency(..), PackageName(..)) import Distribution.PackageDescription import Data.GI.CodeGen.API (loadGIRInfo) import Data.GI.CodeGen.Code (genCode, writeModuleTree, listModuleTree) import Data.GI.CodeGen.CodeGen (genModule)-import Data.GI.CodeGen.Config (Config(..))+import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.Overrides (parseOverridesFile, girFixups, filterAPIsAndDeps)-import Data.GI.CodeGen.Util (ucFirst)+import Data.GI.CodeGen.PkgConfig (tryPkgConfig)+import Data.GI.CodeGen.Util (ucFirst, tshow) +import Control.Monad (when)+ import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M+import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO@@ -31,6 +36,49 @@ type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo +-- | Generate the @PkgInfo@ module, listing the build information for+-- the module. We include in particular the versions for the+-- `pkg-config` dependencies of the module.+genPkgInfo :: [Dependency] -> [(FlagName, Bool)] -> FilePath -> Text -> IO ()+genPkgInfo deps flags fName modName = do+ versions <- mapM findVersion deps+ TIO.writeFile fName $ T.unlines+ [ "module " <> modName <> " (pkgConfigVersions, flags) where"+ , ""+ , "import Prelude (String, Bool(..))"+ , ""+ , "pkgConfigVersions :: [(String, String)]"+ , "pkgConfigVersions = " <> tshow versions+ , ""+ , "flags :: [(String, Bool)]"+ , "flags = " <> tshow flags'+ ]+ where findVersion :: Dependency -> IO (Text, Text)+ findVersion (Dependency (PackageName n) _) =+ tryPkgConfig (T.pack n) >>= \case+ Just v -> return v+ Nothing -> error ("Could not determine version for required pkg-config module \"" <> n <> "\".")++ flags' :: [(String, Bool)]+ flags' = map (\(FlagName fn, v) -> (fn, v)) flags++-- | Parse the set of flags given to configure into flags for the code+-- generator.+parseFlags :: [(FlagName, Bool)] -> CodeGenFlags+parseFlags fs = parsed+ where parsed :: CodeGenFlags+ parsed = CodeGenFlags {+ cgOverloadedProperties = check "overloaded-properties"+ , cgOverloadedSignals = check "overloaded-signals"+ , cgOverloadedMethods = check "overloaded-methods"+ }++ check :: String -> Bool+ check s = fromMaybe True (M.lookup s flags)++ flags :: M.Map String Bool+ flags = M.fromList (map (\(FlagName fn, v) -> (fn, v)) fs)+ -- | A convenience helper for `confHook`, such that bindings for the -- given module are generated in the @configure@ step of @cabal@. confCodeGenHook :: Text -- ^ name@@ -55,7 +103,8 @@ allAPIs = M.union apis deps cfg = Config {modName = Just name, verbose = verbosity,- overrides = ovs}+ overrides = ovs,+ cgFlags = parseFlags (configConfigurationsFlags flags)} m <- genCode cfg allAPIs ["GI", ucFirst name] (genModule apis) alreadyDone <- doesFileExist (fromMaybe "" outputDir@@ -64,13 +113,23 @@ then writeModuleTree verbosity outputDir m else return (listModuleTree m) - let em' = map (MN.fromString . T.unpack) moduleList+ let pkgInfoMod = "GI." <> ucFirst name <> ".PkgInfo"+ em' = map (MN.fromString . T.unpack) (pkgInfoMod : moduleList) ctd' = ((condTreeData . fromJust . condLibrary) gpd) {exposedModules = em'} cL' = ((fromJust . condLibrary) gpd) {condTreeData = ctd'} gpd' = gpd {condLibrary = Just cL'} - defaultConfHook (gpd', hbi) flags+ when (not alreadyDone) $+ genPkgInfo ((pkgconfigDepends . libBuildInfo . condTreeData .+ fromJust . condLibrary) gpd)+ (configConfigurationsFlags flags)+ (fromMaybe "" outputDir+ </> "GI" </> T.unpack (ucFirst name) </> "PkgInfo.hs")+ pkgInfoMod + lbi <- defaultConfHook (gpd', hbi) flags++ return (lbi {withOptimization = NoOptimisation}) -- | The entry point for @Setup.hs@ files in bindings. setupHaskellGIBinding :: Text -- ^ name
lib/Data/GI/CodeGen/Callable.hs view
@@ -19,6 +19,7 @@ import Data.Bool (bool) import Data.List (nub, (\\)) import Data.Maybe (isJust)+import Data.Monoid ((<>)) import Data.Tuple (swap) import Data.Typeable (TypeRep, typeOf) import qualified Data.Map as Map@@ -283,18 +284,19 @@ return maybeName) -- Callbacks are a fairly special case, we treat them separately.-prepareInCallback :: Arg -> ExcCodeGen Text+prepareInCallback :: Arg -> CodeGen Text prepareInCallback arg = do let name = escapedArgName arg ptrName = "ptr" <> name scope = argScope arg (maker, wrapper) <- case argType arg of- (TInterface ns n) ->+ TInterface ns n -> do- prefix <- qualify ns- return $ (prefix <> "mk" <> n,- prefix <> lcFirst n <> "Wrapper")+ let tn = Name ns n+ maker <- qualifiedSymbol ("mk" <> n) tn+ wrapper <- qualifiedSymbol (lcFirst n <> "Wrapper") tn+ return $ (maker, wrapper) _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg) when (scope == ScopeTypeAsync) $ do
lib/Data/GI/CodeGen/Code.hs view
@@ -11,14 +11,15 @@ , writeModuleTree , listModuleTree- , writeModuleCode , codeToText , transitiveModuleDeps , minBaseVersion , BaseVersion(..) , showBaseVersion - , loadDependency+ , ModuleName+ , registerNSDependency+ , qualified , getDeps , recurseWithAPIs @@ -49,18 +50,16 @@ , exportSignal , findAPI+ , getAPI , findAPIByName , getAPIs , config , currentModule-- -- From Data.Monoid, for convenience- , (<>) ) where #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>)) import Data.Monoid (Monoid(..)) #endif import Control.Monad.Reader@@ -83,7 +82,7 @@ import Data.GI.CodeGen.API (API, Name(..)) import Data.GI.CodeGen.Config (Config(..)) import Data.GI.CodeGen.Type (Type(..))-import Data.GI.CodeGen.Util (tshow, terror, ucFirst, padTo)+import Data.GI.CodeGen.Util (tshow, terror, padTo) import Data.GI.CodeGen.ProjectInfo (authors, license, maintainers) import Data.GI.GIR.Documentation (Documentation(..)) @@ -143,6 +142,7 @@ -- module name. , moduleDeps :: Deps -- ^ Set of dependencies for this module. , moduleExports :: Seq Export -- ^ Exports for the module.+ , qualifiedImports :: Set.Set ModuleName -- ^ Qualified (source) imports , 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.@@ -154,9 +154,6 @@ -- | Flags for module code generation. data ModuleFlag = ImplicitPrelude -- ^ Use the standard prelude, -- instead of the haskell-gi-base short one.- | NoTypesImport -- ^ Do not import a "Types" submodule.- | NoCallbacksImport-- ^ Do not import a "Callbacks" submodule.- | Reexport -- ^ Reexport the module (as is) from .Types deriving (Show, Eq, Ord) -- | Minimal version of base supported by a given module.@@ -177,6 +174,7 @@ , submodules = M.empty , moduleDeps = Set.empty , moduleExports = S.empty+ , qualifiedImports = Set.empty , modulePragmas = Set.empty , moduleGHCOpts = Set.empty , moduleFlags = Set.empty@@ -222,6 +220,7 @@ cleanInfo :: ModuleInfo -> ModuleInfo cleanInfo info = info { moduleCode = NoCode, submodules = M.empty, bootCode = NoCode, moduleExports = S.empty,+ qualifiedImports = Set.empty, moduleDoc = Nothing, moduleMinBase = Base47 } -- | Run the given code generator using the state and config of an@@ -257,6 +256,7 @@ let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState) newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState) newExports = moduleExports oldState <> moduleExports newState+ newImports = qualifiedImports oldState <> qualifiedImports newState newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState) newGHCOpts = Set.union (moduleGHCOpts oldState) (moduleGHCOpts newState) newFlags = Set.union (moduleFlags oldState) (moduleFlags newState)@@ -264,7 +264,8 @@ newDoc = moduleDoc oldState <> moduleDoc newState newMinBase = max (moduleMinBase oldState) (moduleMinBase newState) in oldState {moduleDeps = newDeps, submodules = newSubmodules,- moduleExports = newExports, modulePragmas = newPragmas,+ moduleExports = newExports, qualifiedImports = newImports,+ modulePragmas = newPragmas, moduleGHCOpts = newGHCOpts, moduleFlags = newFlags, bootCode = newBoot, moduleDoc = newDoc, moduleMinBase = newMinBase }@@ -280,17 +281,28 @@ addSubmodule :: Text -> ModuleInfo -> ModuleInfo -> ModuleInfo addSubmodule modName submodule current = current { submodules = M.insertWith mergeInfo modName submodule (submodules current)} --- | Run the given CodeGen in order to generate a submodule of the--- current module.-submodule :: Text -> BaseCodeGen e () -> BaseCodeGen e ()-submodule modName cg = do+-- | Run the given CodeGen in order to generate a single submodule of the+-- current module. Note that we do not generate the submodule if the+-- code generator generated no code and the module does not have+-- submodules.+submodule' :: Text -> BaseCodeGen e () -> BaseCodeGen e ()+submodule' modName cg = do cfg <- ask oldInfo <- get let info = emptyModule (moduleName oldInfo ++ [modName]) liftIO (runCodeGen cg cfg info) >>= \case Left e -> throwError e- Right (_, smInfo) -> modify' (addSubmodule modName smInfo)+ Right (_, smInfo) -> if moduleCode smInfo == NoCode &&+ M.null (submodules smInfo)+ then return ()+ else modify' (addSubmodule modName smInfo) +-- | Run the given CodeGen in order to generate a submodule (specified+-- an an ordered list) of the current module.+submodule :: [Text] -> BaseCodeGen e () -> BaseCodeGen e ()+submodule [] cg = cg+submodule (m:ms) cg = submodule' m (submodule ms cg)+ -- | Try running the given `action`, and if it fails run `fallback` -- instead. handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a@@ -351,8 +363,8 @@ unwrapCodeGen cg cfg' initialInfo -- | Mark the given dependency as used by the module.-loadDependency :: Text -> CodeGen ()-loadDependency name = do+registerNSDependency :: Text -> CodeGen ()+registerNSDependency name = do deps <- getDeps unless (Set.member name deps) $ do let newDeps = Set.insert name deps@@ -365,6 +377,39 @@ Set.unions (moduleDeps minfo : map transitiveModuleDeps (M.elems $ submodules minfo)) +-- | Given a module name and a symbol in the module (including a+-- proper namespace), return a qualified name for the symbol.+qualified :: ModuleName -> Name -> CodeGen Text+qualified mn (Name ns s) = do+ cfg <- config+ -- Make sure the module is listed as a dependency.+ when (modName cfg /= Just ns) $+ registerNSDependency ns+ minfo <- get+ if mn == moduleName minfo+ then return s+ else do+ qm <- qualifiedImport mn+ return (qm <> "." <> s)++-- | Import the given module name qualified (as a source import if the+-- namespace is the same as the current one), and return the name+-- under which the module was imported.+qualifiedImport :: ModuleName -> CodeGen Text+qualifiedImport mn = do+ modify' $ \s -> s {qualifiedImports = Set.insert mn (qualifiedImports s)}+ return (qualifiedModuleName mn)++-- | Construct a simplified version of the module name, suitable for a+-- qualified import.+qualifiedModuleName :: ModuleName -> Text+qualifiedModuleName ["GI", ns, "Objects", o] = ns <> "." <> o+qualifiedModuleName ["GI", ns, "Interfaces", i] = ns <> "." <> i+qualifiedModuleName ["GI", ns, "Structs", s] = ns <> "." <> s+qualifiedModuleName ["GI", ns, "Unions", u] = ns <> "." <> u+qualifiedModuleName ("GI" : rest) = dotModuleName rest+qualifiedModuleName mn = dotModuleName mn+ -- | Return the minimal base version supported by the module and all -- its submodules. minBaseVersion :: ModuleInfo -> BaseVersion@@ -393,6 +438,13 @@ findAPI (TInterface ns n) = Just <$> findAPIByName (Name ns n) findAPI _ = return Nothing +-- | Find the API associated with a given type. If the API cannot be+-- found this raises an `error`.+getAPI :: Type -> CodeGen API+getAPI t = findAPI t >>= \case+ Just a -> return a+ Nothing -> terror ("Could not resolve type \"" <> tshow t <> "\".")+ findAPIByName :: Name -> CodeGen API findAPIByName n@(Name ns _) = do apis <- getAPIs@@ -652,17 +704,27 @@ <> " ) where\n\n" <> T.unlines (map ("import " <>) reexportedModules) --- | Code for loading the needed dependencies.-importDeps :: [Text] -> Text-importDeps [] = ""-importDeps deps = T.unlines . map toImport $ deps- where toImport :: Text -> Text- toImport dep = let ucDep = ucFirst dep- in "import qualified GI." <> ucDep <> " as " <> ucDep+-- | Code for loading the needed dependencies. One needs to give the+-- prefix for the namespace being currently generated, modules with+-- this prefix will be imported as {-# SOURCE #-}, and otherwise will+-- be imported normally.+importDeps :: ModuleName -> [ModuleName] -> Text+importDeps _ [] = ""+importDeps prefix deps = T.unlines . map toImport $ deps+ where toImport :: ModuleName -> Text+ toImport dep = let impSt = if importSource dep+ then "import {-# SOURCE #-} qualified "+ else "import qualified "+ in impSt <> dotModuleName dep <>+ " as " <> qualifiedModuleName dep+ importSource :: ModuleName -> Bool+ importSource ["GI", _, "Callbacks"] = False+ importSource mn = take (length prefix) mn == prefix -- | Standard imports. moduleImports :: Text moduleImports = T.unlines [ "import Data.GI.Base.ShortPrelude"+ , "import qualified Data.GI.Base.Overloading as O" , "import qualified Prelude as P" , "" , "import qualified Data.GI.Base.Attributes as GI.Attributes"@@ -689,25 +751,15 @@ imports = if ImplicitPrelude `Set.member` moduleFlags minfo then "" else moduleImports- deps = importDeps (Set.toList $ moduleDeps minfo) pkgRoot = take 2 (moduleName minfo)- typesModule = pkgRoot ++ ["Types"]- types = if moduleName minfo == typesModule ||- NoTypesImport `Set.member` moduleFlags minfo- then ""- else "import " <> dotModuleName typesModule- callbacksModule = pkgRoot ++ ["Callbacks"]- callbacks = if moduleName minfo == callbacksModule ||- NoCallbacksImport `Set.member` moduleFlags minfo- then ""- else "import " <> dotModuleName callbacksModule+ deps = importDeps pkgRoot (Set.toList $ qualifiedImports minfo) haddock = moduleHaddock (moduleDoc minfo) when verbose $ putStrLn ((T.unpack . dotModuleName . moduleName) minfo ++ " -> " ++ fname) createDirectoryIfMissing True dirname TIO.writeFile fname (T.unlines [pragmas, optionsGHC, haddock, prelude,- imports, types, callbacks, deps, code])+ imports, deps, code]) when (bootCode minfo /= NoCode) $ do let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot" TIO.writeFile bootFName (genHsBoot minfo)@@ -731,76 +783,16 @@ -- | Write down the code for a module and its submodules to disk under -- the given base directory. It returns the list of written modules.-writeModuleCode :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]-writeModuleCode verbose dirPrefix minfo = do+writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]+writeModuleTree verbose dirPrefix minfo = do submoduleNames <- concat <$> forM (M.elems (submodules minfo))- (writeModuleCode verbose dirPrefix)+ (writeModuleTree verbose dirPrefix) writeModuleInfo verbose dirPrefix minfo return $ (dotModuleName (moduleName minfo) : submoduleNames) --- | Return the list of modules `writeModuleCode` would write, without+-- | Return the list of modules `writeModuleTree` would write, without -- actually writing anything to disk.-listModules :: ModuleInfo -> [Text]-listModules minfo =- let submoduleNames = concatMap listModules (M.elems (submodules minfo))- in dotModuleName (moduleName minfo) : submoduleNames---- | List of reexports from the ".Types" module.-typeReexports :: ModuleName -> [Text] -> Text-typeReexports typesModule bootFiles =- "module " <> dotModuleName typesModule <>- "\n ( " <>- formatExportList (map (Export ExportModule) bootFiles) <>- " ) where\n\n"---- | Import the given (.hs-boot) modules.-hsBootImports :: [Text] -> Text-hsBootImports bootFiles =- T.unlines (map ("import {-# SOURCE #-} " <>) bootFiles)---- | Write down the ".Types" file reexporting all the interfaces--- defined in .hs-boot files. Returns the module name for the ".Types" file.-writeTypes :: Maybe FilePath -> ModuleInfo -> IO Text-writeTypes dirPrefix minfo = do- let pkgRoot = take 2 (moduleName minfo)- typesModule = pkgRoot ++ ["Types"]- fname = moduleNameToPath dirPrefix typesModule ".hs"- dirname = takeDirectory fname- bootfiles = map (dotModuleName . moduleName) (collectBootFiles minfo)- reexports = map (dotModuleName . moduleName) (collectReexports minfo)- exports = typeReexports typesModule (bootfiles ++ reexports)-- createDirectoryIfMissing True dirname- TIO.writeFile fname (T.unlines [exports, hsBootImports bootfiles,- T.unlines (map ("import " <>) reexports) ])- return (dotModuleName typesModule)-- where collectBootFiles :: ModuleInfo -> [ModuleInfo]- collectBootFiles minfo =- let sms = M.elems (submodules minfo)- in if bootCode minfo /= NoCode- then minfo : concatMap collectBootFiles sms- else concatMap collectBootFiles sms-- collectReexports :: ModuleInfo -> [ModuleInfo]- collectReexports minfo =- let sms = M.elems (submodules minfo)- in if Reexport `Set.member` moduleFlags minfo- then minfo : concatMap collectReexports sms- else concatMap collectReexports sms---- | Write down the code for a module and its submodules to disk under--- the given base directory. This also writes the submodules, and a--- "Types" submodule reexporting all interfaces defined in .hs-boot--- files. It returns the list of written modules.-writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]-writeModuleTree verbose dirPrefix minfo =- (:) <$> writeTypes dirPrefix minfo <*> writeModuleCode verbose dirPrefix minfo---- | Return the list of modules that would be written by--- `writeModuleTree`, without actually writing anything to disk. listModuleTree :: ModuleInfo -> [Text] listModuleTree minfo =- let pkgRoot = take 2 (moduleName minfo)- typesModule = pkgRoot ++ ["Types"]- in dotModuleName typesModule : listModules minfo+ let submoduleNames = concatMap listModuleTree (M.elems (submodules minfo))+ in dotModuleName (moduleName minfo) : submoduleNames
lib/Data/GI/CodeGen/CodeGen.hs view
@@ -12,6 +12,7 @@ import Data.List (nub) import Data.Tuple (swap) import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe)+import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text)@@ -21,6 +22,7 @@ import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (genCallable)+import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.Constant (genConstant) import Data.GI.CodeGen.Code import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability)@@ -36,7 +38,8 @@ import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct, fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion, genWrappedPtr)-import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName)+import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName,+ submoduleLocation) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util (tshow) @@ -44,7 +47,7 @@ genFunction n (Function symbol throws fnMovedTo callable) = -- Only generate the function if it has not been moved. when (Nothing == fnMovedTo) $- submodule "Functions" $ group $ do+ group $ do line $ "-- function " <> symbol handleCGExc (\e -> line ("-- XXX Could not generate function " <> symbol@@ -53,7 +56,7 @@ genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do- name' <- upperName n+ let name' = upperName n group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>@@ -75,15 +78,16 @@ when (storageBytes /= 4) $ notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes - name' <- upperName n+ let name' = upperName n fields' <- forM fields $ \(fieldName, value) -> do- n <- upperName $ Name ns (name <> "_" <> fieldName)+ let n = upperName $ Name ns (name <> "_" <> fieldName) return (n, value) line $ deprecatedPragma name' isDeprecated group $ do exportDecl (name' <> "(..)")+ hsBoot . line $ "data " <> name' line $ "data " <> name' <> " = " indent $ case fields' of@@ -95,7 +99,7 @@ _ -> return () group $ do- line $ "instance P.Enum " <> name' <> " where"+ bline $ "instance P.Enum " <> name' <> " where" indent $ do forM_ fields' $ \(n, v) -> line $ "fromEnum " <> n <> " = " <> tshow v@@ -115,23 +119,20 @@ genBoxedEnum :: Name -> Text -> CodeGen () genBoxedEnum n typeInit = do- name' <- upperName n+ let name' = upperName n group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do- line $ "instance BoxedEnum " <> name' <> " where"+ bline $ "instance BoxedEnum " <> name' <> " where" indent $ line $ "boxedEnumType _ = c_" <> typeInit genEnum :: Name -> Enumeration -> CodeGen ()-genEnum n@(Name _ name) enum = submodule "Enums" $ do+genEnum n@(Name _ name) enum = do line $ "-- Enum " <> name - -- Reexported as-is by GI.Pkg.Types- setModuleFlags [Reexport, NoTypesImport, NoCallbacksImport]- handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e) (do genEnumOrFlags n enum case enumTypeInit enum of@@ -140,25 +141,22 @@ genBoxedFlags :: Name -> Text -> CodeGen () genBoxedFlags n typeInit = do- name' <- upperName n+ let name' = upperName n group $ do line $ "foreign import ccall \"" <> typeInit <> "\" c_" <> typeInit <> " :: " indent $ line "IO GType" group $ do- line $ "instance BoxedFlags " <> name' <> " where"+ bline $ "instance BoxedFlags " <> name' <> " where" indent $ line $ "boxedFlagsType _ = c_" <> typeInit -- Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass. genFlags :: Name -> Flags -> CodeGen ()-genFlags n@(Name _ name) (Flags enum) = submodule "Flags" $ do+genFlags n@(Name _ name) (Flags enum) = do line $ "-- Flags " <> name - -- Reexported as-is by Data.GI.CodeGen.Pkg.Types- setModuleFlags [Reexport, NoTypesImport, NoCallbacksImport]- handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e) (do genEnumOrFlags n enum@@ -167,8 +165,8 @@ Nothing -> return () Just ti -> genBoxedFlags n ti - name' <- upperName n- group $ line $ "instance IsGFlag " <> name')+ let name' = upperName n+ group $ bline $ "instance IsGFlag " <> name') genErrorDomain :: Text -> Text -> CodeGen () genErrorDomain name' domain = do@@ -200,84 +198,86 @@ -- | Generate wrapper for structures. genStruct :: Name -> Struct -> CodeGen () genStruct n s = unless (ignoreStruct n s) $ do- name' <- upperName n+ let name' = upperName n - submodule "Structs" $ submodule name' $ do- let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- hsBoot decl- decl+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ hsBoot decl+ decl - addModuleDocumentation (structDocumentation s)+ addModuleDocumentation (structDocumentation s) - if structIsBoxed s- then genBoxedObject n (fromJust $ structTypeInit s)- else genWrappedPtr n (structAllocationInfo s) (structSize s)+ if structIsBoxed s+ then genBoxedObject n (fromJust $ structTypeInit s)+ else genWrappedPtr n (structAllocationInfo s) (structSize s) - exportDecl (name' <> ("(..)"))+ exportDecl (name' <> ("(..)")) - -- Generate a builder for a structure filled with zeroes.- genZeroStruct n s+ -- Generate a builder for a structure filled with zeroes.+ genZeroStruct n s - noName name'+ noName name' - -- Generate code for fields.- genStructOrUnionFields n (structFields s)+ -- Generate code for fields.+ genStructOrUnionFields n (structFields s) - -- Methods- 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) >>- return Nothing)- (genMethod n f >> return (Just (n, f)))- else return Nothing+ -- Methods+ 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) >>+ return Nothing)+ (genMethod n f >> return (Just (n, f)))+ else return Nothing - -- Overloaded methods- genMethodList n (catMaybes methods)+ -- Overloaded methods+ cfg <- config+ when (cgOverloadedMethods (cgFlags cfg)) $+ genMethodList n (catMaybes methods) -- | Generated wrapper for unions. genUnion :: Name -> Union -> CodeGen () genUnion n u = do- name' <- upperName n+ let name' = upperName n - submodule "Unions" $ submodule name' $ do- let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- hsBoot decl- decl+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ hsBoot decl+ decl - if unionIsBoxed u- then genBoxedObject n (fromJust $ unionTypeInit u)- else genWrappedPtr n (unionAllocationInfo u) (unionSize u)+ if unionIsBoxed u+ then genBoxedObject n (fromJust $ unionTypeInit u)+ else genWrappedPtr n (unionAllocationInfo u) (unionSize u) - exportDecl (name' <> "(..)")+ exportDecl (name' <> "(..)") - -- Generate a builder for a structure filled with zeroes.- genZeroUnion n u+ -- Generate a builder for a structure filled with zeroes.+ genZeroUnion n u - noName name'+ noName name' - -- Generate code for fields.- genStructOrUnionFields n (unionFields u)+ -- Generate code for fields.+ genStructOrUnionFields n (unionFields u) - -- Methods- 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)- >> return Nothing)- (genMethod n f >> return (Just (n, f)))- else return Nothing+ -- Methods+ 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)+ >> return Nothing)+ (genMethod n f >> return (Just (n, f)))+ else return Nothing - -- Overloaded methods- genMethodList n (catMaybes methods)+ -- Overloaded methods+ cfg <- config+ when (cgOverloadedMethods (cgFlags cfg)) $+ genMethodList n (catMaybes methods) -- Add the implicit object argument to methods of an object. Since we -- are prepending an argument we need to adjust the offset of the@@ -340,7 +340,7 @@ methodType = t, methodThrows = throws }) = do- name' <- upperName cn+ let name' = upperName cn returnsGObject <- maybe (return False) isGObject (returnType c) line $ "-- method " <> name' <> "::" <> name mn line $ "-- method type : " <> tshow t@@ -354,36 +354,38 @@ else c' genCallable mn' sym c'' throws - genMethodInfo cn (m {methodCallable = c''})+ cfg <- config+ when (cgOverloadedMethods (cgFlags cfg)) $+ genMethodInfo cn (m {methodCallable = c''}) -- Type casting with type checking genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen () genGObjectCasts isIU n cn_ parents = do- name' <- upperName n- qualifiedParents <- traverse upperName parents+ let name' = upperName n group $ do line $ "foreign import ccall \"" <> cn_ <> "\"" indent $ line $ "c_" <> cn_ <> " :: IO GType" group $ do- let parentObjectsType = name' <> "ParentTypes"- line $ "type instance ParentTypes " <> name' <> " = " <> parentObjectsType- line $ "type " <> parentObjectsType <> " = '[" <>- T.intercalate ", " qualifiedParents <> "]"-- group $ do bline $ "instance GObject " <> name' <> " where" indent $ group $ do line $ "gobjectIsInitiallyUnowned _ = " <> tshow isIU line $ "gobjectType _ = c_" <> cn_ - let className = classConstraint name'+ className <- classConstraint n group $ do exportDecl className bline $ "class GObject o => " <> className <> " o"- bline $ "instance (GObject o, IsDescendantOf " <> name' <> " o) => "- <> className <> " o"+ line $ "#if MIN_VERSION_base(4,9,0)"+ line $ "instance {-# OVERLAPPABLE #-} (GObject a, O.UnknownAncestorError "+ <> name' <> " a) =>"+ line $ " " <> className <> " a"+ line $ "#endif"+ line $ "instance " <> className <> " " <> name'+ forM_ parents $ \parent -> do+ pcls <- classConstraint parent+ line $ "instance " <> pcls <> " " <> name' -- Safe downcasting. group $ do@@ -397,101 +399,106 @@ -- of objects, we deal with these separately. genObject :: Name -> Object -> CodeGen () genObject n o = do- name' <- upperName n+ let name' = upperName n let t = (\(Name ns' n') -> TInterface ns' n') n isGO <- isGObject t if not isGO then line $ "-- APIObject \"" <> name' <> "\" does not descend from GObject, it will be ignored."- else submodule "Objects" $ submodule name' $- do- bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- exportDecl (name' <> "(..)")+ else do+ bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ exportDecl (name' <> "(..)") - -- Type safe casting to parent objects, and implemented interfaces.- isIU <- isInitiallyUnowned t- parents <- instanceTree n- genGObjectCasts isIU n (objTypeInit o) (parents <> objInterfaces o)+ -- Type safe casting to parent objects, and implemented interfaces.+ isIU <- isInitiallyUnowned t+ parents <- instanceTree n+ genGObjectCasts isIU n (objTypeInit o) (parents <> objInterfaces o) - noName name'+ noName name' + cfg <- config+ when (cgOverloadedMethods (cgFlags cfg)) $ fullObjectMethodList n o >>= genMethodList n - forM_ (objSignals o) $ \s ->- handleCGExc- (line . (T.concat ["-- XXX Could not generate signal ", name', "::"- , sigName s- , "\n", "-- Error was : "] <>) . describeCGError)- (genSignal s n)+ forM_ (objSignals o) $ \s ->+ handleCGExc+ (line . (T.concat ["-- XXX Could not generate signal ", name', "::"+ , sigName s+ , "\n", "-- Error was : "] <>) . describeCGError)+ (genSignal s n) - genObjectProperties n o+ genObjectProperties n o+ when (cgOverloadedProperties (cgFlags cfg)) $ genNamespacedPropLabels n (objProperties o) (objMethods o)+ when (cgOverloadedSignals (cgFlags cfg)) $ genObjectSignals n o - -- Methods- 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)+ -- Methods+ 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)+ >> (when (cgOverloadedMethods (cgFlags cfg)) $+ genUnsupportedMethodInfo n f))+ (genMethod n f) genInterface :: Name -> Interface -> CodeGen () genInterface n iface = do- name' <- upperName n+ let name' = upperName n - submodule "Interfaces" $ submodule name' $ do- line $ "-- interface " <> name' <> " "- line $ deprecatedPragma name' $ ifDeprecated iface- bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- exportDecl (name' <> "(..)")+ line $ "-- interface " <> name' <> " "+ line $ deprecatedPragma name' $ ifDeprecated iface+ bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ exportDecl (name' <> "(..)") - noName name'+ noName name' - fullInterfaceMethodList n iface >>= genMethodList n+ cfg <- config+ when (cgOverloadedMethods (cgFlags cfg)) $+ fullInterfaceMethodList n iface >>= genMethodList n - forM_ (ifSignals iface) $ \s -> handleCGExc- (line . (T.concat ["-- XXX Could not generate signal ", name', "::"- , sigName s- , "\n", "-- Error was : "] <>) . describeCGError)- (genSignal s n)+ forM_ (ifSignals iface) $ \s -> handleCGExc+ (line . (T.concat ["-- XXX Could not generate signal ", name', "::"+ , sigName s+ , "\n", "-- Error was : "] <>) . describeCGError)+ (genSignal s n) - genInterfaceProperties n iface- genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)- genInterfaceSignals n iface+ genInterfaceProperties n iface+ when (cgOverloadedProperties (cgFlags cfg)) $+ genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)+ when (cgOverloadedSignals (cgFlags cfg)) $+ genInterfaceSignals n iface - isGO <- apiIsGObject n (APIInterface iface)- if isGO- then do- let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)- isIU <- apiIsInitiallyUnowned n (APIInterface iface)- gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)- allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p- let uniqueParents = nub (concat allParents)- genGObjectCasts isIU n cn_ uniqueParents+ isGO <- apiIsGObject n (APIInterface iface)+ if isGO+ then do+ let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)+ isIU <- apiIsInitiallyUnowned n (APIInterface iface)+ gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)+ allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p+ let uniqueParents = nub (concat allParents)+ genGObjectCasts isIU n cn_ uniqueParents - else group $ do- let cls = classConstraint name'- exportDecl cls- bline $ "class ForeignPtrNewtype a => " <> cls <> " a"- bline $ "instance (ForeignPtrNewtype o, IsDescendantOf " <> name' <> " o) => " <> cls <> " o"- let parentObjectsType = name' <> "ParentTypes"- line $ "type instance ParentTypes " <> name' <> " = " <> parentObjectsType- line $ "type " <> parentObjectsType <> " = '[]"+ else group $ do+ cls <- classConstraint n+ exportDecl cls+ bline $ "class ForeignPtrNewtype a => " <> cls <> " a"+ line $ "instance " <> cls <> " " <> name' - -- Methods- 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)- >> genUnsupportedMethodInfo n f)- (genMethod n f)+ -- Methods+ 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)+ >> (when (cgOverloadedMethods (cgFlags cfg)) $+ 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@@ -520,9 +527,13 @@ genAPI n (APIObject o) = genObject n o genAPI n (APIInterface i) = genInterface n i +-- | Generate the code for a given API in the corresponding module.+genAPIModule :: Name -> API -> CodeGen ()+genAPIModule n api = submodule (submoduleLocation n api) $ genAPI n api+ genModule' :: M.Map Name API -> CodeGen () genModule' apis = do- mapM_ (uncurry genAPI)+ mapM_ (uncurry genAPIModule) -- We provide these ourselves $ filter ((`notElem` [ Name "GLib" "Array" , Name "GLib" "Error"@@ -543,7 +554,7 @@ -- Make sure we generate a "Callbacks" module, since it is imported -- by other modules. It is fine if it ends up empty.- submodule "Callbacks" $ return ()+ submodule ["Callbacks"] (return ()) genModule :: M.Map Name API -> CodeGen () genModule apis = do
lib/Data/GI/CodeGen/Config.hs view
@@ -1,15 +1,29 @@+-- | Configuration for the code generator. module Data.GI.CodeGen.Config ( Config(..)+ , CodeGenFlags(..) ) where import Data.Text (Text) import Data.GI.CodeGen.Overrides (Overrides) +-- | Flags controlling different aspects of the code generator.+data CodeGenFlags = CodeGenFlags {+ -- | Whether to generate overloaded properties.+ cgOverloadedProperties :: Bool+ -- | Whether to generate support for overloaded signals.+ , cgOverloadedSignals :: Bool+ -- | Whether to generate support for overloaded methods.+ , cgOverloadedMethods :: Bool+ } deriving Show+ data Config = Config { -- | Name of the module being generated. modName :: Maybe Text, -- | Whether to print extra info. verbose :: Bool, -- | List of loaded overrides for the code generator.- overrides :: Overrides- }+ overrides :: Overrides,+ -- | List of flags for the code generator.+ cgFlags :: CodeGenFlags+ } deriving Show
lib/Data/GI/CodeGen/Constant.hs view
@@ -6,6 +6,7 @@ import Control.Applicative ((<$>)) #endif +import Data.Monoid ((<>)) import Data.Text (Text) import Data.GI.CodeGen.API@@ -41,7 +42,7 @@ genConstant :: Name -> Constant -> CodeGen () genConstant (Name _ name) (Constant t value deprecated) =- submodule "Constants" $ group $ do+ group $ do setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables", "ViewPatterns"] line $ deprecatedPragma name deprecated
lib/Data/GI/CodeGen/Conversions.hs view
@@ -33,10 +33,11 @@ import Control.Applicative ((<$>), (<*>), pure, Applicative) #endif import Control.Monad (when)-import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)+import Data.Monoid ((<>)) import Data.Int import Data.Text (Text) import qualified Data.Text as T+import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf) import Data.Word import GHC.Exts (IsString(..)) @@ -589,21 +590,22 @@ argumentType letters (TGSList a) = do (ls, name, constraints) <- argumentType letters a return (ls, "[" <> name <> "]", constraints)-argumentType letters@(l:ls) t = do+argumentType letters@(l:ls) t = do api <- findAPI t s <- tshow <$> haskellType t case api of- Just (APIInterface _) -> do- let constraints = [classConstraint s <> " " <> T.singleton l]- return (ls, T.singleton l, constraints) -- Instead of restricting to the actual class, -- we allow for any object descending from it.+ Just (APIInterface _) -> do+ cls <- typeConstraint t+ return (ls, T.singleton l, [cls <> " " <> T.singleton l]) Just (APIObject _) -> do- isGO <- isGObject t- if isGO- then return (ls, T.singleton l,- [classConstraint s <> " " <> T.singleton l])- else return (letters, s, [])+ isGO <- isGObject t+ if isGO+ then do+ cls <- typeConstraint t+ return (ls, T.singleton l, [cls <> " " <> T.singleton l])+ else return (letters, s, []) _ -> return (letters, s, []) haskellBasicType TPtr = ptr $ typeOf ()@@ -673,12 +675,11 @@ haskellType (TInterface "GObject" "Value") = return $ "GValue" `con` [] haskellType (TInterface "GObject" "Closure") = return $ "Closure" `con` [] haskellType t@(TInterface ns n) = do- prefix <- qualify ns- api <- findAPI t- let tname = (prefix <> n) `con` []+ api <- getAPI t+ tname <- qualifiedAPI (Name ns n) return $ case api of- Just (APIFlags _) -> "[]" `con` [tname]- _ -> tname+ (APIFlags _) -> "[]" `con` [tname `con` []]+ _ -> tname `con` [] foreignBasicType TBoolean = "CInt" `con` [] foreignBasicType TUTF8 = "CString" `con` []@@ -731,12 +732,14 @@ if isScalar then return $ "CUInt" `con` [] else do- api <- findAPI t- prefix <- qualify ns- return $ case api of- Just (APICallback _) ->- funptr $ (prefix <> n <> "C") `con` []- _ -> ptr $ (prefix <> n) `con` []+ api <- getAPI t+ case api of+ APICallback _ -> do+ tname <- qualifiedSymbol (n <> "C") (Name ns n)+ return (funptr $ tname `con` [])+ _ -> do+ tname <- qualifiedAPI (Name ns n)+ return (ptr $ tname `con` []) getIsScalar :: Type -> CodeGen Bool getIsScalar t = do
lib/Data/GI/CodeGen/Inheritance.hs view
@@ -14,10 +14,11 @@ #endif import Control.Monad (foldM, when) import qualified Data.Map as M+import Data.Monoid ((<>)) import Data.Text (Text) import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line, (<>))+import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line) import Data.GI.CodeGen.Util (tshow) -- | Find the parent of a given object when building the
lib/Data/GI/CodeGen/OverloadedLabels.hs view
@@ -6,6 +6,7 @@ import Control.Applicative ((<$>)) #endif import Data.Maybe (isNothing)+import Data.Monoid ((<>)) import Control.Monad (forM_) import qualified Data.Set as S import Data.Text (Text)@@ -82,7 +83,7 @@ genOverloadedLabels :: [(Name, API)] -> CodeGen () genOverloadedLabels allAPIs = do setLanguagePragmas ["DataKinds", "FlexibleContexts"]- setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]+ setModuleFlags [ImplicitPrelude] line $ "import Data.Proxy (Proxy(..))" line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))"
lib/Data/GI/CodeGen/OverloadedMethods.hs view
@@ -5,43 +5,44 @@ ) where import Control.Monad (forM, forM_, when)+import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Callable (callableSignature, fixupCallerAllocates) import Data.GI.CodeGen.Code-import Data.GI.CodeGen.SymbolNaming (lowerName, upperName)+import Data.GI.CodeGen.SymbolNaming (lowerName, upperName, qualifiedSymbol) import Data.GI.CodeGen.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"+methodInfoName n method =+ let infoName = upperName n <> (ucFirst . lowerName . methodName) method+ <> "MethodInfo"+ in qualifiedSymbol infoName n -- | 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 ("+ <> "O.MethodInfo info " <> n <> " p) => O.IsLabelProxy t (" <> n <> " -> p) where"- indent $ line $ "fromLabelProxy _ = overloadedMethod (MethodProxy :: MethodProxy info)"+ indent $ line $ "fromLabelProxy _ = O.overloadedMethod (O.MethodProxy :: O.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 ("+ <> "O.MethodInfo info " <> n <> " p) => O.IsLabel t (" <> n <> " -> p) where"- indent $ line $ "fromLabel _ = overloadedMethod (MethodProxy :: MethodProxy info)"+ indent $ line $ "fromLabel _ = O.overloadedMethod (O.MethodProxy :: O.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 name = upperName n let filteredMethods = filter isOrdinaryMethod methods gets = filter isGet filteredMethods sets = filter isSet filteredMethods@@ -55,7 +56,7 @@ 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"+ indent $ line $ resolver <> " l o = O.MethodResolutionFailed l o" genMethodResolver name @@ -85,7 +86,7 @@ sigConstraint = "signature ~ (" <> T.intercalate " -> " otherTypes <> ")" line $ "instance (" <> T.intercalate ", " (sigConstraint : constraints)- <> ") => MethodInfo " <> infoName <> " " <> obj <> " signature where"+ <> ") => O.MethodInfo " <> infoName <> " " <> obj <> " signature where" let mn = methodName m mangled = lowerName (mn {name = name n <> "_" <> name mn}) indent $ line $ "overloadedMethod _ = " <> mangled@@ -99,8 +100,8 @@ 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 \""+ line $ "instance (p ~ (), o ~ O.MethodResolutionFailed \"" <> lowerName (methodName m) <> "\" " <> name n- <> ") => MethodInfo " <> infoName <> " o p where"+ <> ") => O.MethodInfo " <> infoName <> " o p where" indent $ line $ "overloadedMethod _ = undefined" exportMethod "Unsupported methods" infoName
lib/Data/GI/CodeGen/OverloadedSignals.hs view
@@ -8,9 +8,10 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when)++import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T- import qualified Data.Set as S import Data.GI.CodeGen.API@@ -18,7 +19,8 @@ import Data.GI.CodeGen.Inheritance (fullObjectSignalList, fullInterfaceSignalList) import Data.GI.CodeGen.GObject (apiIsGObject) import Data.GI.CodeGen.Signal (signalHaskellName)-import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase)+import Data.GI.CodeGen.SymbolNaming (upperName, hyphensToCamelCase,+ qualifiedSymbol) import Data.GI.CodeGen.Util (lcFirst, ucFirst) -- A list of distinct signal names for all GObjects appearing in the@@ -45,7 +47,7 @@ setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP", -- For ghc 7.8 support "RankNTypes", "ScopedTypeVariables", "TypeFamilies"]- setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]+ setModuleFlags [ImplicitPrelude] line "import Data.GI.Base.Signals (SignalProxy(..))" line "import Data.GI.Base.Overloading (ResolveSignal)"@@ -68,14 +70,14 @@ -- | Qualified name for the "(sigName, info)" tag for a given signal. signalInfoName :: Name -> Signal -> CodeGen Text signalInfoName n signal = do- n' <- upperName n- return $ n' <> (ucFirst . signalHaskellName . sigName) signal- <> "SignalInfo"+ let infoName = upperName n <> (ucFirst . signalHaskellName . sigName) signal+ <> "SignalInfo"+ qualifiedSymbol infoName n -- | Generate the given signal instance for the given API object. genInstance :: Name -> Signal -> CodeGen () genInstance owner signal = group $ do- name <- upperName owner+ let name = upperName owner let sn = (ucFirst . signalHaskellName . sigName) signal si <- signalInfoName owner signal bline $ "data " <> si@@ -90,7 +92,7 @@ -- | Signal instances for (GObject-derived) objects. genObjectSignals :: Name -> Object -> CodeGen () genObjectSignals n o = do- name <- upperName n+ let name = upperName n isGO <- apiIsGObject n (APIObject o) when isGO $ do mapM_ (genInstance n) (objSignals o)@@ -101,14 +103,14 @@ <> "\", " <> si <> ")") group $ do let signalListType = name <> "SignalList"- line $ "type instance SignalList " <> name <> " = " <> signalListType+ line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " <> T.intercalate ", " infos <> "] :: [(Symbol, *)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen () genInterfaceSignals n iface = do- name <- upperName n+ let name = upperName n mapM_ (genInstance n) (ifSignals iface) infos <- fullInterfaceSignalList n iface >>= mapM (\(owner, signal) -> do@@ -117,6 +119,6 @@ <> "\", " <> si <> ")") group $ do let signalListType = name <> "SignalList"- line $ "type instance SignalList " <> name <> " = " <> signalListType+ line $ "type instance O.SignalList " <> name <> " = " <> signalListType line $ "type " <> signalListType <> " = ('[ " <> T.intercalate ", " infos <> "] :: [(Symbol, *)])"
lib/Data/GI/CodeGen/PkgConfig.hs view
@@ -1,5 +1,6 @@ module Data.GI.CodeGen.PkgConfig ( pkgConfigGetVersion+ , tryPkgConfig ) where import Control.Monad (when)@@ -13,7 +14,8 @@ import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) --- | Try asking pkg-config for the version of a given module.+-- | Try asking pkg-config for the version of a given module, and+-- return the package name together with its version. tryPkgConfig :: Text -> IO (Maybe (Text, Text)) tryPkgConfig pkgName = do (exitcode, stdout, _) <-
lib/Data/GI/CodeGen/ProjectInfo.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} -- | Project information to include in generated bindings, should be -- kept in sync with haskell-gi.cabal module Data.GI.CodeGen.ProjectInfo@@ -15,8 +14,8 @@ , standardDeps ) where -import Data.FileEmbed (embedStringFile) import Data.Text (Text)+import qualified Data.Text as T (unlines) homepage :: Text homepage = "https://github.com/haskell-gi/haskell-gi"@@ -30,9 +29,6 @@ license :: Text license = "LGPL-2.1" -licenseText :: Text-licenseText = $(embedStringFile "LICENSE")- -- | Default list of extensions to turn on when compiling the -- generated code. defaultExtensions :: [Text]@@ -69,3 +65,462 @@ -- | Under which category in hackage should the generated bindings be listed. category :: Text category = "Bindings"++licenseText :: Text+licenseText = T.unlines+ [" GNU LESSER GENERAL PUBLIC LICENSE"+ ," Version 2.1, February 1999"+ ,""+ ," Copyright (C) 1991, 1999 Free Software Foundation, Inc."+ ," 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA"+ ," Everyone is permitted to copy and distribute verbatim copies"+ ," of this license document, but changing it is not allowed."+ ,""+ ,"[This is the first released version of the Lesser GPL. It also counts"+ ," as the successor of the GNU Library Public License, version 2, hence"+ ," the version number 2.1.]"+ ,""+ ," Preamble"+ ,""+ ," The licenses for most software are designed to take away your"+ ,"freedom to share and change it. By contrast, the GNU General Public"+ ,"Licenses are intended to guarantee your freedom to share and change"+ ,"free software--to make sure the software is free for all its users."+ ,""+ ," This license, the Lesser General Public License, applies to some"+ ,"specially designated software packages--typically libraries--of the"+ ,"Free Software Foundation and other authors who decide to use it. You"+ ,"can use it too, but we suggest you first think carefully about whether"+ ,"this license or the ordinary General Public License is the better"+ ,"strategy to use in any particular case, based on the explanations below."+ ,""+ ," When we speak of free software, we are referring to freedom of use,"+ ,"not price. Our General Public Licenses are designed to make sure that"+ ,"you have the freedom to distribute copies of free software (and charge"+ ,"for this service if you wish); that you receive source code or can get"+ ,"it if you want it; that you can change the software and use pieces of"+ ,"it in new free programs; and that you are informed that you can do"+ ,"these things."+ ,""+ ," To protect your rights, we need to make restrictions that forbid"+ ,"distributors to deny you these rights or to ask you to surrender these"+ ,"rights. These restrictions translate to certain responsibilities for"+ ,"you if you distribute copies of the library or if you modify it."+ ,""+ ," For example, if you distribute copies of the library, whether gratis"+ ,"or for a fee, you must give the recipients all the rights that we gave"+ ,"you. You must make sure that they, too, receive or can get the source"+ ,"code. If you link other code with the library, you must provide"+ ,"complete object files to the recipients, so that they can relink them"+ ,"with the library after making changes to the library and recompiling"+ ,"it. And you must show them these terms so they know their rights."+ ,""+ ," We protect your rights with a two-step method: (1) we copyright the"+ ,"library, and (2) we offer you this license, which gives you legal"+ ,"permission to copy, distribute and/or modify the library."+ ,""+ ," To protect each distributor, we want to make it very clear that"+ ,"there is no warranty for the free library. Also, if the library is"+ ,"modified by someone else and passed on, the recipients should know"+ ,"that what they have is not the original version, so that the original"+ ,"author's reputation will not be affected by problems that might be"+ ,"introduced by others."+ ,"\f"+ ," Finally, software patents pose a constant threat to the existence of"+ ,"any free program. We wish to make sure that a company cannot"+ ,"effectively restrict the users of a free program by obtaining a"+ ,"restrictive license from a patent holder. Therefore, we insist that"+ ,"any patent license obtained for a version of the library must be"+ ,"consistent with the full freedom of use specified in this license."+ ,""+ ," Most GNU software, including some libraries, is covered by the"+ ,"ordinary GNU General Public License. This license, the GNU Lesser"+ ,"General Public License, applies to certain designated libraries, and"+ ,"is quite different from the ordinary General Public License. We use"+ ,"this license for certain libraries in order to permit linking those"+ ,"libraries into non-free programs."+ ,""+ ," When a program is linked with a library, whether statically or using"+ ,"a shared library, the combination of the two is legally speaking a"+ ,"combined work, a derivative of the original library. The ordinary"+ ,"General Public License therefore permits such linking only if the"+ ,"entire combination fits its criteria of freedom. The Lesser General"+ ,"Public License permits more lax criteria for linking other code with"+ ,"the library."+ ,""+ ," We call this license the \"Lesser\" General Public License because it"+ ,"does Less to protect the user's freedom than the ordinary General"+ ,"Public License. It also provides other free software developers Less"+ ,"of an advantage over competing non-free programs. These disadvantages"+ ,"are the reason we use the ordinary General Public License for many"+ ,"libraries. However, the Lesser license provides advantages in certain"+ ,"special circumstances."+ ,""+ ," For example, on rare occasions, there may be a special need to"+ ,"encourage the widest possible use of a certain library, so that it becomes"+ ,"a de-facto standard. To achieve this, non-free programs must be"+ ,"allowed to use the library. A more frequent case is that a free"+ ,"library does the same job as widely used non-free libraries. In this"+ ,"case, there is little to gain by limiting the free library to free"+ ,"software only, so we use the Lesser General Public License."+ ,""+ ," In other cases, permission to use a particular library in non-free"+ ,"programs enables a greater number of people to use a large body of"+ ,"free software. For example, permission to use the GNU C Library in"+ ,"non-free programs enables many more people to use the whole GNU"+ ,"operating system, as well as its variant, the GNU/Linux operating"+ ,"system."+ ,""+ ," Although the Lesser General Public License is Less protective of the"+ ,"users' freedom, it does ensure that the user of a program that is"+ ,"linked with the Library has the freedom and the wherewithal to run"+ ,"that program using a modified version of the Library."+ ,""+ ," The precise terms and conditions for copying, distribution and"+ ,"modification follow. Pay close attention to the difference between a"+ ,"\"work based on the library\" and a \"work that uses the library\". The"+ ,"former contains code derived from the library, whereas the latter must"+ ,"be combined with the library in order to run."+ ,"\f"+ ," GNU LESSER GENERAL PUBLIC LICENSE"+ ," TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+ ,""+ ," 0. This License Agreement applies to any software library or other"+ ,"program which contains a notice placed by the copyright holder or"+ ,"other authorized party saying it may be distributed under the terms of"+ ,"this Lesser General Public License (also called \"this License\")."+ ,"Each licensee is addressed as \"you\"."+ ,""+ ," A \"library\" means a collection of software functions and/or data"+ ,"prepared so as to be conveniently linked with application programs"+ ,"(which use some of those functions and data) to form executables."+ ,""+ ," The \"Library\", below, refers to any such software library or work"+ ,"which has been distributed under these terms. A \"work based on the"+ ,"Library\" means either the Library or any derivative work under"+ ,"copyright law: that is to say, a work containing the Library or a"+ ,"portion of it, either verbatim or with modifications and/or translated"+ ,"straightforwardly into another language. (Hereinafter, translation is"+ ,"included without limitation in the term \"modification\".)"+ ,""+ ," \"Source code\" for a work means the preferred form of the work for"+ ,"making modifications to it. For a library, complete source code means"+ ,"all the source code for all modules it contains, plus any associated"+ ,"interface definition files, plus the scripts used to control compilation"+ ,"and installation of the library."+ ,""+ ," Activities other than copying, distribution and modification are not"+ ,"covered by this License; they are outside its scope. The act of"+ ,"running a program using the Library is not restricted, and output from"+ ,"such a program is covered only if its contents constitute a work based"+ ,"on the Library (independent of the use of the Library in a tool for"+ ,"writing it). Whether that is true depends on what the Library does"+ ,"and what the program that uses the Library does."+ ,""+ ," 1. You may copy and distribute verbatim copies of the Library's"+ ,"complete source code as you receive it, in any medium, provided that"+ ,"you conspicuously and appropriately publish on each copy an"+ ,"appropriate copyright notice and disclaimer of warranty; keep intact"+ ,"all the notices that refer to this License and to the absence of any"+ ,"warranty; and distribute a copy of this License along with the"+ ,"Library."+ ,""+ ," You may charge a fee for the physical act of transferring a copy,"+ ,"and you may at your option offer warranty protection in exchange for a"+ ,"fee."+ ,"\f"+ ," 2. You may modify your copy or copies of the Library or any portion"+ ,"of it, thus forming a work based on the Library, and copy and"+ ,"distribute such modifications or work under the terms of Section 1"+ ,"above, provided that you also meet all of these conditions:"+ ,""+ ," a) The modified work must itself be a software library."+ ,""+ ," b) You must cause the files modified to carry prominent notices"+ ," stating that you changed the files and the date of any change."+ ,""+ ," c) You must cause the whole of the work to be licensed at no"+ ," charge to all third parties under the terms of this License."+ ,""+ ," d) If a facility in the modified Library refers to a function or a"+ ," table of data to be supplied by an application program that uses"+ ," the facility, other than as an argument passed when the facility"+ ," is invoked, then you must make a good faith effort to ensure that,"+ ," in the event an application does not supply such function or"+ ," table, the facility still operates, and performs whatever part of"+ ," its purpose remains meaningful."+ ,""+ ," (For example, a function in a library to compute square roots has"+ ," a purpose that is entirely well-defined independent of the"+ ," application. Therefore, Subsection 2d requires that any"+ ," application-supplied function or table used by this function must"+ ," be optional: if the application does not supply it, the square"+ ," root function must still compute square roots.)"+ ,""+ ,"These requirements apply to the modified work as a whole. If"+ ,"identifiable sections of that work are not derived from the Library,"+ ,"and can be reasonably considered independent and separate works in"+ ,"themselves, then this License, and its terms, do not apply to those"+ ,"sections when you distribute them as separate works. But when you"+ ,"distribute the same sections as part of a whole which is a work based"+ ,"on the Library, the distribution of the whole must be on the terms of"+ ,"this License, whose permissions for other licensees extend to the"+ ,"entire whole, and thus to each and every part regardless of who wrote"+ ,"it."+ ,""+ ,"Thus, it is not the intent of this section to claim rights or contest"+ ,"your rights to work written entirely by you; rather, the intent is to"+ ,"exercise the right to control the distribution of derivative or"+ ,"collective works based on the Library."+ ,""+ ,"In addition, mere aggregation of another work not based on the Library"+ ,"with the Library (or with a work based on the Library) on a volume of"+ ,"a storage or distribution medium does not bring the other work under"+ ,"the scope of this License."+ ,""+ ," 3. You may opt to apply the terms of the ordinary GNU General Public"+ ,"License instead of this License to a given copy of the Library. To do"+ ,"this, you must alter all the notices that refer to this License, so"+ ,"that they refer to the ordinary GNU General Public License, version 2,"+ ,"instead of to this License. (If a newer version than version 2 of the"+ ,"ordinary GNU General Public License has appeared, then you can specify"+ ,"that version instead if you wish.) Do not make any other change in"+ ,"these notices."+ ,"\f"+ ," Once this change is made in a given copy, it is irreversible for"+ ,"that copy, so the ordinary GNU General Public License applies to all"+ ,"subsequent copies and derivative works made from that copy."+ ,""+ ," This option is useful when you wish to copy part of the code of"+ ,"the Library into a program that is not a library."+ ,""+ ," 4. You may copy and distribute the Library (or a portion or"+ ,"derivative of it, under Section 2) in object code or executable form"+ ,"under the terms of Sections 1 and 2 above provided that you accompany"+ ,"it with the complete corresponding machine-readable source code, which"+ ,"must be distributed under the terms of Sections 1 and 2 above on a"+ ,"medium customarily used for software interchange."+ ,""+ ," If distribution of object code is made by offering access to copy"+ ,"from a designated place, then offering equivalent access to copy the"+ ,"source code from the same place satisfies the requirement to"+ ,"distribute the source code, even though third parties are not"+ ,"compelled to copy the source along with the object code."+ ,""+ ," 5. A program that contains no derivative of any portion of the"+ ,"Library, but is designed to work with the Library by being compiled or"+ ,"linked with it, is called a \"work that uses the Library\". Such a"+ ,"work, in isolation, is not a derivative work of the Library, and"+ ,"therefore falls outside the scope of this License."+ ,""+ ," However, linking a \"work that uses the Library\" with the Library"+ ,"creates an executable that is a derivative of the Library (because it"+ ,"contains portions of the Library), rather than a \"work that uses the"+ ,"library\". The executable is therefore covered by this License."+ ,"Section 6 states terms for distribution of such executables."+ ,""+ ," When a \"work that uses the Library\" uses material from a header file"+ ,"that is part of the Library, the object code for the work may be a"+ ,"derivative work of the Library even though the source code is not."+ ,"Whether this is true is especially significant if the work can be"+ ,"linked without the Library, or if the work is itself a library. The"+ ,"threshold for this to be true is not precisely defined by law."+ ,""+ ," If such an object file uses only numerical parameters, data"+ ,"structure layouts and accessors, and small macros and small inline"+ ,"functions (ten lines or less in length), then the use of the object"+ ,"file is unrestricted, regardless of whether it is legally a derivative"+ ,"work. (Executables containing this object code plus portions of the"+ ,"Library will still fall under Section 6.)"+ ,""+ ," Otherwise, if the work is a derivative of the Library, you may"+ ,"distribute the object code for the work under the terms of Section 6."+ ,"Any executables containing that work also fall under Section 6,"+ ,"whether or not they are linked directly with the Library itself."+ ,"\f"+ ," 6. As an exception to the Sections above, you may also combine or"+ ,"link a \"work that uses the Library\" with the Library to produce a"+ ,"work containing portions of the Library, and distribute that work"+ ,"under terms of your choice, provided that the terms permit"+ ,"modification of the work for the customer's own use and reverse"+ ,"engineering for debugging such modifications."+ ,""+ ," You must give prominent notice with each copy of the work that the"+ ,"Library is used in it and that the Library and its use are covered by"+ ,"this License. You must supply a copy of this License. If the work"+ ,"during execution displays copyright notices, you must include the"+ ,"copyright notice for the Library among them, as well as a reference"+ ,"directing the user to the copy of this License. Also, you must do one"+ ,"of these things:"+ ,""+ ," a) Accompany the work with the complete corresponding"+ ," machine-readable source code for the Library including whatever"+ ," changes were used in the work (which must be distributed under"+ ," Sections 1 and 2 above); and, if the work is an executable linked"+ ," with the Library, with the complete machine-readable \"work that"+ ," uses the Library\", as object code and/or source code, so that the"+ ," user can modify the Library and then relink to produce a modified"+ ," executable containing the modified Library. (It is understood"+ ," that the user who changes the contents of definitions files in the"+ ," Library will not necessarily be able to recompile the application"+ ," to use the modified definitions.)"+ ,""+ ," b) Use a suitable shared library mechanism for linking with the"+ ," Library. A suitable mechanism is one that (1) uses at run time a"+ ," copy of the library already present on the user's computer system,"+ ," rather than copying library functions into the executable, and (2)"+ ," will operate properly with a modified version of the library, if"+ ," the user installs one, as long as the modified version is"+ ," interface-compatible with the version that the work was made with."+ ,""+ ," c) Accompany the work with a written offer, valid for at"+ ," least three years, to give the same user the materials"+ ," specified in Subsection 6a, above, for a charge no more"+ ," than the cost of performing this distribution."+ ,""+ ," d) If distribution of the work is made by offering access to copy"+ ," from a designated place, offer equivalent access to copy the above"+ ," specified materials from the same place."+ ,""+ ," e) Verify that the user has already received a copy of these"+ ," materials or that you have already sent this user a copy."+ ,""+ ," For an executable, the required form of the \"work that uses the"+ ,"Library\" must include any data and utility programs needed for"+ ,"reproducing the executable from it. However, as a special exception,"+ ,"the materials to be distributed need not include anything that is"+ ,"normally distributed (in either source or binary form) with the major"+ ,"components (compiler, kernel, and so on) of the operating system on"+ ,"which the executable runs, unless that component itself accompanies"+ ,"the executable."+ ,""+ ," It may happen that this requirement contradicts the license"+ ,"restrictions of other proprietary libraries that do not normally"+ ,"accompany the operating system. Such a contradiction means you cannot"+ ,"use both them and the Library together in an executable that you"+ ,"distribute."+ ,"\f"+ ," 7. You may place library facilities that are a work based on the"+ ,"Library side-by-side in a single library together with other library"+ ,"facilities not covered by this License, and distribute such a combined"+ ,"library, provided that the separate distribution of the work based on"+ ,"the Library and of the other library facilities is otherwise"+ ,"permitted, and provided that you do these two things:"+ ,""+ ," a) Accompany the combined library with a copy of the same work"+ ," based on the Library, uncombined with any other library"+ ," facilities. This must be distributed under the terms of the"+ ," Sections above."+ ,""+ ," b) Give prominent notice with the combined library of the fact"+ ," that part of it is a work based on the Library, and explaining"+ ," where to find the accompanying uncombined form of the same work."+ ,""+ ," 8. You may not copy, modify, sublicense, link with, or distribute"+ ,"the Library except as expressly provided under this License. Any"+ ,"attempt otherwise to copy, modify, sublicense, link with, or"+ ,"distribute the Library is void, and will automatically terminate your"+ ,"rights under this License. However, parties who have received copies,"+ ,"or rights, from you under this License will not have their licenses"+ ,"terminated so long as such parties remain in full compliance."+ ,""+ ," 9. You are not required to accept this License, since you have not"+ ,"signed it. However, nothing else grants you permission to modify or"+ ,"distribute the Library or its derivative works. These actions are"+ ,"prohibited by law if you do not accept this License. Therefore, by"+ ,"modifying or distributing the Library (or any work based on the"+ ,"Library), you indicate your acceptance of this License to do so, and"+ ,"all its terms and conditions for copying, distributing or modifying"+ ,"the Library or works based on it."+ ,""+ ," 10. Each time you redistribute the Library (or any work based on the"+ ,"Library), the recipient automatically receives a license from the"+ ,"original licensor to copy, distribute, link with or modify the Library"+ ,"subject to these terms and conditions. You may not impose any further"+ ,"restrictions on the recipients' exercise of the rights granted herein."+ ,"You are not responsible for enforcing compliance by third parties with"+ ,"this License."+ ,"\f"+ ," 11. If, as a consequence of a court judgment or allegation of patent"+ ,"infringement or for any other reason (not limited to patent issues),"+ ,"conditions are imposed on you (whether by court order, agreement or"+ ,"otherwise) that contradict the conditions of this License, they do not"+ ,"excuse you from the conditions of this License. If you cannot"+ ,"distribute so as to satisfy simultaneously your obligations under this"+ ,"License and any other pertinent obligations, then as a consequence you"+ ,"may not distribute the Library at all. For example, if a patent"+ ,"license would not permit royalty-free redistribution of the Library by"+ ,"all those who receive copies directly or indirectly through you, then"+ ,"the only way you could satisfy both it and this License would be to"+ ,"refrain entirely from distribution of the Library."+ ,""+ ,"If any portion of this section is held invalid or unenforceable under any"+ ,"particular circumstance, the balance of the section is intended to apply,"+ ,"and the section as a whole is intended to apply in other circumstances."+ ,""+ ,"It is not the purpose of this section to induce you to infringe any"+ ,"patents or other property right claims or to contest validity of any"+ ,"such claims; this section has the sole purpose of protecting the"+ ,"integrity of the free software distribution system which is"+ ,"implemented by public license practices. Many people have made"+ ,"generous contributions to the wide range of software distributed"+ ,"through that system in reliance on consistent application of that"+ ,"system; it is up to the author/donor to decide if he or she is willing"+ ,"to distribute software through any other system and a licensee cannot"+ ,"impose that choice."+ ,""+ ,"This section is intended to make thoroughly clear what is believed to"+ ,"be a consequence of the rest of this License."+ ,""+ ," 12. If the distribution and/or use of the Library is restricted in"+ ,"certain countries either by patents or by copyrighted interfaces, the"+ ,"original copyright holder who places the Library under this License may add"+ ,"an explicit geographical distribution limitation excluding those countries,"+ ,"so that distribution is permitted only in or among countries not thus"+ ,"excluded. In such case, this License incorporates the limitation as if"+ ,"written in the body of this License."+ ,""+ ," 13. The Free Software Foundation may publish revised and/or new"+ ,"versions of the Lesser General Public License from time to time."+ ,"Such new versions will be similar in spirit to the present version,"+ ,"but may differ in detail to address new problems or concerns."+ ,""+ ,"Each version is given a distinguishing version number. If the Library"+ ,"specifies a version number of this License which applies to it and"+ ,"\"any later version\", you have the option of following the terms and"+ ,"conditions either of that version or of any later version published by"+ ,"the Free Software Foundation. If the Library does not specify a"+ ,"license version number, you may choose any version ever published by"+ ,"the Free Software Foundation."+ ,"\f"+ ," 14. If you wish to incorporate parts of the Library into other free"+ ,"programs whose distribution conditions are incompatible with these,"+ ,"write to the author to ask for permission. For software which is"+ ,"copyrighted by the Free Software Foundation, write to the Free"+ ,"Software Foundation; we sometimes make exceptions for this. Our"+ ,"decision will be guided by the two goals of preserving the free status"+ ,"of all derivatives of our free software and of promoting the sharing"+ ,"and reuse of software generally."+ ,""+ ," NO WARRANTY"+ ,""+ ," 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO"+ ,"WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW."+ ,"EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR"+ ,"OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY"+ ,"KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE"+ ,"IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+ ,"PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE"+ ,"LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME"+ ,"THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+ ,""+ ," 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN"+ ,"WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY"+ ,"AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU"+ ,"FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR"+ ,"CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE"+ ,"LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING"+ ,"RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A"+ ,"FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF"+ ,"SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"+ ,"DAMAGES."]
lib/Data/GI/CodeGen/Properties.hs view
@@ -8,6 +8,7 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when, unless)+import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Set as S@@ -16,12 +17,15 @@ import Foreign.Storable (sizeOf) import Data.GI.CodeGen.API+import Data.GI.CodeGen.Config (Config(cgFlags),+ CodeGenFlags(cgOverloadedProperties)) import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Code import Data.GI.CodeGen.GObject import Data.GI.CodeGen.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)-import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, qualify,- hyphensToCamelCase, lowerName)+import Data.GI.CodeGen.SymbolNaming (lowerName, upperName,+ classConstraint, typeConstraint,+ hyphensToCamelCase, qualifiedSymbol) import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util @@ -86,72 +90,75 @@ (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop return (constraints, t) -genPropertySetter :: Name -> Text -> Property -> CodeGen ()-genPropertySetter n pName prop = group $ do- oName <- upperName n+genPropertySetter :: Text -> Name -> Text -> Property -> CodeGen ()+genPropertySetter setter n cName prop = group $ do (constraints, t) <- attrType prop isNullable <- typeIsNullable (propType prop)- let constraints' = "MonadIO m":(classConstraint oName <> " o"):constraints+ cls <- classConstraint n+ let constraints' = "MonadIO m":(cls <> " o"):constraints tStr <- propTypeStr $ propType prop- line $ "set" <> pName <> " :: (" <> T.intercalate ", " constraints'+ line $ setter <> " :: (" <> T.intercalate ", " constraints' <> ") => o -> " <> t <> " -> m ()"- line $ "set" <> pName <> " obj val = liftIO $ setObjectProperty" <> tStr+ line $ setter <> " obj val = liftIO $ setObjectProperty" <> tStr <> " obj \"" <> propName prop <> if isNullable then "\" (Just val)" else "\" val"+ exportProperty cName setter -genPropertyGetter :: Name -> Text -> Property -> CodeGen ()-genPropertyGetter n pName prop = group $ do- oName <- upperName n+genPropertyGetter :: Text -> Name -> Text -> Property -> CodeGen ()+genPropertyGetter getter n cName prop = group $ do isNullable <- typeIsNullable (propType prop) let isMaybe = isNullable && propReadNullable prop /= Just False constructorType <- haskellType (propType prop) tStr <- propTypeStr $ propType prop- let constraints = "(MonadIO m, " <> classConstraint oName <> " o)"+ cls <- classConstraint n+ let constraints = "(MonadIO m, " <> cls <> " o)" outType = if isMaybe then maybeT constructorType else constructorType- getter = if isNullable && not isMaybe- then "checkUnexpectedNothing \"get" <> pName- <> "\" $ getObjectProperty" <> tStr- else "getObjectProperty" <> tStr- line $ "get" <> pName <> " :: " <> constraints <>+ getProp = if isNullable && not isMaybe+ then "checkUnexpectedNothing \"" <> getter+ <> "\" $ getObjectProperty" <> tStr+ else "getObjectProperty" <> tStr+ line $ getter <> " :: " <> constraints <> " => o -> " <> tshow ("m" `con` [outType])- line $ "get" <> pName <> " obj = liftIO $ " <> getter+ line $ getter <> " obj = liftIO $ " <> getProp <> " obj \"" <> propName prop <> "\"" <> if tStr `elem` ["Object", "Boxed"] then " " <> tshow constructorType -- These require the constructor. else ""+ exportProperty cName getter -genPropertyConstructor :: Text -> Property -> CodeGen ()-genPropertyConstructor pName prop = group $ do+genPropertyConstructor :: Text -> Name -> Text -> Property -> CodeGen ()+genPropertyConstructor constructor n cName prop = group $ do (constraints, t) <- attrType prop tStr <- propTypeStr $ propType prop isNullable <- typeIsNullable (propType prop)- let constraints' =- case constraints of- [] -> ""- _ -> parenthesize (T.intercalate ", " constraints) <> " => "- line $ "construct" <> pName <> " :: " <> constraints'- <> t <> " -> IO ([Char], GValue)"- line $ "construct" <> pName <> " val = constructObjectProperty" <> tStr+ cls <- classConstraint n+ let constraints' = (cls <> " o") : constraints+ pconstraints = parenthesize (T.intercalate ", " constraints') <> " => "+ line $ constructor <> " :: " <> pconstraints+ <> t <> " -> IO (GValueConstruct o)"+ line $ constructor <> " val = constructObjectProperty" <> tStr <> " \"" <> propName prop <> if isNullable then "\" (Just val)" else "\" val"+ exportProperty cName constructor -genPropertyClear :: Name -> Text -> Property -> CodeGen ()-genPropertyClear n pName prop = group $ do- oName <- upperName n+genPropertyClear :: Text -> Name -> Text -> Property -> CodeGen ()+genPropertyClear clear n cName prop = group $ do nothingType <- tshow . maybeT <$> haskellType (propType prop)- let constraints = ["MonadIO m", classConstraint oName <> " o"]+ cls <- classConstraint n+ let constraints = ["MonadIO m", cls <> " o"] tStr <- propTypeStr $ propType prop- line $ "clear" <> pName <> " :: (" <> T.intercalate ", " constraints+ line $ clear <> " :: (" <> T.intercalate ", " constraints <> ") => o -> m ()"- line $ "clear" <> pName <> " obj = liftIO $ setObjectProperty" <> tStr+ line $ clear <> " obj = liftIO $ setObjectProperty" <> tStr <> " obj \"" <> propName prop <> "\" (Nothing :: " <> nothingType <> ")"+ exportProperty cName clear -- | The property name as a lexically valid Haskell identifier. Note -- that this is not escaped, since it is assumed that it will be used@@ -185,25 +192,23 @@ -- generate a fully qualified accesor name, otherwise just return -- "undefined". accessor is "get", "set" or "construct" accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen Text-accessorOrUndefined available accessor (Name ons on) cName =+accessorOrUndefined available accessor owner@(Name _ on) cName = if not available then return "undefined"- else do- prefix <- qualify ons- return $ prefix <> accessor <> on <> cName+ else qualifiedSymbol (accessor <> on <> cName) owner -- | The name of the type encoding the information for the property of -- the object. infoType :: Name -> Property -> CodeGen Text-infoType owner prop = do- name <- upperName owner- let cName = (hyphensToCamelCase . propName) prop- return $ name <> cName <> "PropertyInfo"+infoType owner prop =+ let infoType = upperName owner <> (hyphensToCamelCase . propName) prop+ <> "PropertyInfo"+ in qualifiedSymbol infoType owner genOneProperty :: Name -> Property -> ExcCodeGen () genOneProperty owner prop = do- name <- upperName owner- let cName = (hyphensToCamelCase . propName) prop+ let name = upperName owner+ cName = (hyphensToCamelCase . propName) prop pName = name <> cName flags = propFlags prop writable = PropertyWritable `elem` flags &&@@ -222,14 +227,6 @@ isNullable <- typeIsNullable (propType prop) - getter <- accessorOrUndefined readable "get" owner cName- setter <- accessorOrUndefined writable "set" owner cName- constructor <- accessorOrUndefined (writable || constructOnly)- "construct" owner cName- clear <- accessorOrUndefined (isNullable && writable &&- propWriteNullable prop /= Just False)- "clear" owner cName- unless (readable || writable || constructOnly) $ notImplementedError $ "Property is not readable, writable, or constructible: " <> tshow pName@@ -241,12 +238,20 @@ line $ " -- Nullable: " <> tshow (propReadNullable prop, propWriteNullable prop) - when readable $ genPropertyGetter owner pName prop- when writable $ genPropertySetter owner pName prop- when (writable || constructOnly) $ genPropertyConstructor pName prop- when (isNullable && writable && propWriteNullable prop /= Just False) $- genPropertyClear owner pName prop+ getter <- accessorOrUndefined readable "get" owner cName+ setter <- accessorOrUndefined writable "set" owner cName+ constructor <- accessorOrUndefined (writable || constructOnly)+ "construct" owner cName+ clear <- accessorOrUndefined (isNullable && writable &&+ propWriteNullable prop /= Just False)+ "clear" owner cName + when (getter /= "undefined") $ genPropertyGetter getter owner cName prop+ when (setter /= "undefined") $ genPropertySetter setter owner cName prop+ when (constructor /= "undefined") $+ genPropertyConstructor constructor owner cName prop+ when (clear /= "undefined") $ genPropertyClear clear owner cName prop+ outType <- if not readable then return "()" else do@@ -258,17 +263,20 @@ else sOutType -- Polymorphic _label style lens- group $ do- inIsGO <- isGObject (propType prop)- hInType <- tshow <$> haskellType (propType prop)- let inConstraint = if writable || constructOnly- then if inIsGO- then classConstraint hInType- else "(~) " <> if T.any (== ' ') hInType- then parenthesize hInType- else hInType- else "(~) ()"- allowedOps = (if writable+ cfg <- config+ when (cgOverloadedProperties (cgFlags cfg)) $ group $ do+ cls <- classConstraint owner+ inConstraint <- if writable || constructOnly+ then do+ inIsGO <- isGObject (propType prop)+ hInType <- tshow <$> haskellType (propType prop)+ if inIsGO+ then typeConstraint (propType prop)+ else return $ "(~) " <> if T.any (== ' ') hInType+ then parenthesize hInType+ else hInType+ else return "(~) ()"+ let allowedOps = (if writable then ["'AttrSet", "'AttrConstruct"] else []) <> (if constructOnly@@ -282,10 +290,6 @@ else []) it <- infoType owner prop exportProperty cName it- when (getter /= "undefined") (exportProperty cName getter)- when (setter /= "undefined") (exportProperty cName setter)- when (constructor /= "undefined") (exportProperty cName constructor)- when (clear /= "undefined") (exportProperty cName clear) bline $ "data " <> it line $ "instance AttrInfo " <> it <> " where" indent $ do@@ -293,8 +297,7 @@ <> " = '[ " <> T.intercalate ", " allowedOps <> "]" line $ "type AttrSetTypeConstraint " <> it <> " = " <> inConstraint- line $ "type AttrBaseTypeConstraint " <> it- <> " = " <> classConstraint name+ line $ "type AttrBaseTypeConstraint " <> it <> " = " <> cls line $ "type AttrGetType " <> it <> " = " <> outType line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\"" line $ "attrGet _ = " <> getter@@ -325,19 +328,24 @@ genProperties :: Name -> [Property] -> [Text] -> CodeGen () genProperties n ownedProps allProps = do- name <- upperName n+ let name = upperName n + cfg <- config forM_ ownedProps $ \prop -> do handleCGExc (\err -> do line $ "-- XXX Generation of property \"" <> propName prop <> "\" of object \"" <> name <> "\" failed: " <> describeCGError err- genPlaceholderProperty n prop)+ (when (cgOverloadedProperties (cgFlags cfg)) $+ genPlaceholderProperty n prop)) (genOneProperty n prop) - group $ do+ cfg <- config++ when (cgOverloadedProperties (cgFlags cfg)) $ group $ do let propListType = name <> "AttributeList"- line $ "type instance AttributeList " <> name <> " = " <> propListType+ line $ "instance O.HasAttributeList " <> name+ line $ "type instance O.AttributeList " <> name <> " = " <> propListType line $ "type " <> propListType <> " = ('[ " <> T.intercalate ", " allProps <> "] :: [(Symbol, *)])" @@ -354,7 +362,7 @@ genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen () genNamespacedAttrLabels owner attrNames methods = do- name <- upperName owner+ let name = upperName owner let methodNames = S.fromList (map (lowerName . methodName) methods) filteredAttrs = filter (`S.notMember` methodNames) attrNames
lib/Data/GI/CodeGen/Signal.hs view
@@ -9,6 +9,7 @@ #endif import Control.Monad (forM, forM_, when, unless) +import Data.Monoid ((<>)) import Data.Typeable (typeOf) import Data.Bool (bool) import qualified Data.Text as T@@ -51,8 +52,7 @@ -- Prototype of the callback on the C side genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen ()-genCCallbackPrototype subsec cb name' isSignal =- group $ do+genCCallbackPrototype subsec cb name' isSignal = group $ do let ctypeName = name' <> "C" exportSignal subsec ctypeName @@ -248,8 +248,8 @@ line $ "return " <> result' genCallback :: Name -> Callback -> CodeGen ()-genCallback n (Callback cb) = submodule "Callbacks" $ do- name' <- upperName n+genCallback n (Callback cb) = do+ let name' = upperName n line $ "-- callback " <> name' let -- user_data pointers, which we generically omit@@ -286,7 +286,7 @@ genSignal :: Signal -> Name -> ExcCodeGen () genSignal (Signal { sigName = sn, sigCallable = cb }) on = do- on' <- upperName on+ let on' = upperName on line $ "-- signal " <> on' <> "::" <> sn
lib/Data/GI/CodeGen/Struct.hs view
@@ -14,12 +14,14 @@ import Control.Monad (forM, when) import Data.Maybe (mapMaybe, isJust, catMaybes)+import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API import Data.GI.CodeGen.Conversions import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Config (Config(..), CodeGenFlags(..)) import Data.GI.CodeGen.SymbolNaming import Data.GI.CodeGen.Type import Data.GI.CodeGen.Util@@ -76,14 +78,14 @@ -- struct/union. infoType :: Name -> Field -> CodeGen Text infoType owner field = do- name <- upperName owner+ let name = upperName owner let fName = (underscoresToCamelCase . fieldName) field return $ name <> fName <> "FieldInfo" -- | Extract a field from a struct. buildFieldReader :: Name -> Field -> ExcCodeGen () buildFieldReader n field = group $ do- name' <- upperName n+ let name' = upperName n let getter = fieldGetter n field isMaybe <- typeIsNullable (fieldType field)@@ -120,7 +122,7 @@ -- the C representation. buildFieldWriter :: Name -> Field -> ExcCodeGen () buildFieldWriter n field = group $ do- name' <- upperName n+ let name' = upperName n let setter = fieldSetter n field isPtr <- typeIsPtr (fieldType field)@@ -143,7 +145,7 @@ -- | Write a @NULL@ into a field of a struct of type `Ptr`. buildFieldClear :: Name -> Field -> ExcCodeGen () buildFieldClear n field = group $ do- name' <- upperName n+ let name' = upperName n let clear = fieldClear n field fType <- tshow <$> foreignType (fieldType field)@@ -156,15 +158,15 @@ -- | Name for the getter function fieldGetter :: Name -> Field -> Text-fieldGetter name' field = lowerName name' <> "Read" <> fName field+fieldGetter name' field = "get" <> upperName name' <> fName field -- | Name for the setter function fieldSetter :: Name -> Field -> Text-fieldSetter name' field = lowerName name' <> "Write" <> fName field+fieldSetter name' field = "set" <> upperName name' <> fName field -- | Name for the clear function fieldClear :: Name -> Field -> Text-fieldClear name' field = lowerName name' <> "Clear" <> fName field+fieldClear name' field = "clear" <> upperName name' <> fName field -- | Haskell name for the field fName :: Field -> Text@@ -176,7 +178,7 @@ genAttrInfo :: Name -> Field -> CodeGen Text genAttrInfo owner field = do it <- infoType owner field- on <- upperName owner+ let on = upperName owner isPtr <- typeIsPtr (fieldType field) @@ -223,13 +225,8 @@ buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text) buildFieldAttributes n field | not (fieldVisible field) = return Nothing+ | privateType (fieldType field) = return Nothing | otherwise = group $ do-- hType <- tshow <$> haskellType (fieldType field)- if ("Private" `T.isSuffixOf` hType ||- not (fieldVisible field))- then return Nothing- else do isPtr <- typeIsPtr (fieldType field) buildFieldReader n field@@ -242,11 +239,18 @@ when isPtr $ exportProperty (fName field) (fieldClear n field) - Just <$> genAttrInfo n field+ cfg <- config+ if cgOverloadedProperties (cgFlags cfg)+ then Just <$> genAttrInfo n field+ else return Nothing + where privateType :: Type -> Bool+ privateType (TInterface _ n) = "Private" `T.isSuffixOf` n+ privateType _ = False+ genStructOrUnionFields :: Name -> [Field] -> CodeGen () genStructOrUnionFields n fields = do- name' <- upperName n+ let name' = upperName n attrs <- forM fields $ \field -> handleCGExc (\e -> line ("-- XXX Skipped attribute for \"" <> name' <>@@ -257,9 +261,11 @@ blank - group $ do+ cfg <- config+ when (cgOverloadedProperties (cgFlags cfg)) $ group $ do let attrListName = name' <> "AttributeList"- line $ "type instance AttributeList " <> name' <> " = " <> attrListName+ line $ "instance O.HasAttributeList " <> name'+ line $ "type instance O.AttributeList " <> name' <> " = " <> attrListName line $ "type " <> attrListName <> " = ('[ " <> T.intercalate ", " (catMaybes attrs) <> "] :: [(Symbol, *)])" @@ -267,7 +273,7 @@ -- type, using the boxed (or GLib, for unboxed types) allocator. genZeroSU :: Name -> Int -> Bool -> CodeGen () genZeroSU n size isBoxed = group $ do- name <- upperName n+ let name = upperName n let builder = "newZero" <> name tsize = tshow size line $ "-- | Construct a `" <> name <> "` struct initialized to zero."@@ -322,7 +328,7 @@ -- allocate/deallocate unboxed structs and unions. genWrappedPtr :: Name -> AllocationInfo -> Int -> CodeGen () genWrappedPtr n info size = group $ do- name' <- upperName n+ let name' = upperName n let prefix = \op -> "_" <> name' <> "_" <> op <> "_"
lib/Data/GI/CodeGen/SymbolNaming.hs view
@@ -1,26 +1,42 @@ {-# LANGUAGE ViewPatterns #-} module Data.GI.CodeGen.SymbolNaming- ( qualify- , lowerName+ ( lowerName , upperName , noName , escapedArgName+ , classConstraint+ , typeConstraint+ , hyphensToCamelCase , underscoresToCamelCase++ , submoduleLocation+ , qualifiedAPI+ , qualifiedSymbol ) where +import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.GI.CodeGen.API-import Data.GI.CodeGen.Code-import Data.GI.CodeGen.Config (Config(modName))+import Data.GI.CodeGen.Code (CodeGen, ModuleName, group, line, exportDecl,+ qualified, getAPI)+import Data.GI.CodeGen.Type (Type(TInterface)) import Data.GI.CodeGen.Util (lcFirst, ucFirst) -classConstraint :: Text -> Text-classConstraint n = n <> "K"+-- | Return a qualified form of the constraint for the given name+-- (which should correspond to a valid `TInterface`).+classConstraint :: Name -> CodeGen Text+classConstraint n@(Name _ s) = qualifiedSymbol ("Is" <> s) n +-- | Same as `classConstraint`, but applicable directly to a type. The+-- type should be a `TInterface`, otherwise an error will be raised.+typeConstraint :: Type -> CodeGen Text+typeConstraint (TInterface ns s) = classConstraint (Name ns s)+typeConstraint t = error $ "Class constraint for non-interface type: " <> show t+ -- | Move leading underscores to the end (for example in -- GObject::_Value_Data_Union -> GObject::Value_Data_Union_) sanitize :: Text -> Text@@ -33,33 +49,36 @@ "" -> error "empty name!!" n -> lcFirst n -upperNameWithSuffix :: Text -> Name -> CodeGen Text-upperNameWithSuffix suffix (Name ns s) = do- prefix <- qualifyWithSuffix suffix ns- return $ prefix <> uppered- where uppered = underscoresToCamelCase (sanitize s)+upperName :: Name -> Text+upperName (Name _ s) = underscoresToCamelCase (sanitize s) -upperName :: Name -> CodeGen Text-upperName = upperNameWithSuffix "."+-- | Return an identifier for the given interface type valid in the current+-- module.+qualifiedAPI :: Name -> CodeGen Text+qualifiedAPI n@(Name ns s) = do+ api <- getAPI (TInterface ns s)+ qualified ("GI" : ucFirst ns : submoduleLocation n api) n --- | Return a qualified prefix for the given namespace. In case the--- namespace corresponds to the current module the empty string is--- returned, otherwise the namespace ++ suffix is returned. Suffix is--- typically just ".", see `qualify` below.-qualifyWithSuffix :: Text -> Text -> CodeGen Text-qualifyWithSuffix suffix ns = do- cfg <- config- if modName cfg == Just ns then- return ""- else do- loadDependency ns -- Make sure that the given namespace is- -- listed as a dependency of this module.- return $ ucFirst ns <> suffix+-- | Construct an identifier for the given symbol in the given API.+qualifiedSymbol :: Text -> Name -> CodeGen Text+qualifiedSymbol s n@(Name ns nn) = do+ api <- getAPI (TInterface ns nn)+ qualified ("GI" : ucFirst ns : submoduleLocation n api) (Name ns s) --- | Return the qualified namespace (ns ++ "." or "", depending on--- whether ns is the current namespace).-qualify :: Text -> CodeGen Text-qualify = qualifyWithSuffix "."+-- | Construct the submodule name (as a list, to be joined by+-- intercalating ".") where the given API element will live. This is+-- the path relative to the root for the corresponding+-- namespace. I.e. the "GI.Gtk" part is not prepended.+submoduleLocation :: Name -> API -> ModuleName+submoduleLocation _ (APIConst _) = ["Constants"]+submoduleLocation _ (APIFunction _) = ["Functions"]+submoduleLocation _ (APICallback _) = ["Callbacks"]+submoduleLocation _ (APIEnum _) = ["Enums"]+submoduleLocation _ (APIFlags _) = ["Flags"]+submoduleLocation n (APIInterface _) = ["Interfaces", upperName n]+submoduleLocation n (APIObject _) = ["Objects", upperName n]+submoduleLocation n (APIStruct _) = ["Structs", upperName n]+submoduleLocation n (APIUnion _) = ["Unions", upperName n] -- | Save a bit of typing for optional arguments in the case that we -- want to pass Nothing.
lib/Data/GI/CodeGen/Transfer.hs view
@@ -12,6 +12,7 @@ import Control.Monad (when) import Data.Maybe (isJust)+import Data.Monoid ((<>)) import Data.Text (Text) import Data.GI.CodeGen.API