diff --git a/cmdline/haskell-gi.hs b/cmdline/haskell-gi.hs --- a/cmdline/haskell-gi.hs +++ b/cmdline/haskell-gi.hs @@ -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." <>) diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.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, diff --git a/lib/Data/GI/CodeGen/Cabal.hs b/lib/Data/GI/CodeGen/Cabal.hs --- a/lib/Data/GI/CodeGen/Cabal.hs +++ b/lib/Data/GI/CodeGen/Cabal.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs --- a/lib/Data/GI/CodeGen/CabalHooks.hs +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs --- a/lib/Data/GI/CodeGen/Callable.hs +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs --- a/lib/Data/GI/CodeGen/CodeGen.hs +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Config.hs b/lib/Data/GI/CodeGen/Config.hs --- a/lib/Data/GI/CodeGen/Config.hs +++ b/lib/Data/GI/CodeGen/Config.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Constant.hs b/lib/Data/GI/CodeGen/Constant.hs --- a/lib/Data/GI/CodeGen/Constant.hs +++ b/lib/Data/GI/CodeGen/Constant.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Conversions.hs b/lib/Data/GI/CodeGen/Conversions.hs --- a/lib/Data/GI/CodeGen/Conversions.hs +++ b/lib/Data/GI/CodeGen/Conversions.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Inheritance.hs b/lib/Data/GI/CodeGen/Inheritance.hs --- a/lib/Data/GI/CodeGen/Inheritance.hs +++ b/lib/Data/GI/CodeGen/Inheritance.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedLabels.hs b/lib/Data/GI/CodeGen/OverloadedLabels.hs --- a/lib/Data/GI/CodeGen/OverloadedLabels.hs +++ b/lib/Data/GI/CodeGen/OverloadedLabels.hs @@ -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(..))" diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs --- a/lib/Data/GI/CodeGen/OverloadedMethods.hs +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedSignals.hs b/lib/Data/GI/CodeGen/OverloadedSignals.hs --- a/lib/Data/GI/CodeGen/OverloadedSignals.hs +++ b/lib/Data/GI/CodeGen/OverloadedSignals.hs @@ -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, *)])" diff --git a/lib/Data/GI/CodeGen/PkgConfig.hs b/lib/Data/GI/CodeGen/PkgConfig.hs --- a/lib/Data/GI/CodeGen/PkgConfig.hs +++ b/lib/Data/GI/CodeGen/PkgConfig.hs @@ -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, _) <- diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs --- a/lib/Data/GI/CodeGen/ProjectInfo.hs +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -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."] diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs --- a/lib/Data/GI/CodeGen/Properties.hs +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs --- a/lib/Data/GI/CodeGen/Signal.hs +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -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 <> "_" diff --git a/lib/Data/GI/CodeGen/SymbolNaming.hs b/lib/Data/GI/CodeGen/SymbolNaming.hs --- a/lib/Data/GI/CodeGen/SymbolNaming.hs +++ b/lib/Data/GI/CodeGen/SymbolNaming.hs @@ -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. diff --git a/lib/Data/GI/CodeGen/Transfer.hs b/lib/Data/GI/CodeGen/Transfer.hs --- a/lib/Data/GI/CodeGen/Transfer.hs +++ b/lib/Data/GI/CodeGen/Transfer.hs @@ -12,6 +12,7 @@ import Control.Monad (when) import Data.Maybe (isJust) +import Data.Monoid ((<>)) import Data.Text (Text) import Data.GI.CodeGen.API