haskell-gi 0.13 → 0.14
raw patch · 103 files changed
+8356/−7585 lines, 103 filesdep +Cabaldep +haskell-gidep −freedep ~haskell-gi-base
Dependencies added: Cabal, haskell-gi
Dependencies removed: free
Dependency ranges changed: haskell-gi-base
Files
- cmdline/haskell-gi.hs +229/−0
- haskell-gi.cabal +77/−58
- lib/Data/GI/CodeGen/API.hs +473/−0
- lib/Data/GI/CodeGen/Cabal.hs +184/−0
- lib/Data/GI/CodeGen/CabalHooks.hs +63/−0
- lib/Data/GI/CodeGen/Callable.hs +800/−0
- lib/Data/GI/CodeGen/Code.hs +789/−0
- lib/Data/GI/CodeGen/CodeGen.hs +549/−0
- lib/Data/GI/CodeGen/Config.hs +15/−0
- lib/Data/GI/CodeGen/Constant.hs +107/−0
- lib/Data/GI/CodeGen/Conversions.hs +827/−0
- lib/Data/GI/CodeGen/Fixups.hs +118/−0
- lib/Data/GI/CodeGen/GObject.hs +52/−0
- lib/Data/GI/CodeGen/GType.hsc +24/−0
- lib/Data/GI/CodeGen/Inheritance.hs +163/−0
- lib/Data/GI/CodeGen/LibGIRepository.hs +150/−0
- lib/Data/GI/CodeGen/OverloadedLabels.hs +94/−0
- lib/Data/GI/CodeGen/OverloadedMethods.hs +106/−0
- lib/Data/GI/CodeGen/OverloadedSignals.hs +122/−0
- lib/Data/GI/CodeGen/Overrides.hs +314/−0
- lib/Data/GI/CodeGen/PkgConfig.hs +47/−0
- lib/Data/GI/CodeGen/ProjectInfo.hs +28/−0
- lib/Data/GI/CodeGen/Properties.hs +369/−0
- lib/Data/GI/CodeGen/Signal.hs +341/−0
- lib/Data/GI/CodeGen/Struct.hs +298/−0
- lib/Data/GI/CodeGen/SymbolNaming.hs +125/−0
- lib/Data/GI/CodeGen/Transfer.hs +257/−0
- lib/Data/GI/CodeGen/Type.hs +41/−0
- lib/Data/GI/CodeGen/Util.hs +48/−0
- lib/Data/GI/GIR/Alias.hs +39/−0
- lib/Data/GI/GIR/Arg.hs +80/−0
- lib/Data/GI/GIR/BasicTypes.hs +67/−0
- lib/Data/GI/GIR/Callable.hs +58/−0
- lib/Data/GI/GIR/Callback.hs +17/−0
- lib/Data/GI/GIR/Constant.hs +27/−0
- lib/Data/GI/GIR/Deprecation.hs +43/−0
- lib/Data/GI/GIR/Documentation.hs +20/−0
- lib/Data/GI/GIR/Enum.hs +52/−0
- lib/Data/GI/GIR/Field.hs +74/−0
- lib/Data/GI/GIR/Flags.hs +17/−0
- lib/Data/GI/GIR/Function.hs +35/−0
- lib/Data/GI/GIR/Interface.hs +40/−0
- lib/Data/GI/GIR/Method.hs +45/−0
- lib/Data/GI/GIR/Object.hs +52/−0
- lib/Data/GI/GIR/Parser.hs +237/−0
- lib/Data/GI/GIR/Property.hs +54/−0
- lib/Data/GI/GIR/Repository.hs +87/−0
- lib/Data/GI/GIR/Signal.hs +26/−0
- lib/Data/GI/GIR/Struct.hs +51/−0
- lib/Data/GI/GIR/Type.hs +168/−0
- lib/Data/GI/GIR/Union.hs +41/−0
- lib/Data/GI/GIR/XMLUtils.hs +94/−0
- lib/c/enumStorage.c +122/−0
- src/GI/API.hs +0/−398
- src/GI/Cabal.hs +0/−184
- src/GI/Callable.hs +0/−811
- src/GI/Code.hs +0/−789
- src/GI/CodeGen.hs +0/−543
- src/GI/Config.hs +0/−15
- src/GI/Constant.hs +0/−103
- src/GI/Conversions.hs +0/−776
- src/GI/GIR/Alias.hs +0/−40
- src/GI/GIR/Arg.hs +0/−81
- src/GI/GIR/BasicTypes.hs +0/−21
- src/GI/GIR/Callable.hs +0/−58
- src/GI/GIR/Callback.hs +0/−17
- src/GI/GIR/Constant.hs +0/−27
- src/GI/GIR/Deprecation.hs +0/−43
- src/GI/GIR/Documentation.hs +0/−20
- src/GI/GIR/Enum.hs +0/−52
- src/GI/GIR/Field.hs +0/−75
- src/GI/GIR/Flags.hs +0/−17
- src/GI/GIR/Function.hs +0/−35
- src/GI/GIR/Interface.hs +0/−40
- src/GI/GIR/Method.hs +0/−45
- src/GI/GIR/Object.hs +0/−52
- src/GI/GIR/Parser.hs +0/−239
- src/GI/GIR/Property.hs +0/−51
- src/GI/GIR/Repository.hs +0/−62
- src/GI/GIR/Signal.hs +0/−26
- src/GI/GIR/Struct.hs +0/−51
- src/GI/GIR/Type.hs +0/−164
- src/GI/GIR/Union.hs +0/−41
- src/GI/GIR/XMLUtils.hs +0/−79
- src/GI/GObject.hs +0/−52
- src/GI/GType.hsc +0/−24
- src/GI/Inheritance.hs +0/−163
- src/GI/LibGIRepository.hs +0/−150
- src/GI/OverloadedLabels.hs +0/−84
- src/GI/OverloadedMethods.hs +0/−106
- src/GI/OverloadedSignals.hs +0/−122
- src/GI/Overrides.hs +0/−181
- src/GI/PkgConfig.hs +0/−47
- src/GI/ProjectInfo.hs +0/−28
- src/GI/Properties.hs +0/−293
- src/GI/Signal.hs +0/−338
- src/GI/Struct.hs +0/−129
- src/GI/SymbolNaming.hs +0/−124
- src/GI/Transfer.hs +0/−257
- src/GI/Type.hs +0/−87
- src/GI/Util.hs +0/−48
- src/c/enumStorage.c +0/−122
- src/haskell-gi.hs +0/−217
+ cmdline/haskell-gi.hs view
@@ -0,0 +1,229 @@+module Main where++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable (traverse)+#endif+import Control.Monad (forM_, when, (>=>))+import Control.Exception (handle)++import Data.Char (toLower)+import Data.Bool (bool)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)++import System.Directory (doesFileExist)+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit+import System.FilePath (joinPath)+import System.IO (hPutStr, hPutStrLn, stderr)++import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Set as S++import Data.GI.Base.GError+import Text.Show.Pretty (ppShow)++import Data.GI.CodeGen.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API)+import Data.GI.CodeGen.Cabal (cabalConfig, setupHs, genCabalProject)+import Data.GI.CodeGen.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText, minBaseVersion)+import Data.GI.CodeGen.Config (Config(..))+import Data.GI.CodeGen.CodeGen (genModule)+import Data.GI.CodeGen.OverloadedLabels (genOverloadedLabels)+import Data.GI.CodeGen.OverloadedSignals (genOverloadedSignalConnectors)+import Data.GI.CodeGen.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps, girFixups)+import Data.GI.CodeGen.ProjectInfo (licenseText)+import Data.GI.CodeGen.Util (ucFirst)++data Mode = GenerateCode | Dump | Labels | Signals | Help++data Options = Options {+ optMode :: Mode,+ optOutputDir :: Maybe String,+ optOverridesFiles :: [String],+ optSearchPaths :: [String],+ optVerbose :: Bool,+ optCabal :: Bool}++defaultOptions :: Options+defaultOptions = Options {+ optMode = GenerateCode,+ optOutputDir = Nothing,+ optOverridesFiles = [],+ optSearchPaths = [],+ optVerbose = False,+ optCabal = True}++parseKeyValue :: String -> (String, String)+parseKeyValue s =+ let (a, '=':b) = break (=='=') s+ in (a, b)++optDescrs :: [OptDescr (Options -> Options)]+optDescrs = [+ Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help })+ "\tprint this gentle help text",+ Option "c" ["connectors"] (NoArg $ \opt -> opt {optMode = Signals})+ "generate generic signal connectors",+ Option "d" ["dump"] (NoArg $ \opt -> opt { optMode = Dump })+ "\tdump internal representation",+ Option "l" ["labels"] (NoArg $ \opt -> opt {optMode = Labels})+ "\tgenerate overloaded labels",+ Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False})+ ("\tdo not generate cabal project structure\n" +++ "\t\t\t(note: if you do not generate a cabal project, make sure\n" +++ "\t\t\tto still activate the necessary GHC extensions when\n" +++ "\t\t\tcompiling the generated bindings.)"),+ Option "o" ["overrides"] (ReqArg+ (\arg opt -> opt {optOverridesFiles =+ arg : optOverridesFiles opt})+ "OVERRIDES")+ "specify a file with overrides info",+ Option "O" ["output"] (ReqArg+ (\arg opt -> opt {optOutputDir = Just arg}) "DIR")+ "\tset the output directory",+ Option "s" ["search"] (ReqArg+ (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH")+ "\tprepend a directory to the typelib search path",+ Option "v" ["verbose"] (NoArg $ \opt -> opt { optVerbose = True })+ "\tprint extra info while processing"]++showHelp :: String+showHelp = concatMap optAsLine optDescrs+ where optAsLine (Option flag (long:_) _ desc) =+ " -" ++ flag ++ "|--" ++ long ++ "\t" ++ desc ++ "\n"+ optAsLine _ = error "showHelp"++printGError :: IO () -> IO ()+printGError = handle (gerrorMessage >=> putStrLn . T.unpack)++-- | Load a dependency without further postprocessing.+loadRawAPIs :: Bool -> Overrides -> [FilePath] -> Text -> IO [(Name, API)]+loadRawAPIs verbose ovs extraPaths name = do+ let version = M.lookup name (nsChooseVersion ovs)+ gir <- loadRawGIRInfo verbose name version extraPaths+ return (girAPIs gir)++-- | Generate overloaded labels ("_label", for example).+genLabels :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()+genLabels options ovs modules extraPaths = do+ apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules+ let allAPIs = M.unions (map M.fromList apis)+ cfg = Config {modName = Nothing,+ verbose = optVerbose options,+ overrides = ovs}+ putStrLn $ "\t* Generating GI.OverloadedLabels"+ m <- genCode cfg allAPIs ["GI", "OverloadedLabels"]+ (genOverloadedLabels (M.toList allAPIs))+ _ <- writeModuleCode (optVerbose options) (optOutputDir options) m+ return ()++-- Generate generic signal connectors ("Clicked", "Activate", ...)+genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()+genGenericConnectors options ovs modules extraPaths = do+ apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules+ let allAPIs = M.unions (map M.fromList apis)+ cfg = Config {modName = Nothing,+ verbose = optVerbose options,+ overrides = ovs}+ putStrLn $ "\t* Generating GI.Signals"+ m <- genCode cfg allAPIs ["GI", "Signals"] (genOverloadedSignalConnectors (M.toList allAPIs))+ _ <- writeModuleCode (optVerbose options) (optOutputDir options) m+ return ()++-- Generate the code for the given module, and return the dependencies+-- for this module.+processMod :: Options -> Overrides -> [FilePath] -> Text -> IO ()+processMod options ovs extraPaths name = do+ let version = M.lookup name (nsChooseVersion ovs)+ cfg = Config {modName = Just name,+ verbose = optVerbose options,+ overrides = ovs}+ nm = ucFirst name+ mp = T.unpack . ("GI." <>)++ putStrLn $ "\t* Generating " ++ mp nm++ (gir, girDeps) <- loadGIRInfo (optVerbose options) name version extraPaths+ (girFixups ovs)+ let (apis, deps) = filterAPIsAndDeps ovs gir girDeps+ allAPIs = M.union apis deps++ m <- genCode cfg allAPIs ["GI", nm] (genModule apis)+ let modDeps = transitiveModuleDeps m+ moduleList <- writeModuleTree (optVerbose options) (optOutputDir options) m++ when (optCabal options) $ do+ let cabal = "gi-" ++ map toLower (T.unpack nm) ++ ".cabal"+ fname <- doesFileExist cabal >>=+ bool (return cabal)+ (putStrLn (cabal ++ " exists, writing "+ ++ cabal ++ ".new instead") >>+ return (cabal ++ ".new"))+ -- The module is not a dep of itself+ let usedDeps = S.delete name modDeps+ -- We only list as dependencies in the cabal file the+ -- dependencies that we use, disregarding what the .gir file says.+ actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps+ baseVersion = minBaseVersion m+ p = \n -> joinPath [fromMaybe "" (optOutputDir options), n]+ (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList baseVersion)+ case err of+ Nothing -> do+ putStrLn $ "\t\t+ " ++ fname+ TIO.writeFile (p fname) (codeToText (moduleCode m))+ putStrLn "\t\t+ cabal.config"+ TIO.writeFile (p "cabal.config") cabalConfig+ putStrLn "\t\t+ Setup.hs"+ TIO.writeFile (p "Setup.hs") setupHs+ putStrLn "\t\t+ LICENSE"+ TIO.writeFile (p "LICENSE") licenseText+ Just msg -> putStrLn $ "ERROR: could not generate " ++ fname+ ++ "\nError was: " ++ T.unpack msg++dump :: Options -> Overrides -> Text -> IO ()+dump options ovs name = do+ let version = M.lookup name (nsChooseVersion ovs)+ (doc, _) <- loadGIRInfo (optVerbose options) name version (optSearchPaths options) []+ mapM_ (putStrLn . ppShow) (girAPIs doc)++process :: Options -> [Text] -> IO ()+process options names = do+ let extraPaths = optSearchPaths options+ configs <- traverse TIO.readFile (optOverridesFiles options)+ parseOverridesFile (concatMap T.lines configs) >>= \case+ Left errorMsg -> do+ hPutStr stderr "Error when parsing the config file(s):\n"+ hPutStr stderr (T.unpack errorMsg)+ exitFailure+ Right ovs ->+ case optMode options of+ GenerateCode -> forM_ names (processMod options ovs extraPaths)+ Labels -> genLabels options ovs names extraPaths+ Signals -> genGenericConnectors options ovs names extraPaths+ Dump -> forM_ names (dump options ovs)+ Help -> putStr showHelp++main :: IO ()+main = printGError $ do+ args <- getArgs+ let (actions, nonOptions, errors) = getOpt RequireOrder optDescrs args+ options = foldl (.) id actions defaultOptions++ case errors of+ [] -> return ()+ _ -> do+ mapM_ (hPutStr stderr) errors+ exitFailure++ case nonOptions of+ [] -> failWithUsage+ names -> process options (map T.pack names)+ where+ failWithUsage = do+ hPutStrLn stderr "usage: haskell-gi [options] module1 [module2 [...]]"+ hPutStr stderr showHelp+ exitFailure
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name: haskell-gi-version: 0.13+version: 0.14 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.@@ -20,10 +20,11 @@ type: git location: git://github.com/haskell-gi/haskell-gi.git -executable haskell-gi- main-is: haskell-gi.hs+Library pkgconfig-depends: gobject-introspection-1.0 >= 1.42, gobject-2.0 >= 2.36 build-depends: base >= 4.7 && < 5,+ haskell-gi-base == 0.14,+ Cabal >= 1.24, containers, directory, filepath,@@ -36,61 +37,79 @@ bytestring, xdg-basedir, xml-conduit >= 1.3.0,- haskell-gi-base == 0.13.*,- text >= 1.0,- free-- build-tools: hsc2hs- hs-source-dirs: src- other-modules: GI.GIR.Alias,- GI.GIR.Arg,- GI.GIR.BasicTypes,- GI.GIR.Callable,- GI.GIR.Callback,- GI.GIR.Constant,- GI.GIR.Deprecation,- GI.GIR.Documentation,- GI.GIR.Enum,- GI.GIR.Field,- GI.GIR.Flags,- GI.GIR.Function,- GI.GIR.Interface,- GI.GIR.Method,- GI.GIR.Object,- GI.GIR.Parser,- GI.GIR.Property,- GI.GIR.Repository,- GI.GIR.Signal,- GI.GIR.Struct,- GI.GIR.Type,- GI.GIR.Union,- GI.GIR.XMLUtils,- GI.API,- GI.Cabal,- GI.Callable,- GI.Code,- GI.CodeGen,- GI.Config,- GI.Constant,- GI.Conversions,- GI.GObject,- GI.GType,- GI.Inheritance,- GI.LibGIRepository,- GI.OverloadedSignals,- GI.OverloadedLabels,- GI.OverloadedMethods,- GI.Overrides,- GI.PkgConfig,- GI.ProjectInfo,- GI.Properties,- GI.Signal,- GI.Struct,- GI.SymbolNaming,- GI.Transfer,- GI.Type,- GI.Util+ text >= 1.0 extensions: CPP, ForeignFunctionInterface, DoAndIfThenElse, LambdaCase, RankNTypes, OverloadedStrings ghc-options: -Wall -fno-warn-missing-signatures -fwarn-incomplete-patterns -fno-warn-name-shadowing- c-sources: src/c/enumStorage.c+ c-sources: lib/c/enumStorage.c++ build-tools: hsc2hs+ hs-source-dirs: lib+ exposed-modules: Data.GI.GIR.Alias,+ Data.GI.GIR.Arg,+ Data.GI.GIR.BasicTypes,+ Data.GI.GIR.Callable,+ Data.GI.GIR.Callback,+ Data.GI.GIR.Constant,+ Data.GI.GIR.Deprecation,+ Data.GI.GIR.Documentation,+ Data.GI.GIR.Enum,+ Data.GI.GIR.Field,+ Data.GI.GIR.Flags,+ Data.GI.GIR.Function,+ Data.GI.GIR.Interface,+ Data.GI.GIR.Method,+ Data.GI.GIR.Object,+ Data.GI.GIR.Parser,+ Data.GI.GIR.Property,+ Data.GI.GIR.Repository,+ Data.GI.GIR.Signal,+ Data.GI.GIR.Struct,+ Data.GI.GIR.Type,+ Data.GI.GIR.Union,+ Data.GI.GIR.XMLUtils,+ Data.GI.CodeGen.API,+ Data.GI.CodeGen.Cabal,+ Data.GI.CodeGen.CabalHooks,+ Data.GI.CodeGen.Callable,+ Data.GI.CodeGen.Code,+ Data.GI.CodeGen.CodeGen,+ Data.GI.CodeGen.Config,+ Data.GI.CodeGen.Constant,+ Data.GI.CodeGen.Conversions,+ Data.GI.CodeGen.Fixups,+ Data.GI.CodeGen.GObject,+ Data.GI.CodeGen.GType,+ Data.GI.CodeGen.Inheritance,+ Data.GI.CodeGen.LibGIRepository,+ Data.GI.CodeGen.OverloadedSignals,+ Data.GI.CodeGen.OverloadedLabels,+ Data.GI.CodeGen.OverloadedMethods,+ Data.GI.CodeGen.Overrides,+ Data.GI.CodeGen.PkgConfig,+ Data.GI.CodeGen.ProjectInfo,+ Data.GI.CodeGen.Properties,+ Data.GI.CodeGen.Signal,+ Data.GI.CodeGen.Struct,+ Data.GI.CodeGen.SymbolNaming,+ Data.GI.CodeGen.Transfer,+ Data.GI.CodeGen.Type,+ Data.GI.CodeGen.Util++ other-modules: Paths_haskell_gi++executable haskell-gi+ main-is: haskell-gi.hs+ hs-source-dirs: cmdline++ extensions: CPP, OverloadedStrings, LambdaCase+ ghc-options: -Wall -fno-warn-name-shadowing++ build-depends: base >= 4.7 && < 5,+ text >= 1.0,+ filepath,+ containers,+ directory,+ pretty-show,+ haskell-gi,+ haskell-gi-base
+ lib/Data/GI/CodeGen/API.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++module Data.GI.CodeGen.API+ ( API(..)+ , GIRInfo(..)+ , loadGIRInfo+ , loadRawGIRInfo++ , GIRRule(..)+ , GIRPath+ , GIRNodeSpec(..)++ -- Reexported from Data.GI.GIR.BasicTypes+ , Name(..)+ , Transfer(..)++ -- Reexported from Data.GI.GIR.Arg+ , Direction(..)+ , Scope(..)++ -- Reexported from Data.GI.GIR.Deprecation+ , deprecatedPragma+ , DeprecationInfo++ -- Reexported from Data.GI.GIR.Property+ , PropertyFlag(..)++ -- Reexported from Data.GI.GIR.Method+ , MethodType(..)++ -- Reexported from the corresponding Data.GI.GIR modules+ , Constant(..)+ , Arg(..)+ , Callable(..)+ , Function(..)+ , Signal(..)+ , Property(..)+ , Field(..)+ , Struct(..)+ , Callback(..)+ , Interface(..)+ , Method(..)+ , Object(..)+ , Enumeration(..)+ , Flags (..)+ , Union (..)+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad ((>=>), forM, forM_)+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe (mapMaybe, catMaybes)+import Data.Monoid ((<>))+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)++import Foreign.Ptr (Ptr)+import Foreign (peek)+import Foreign.C.Types (CUInt)++import Text.XML hiding (Name)+import qualified Text.XML as XML++import Data.GI.GIR.Alias (documentListAliases)+import Data.GI.GIR.Arg (Arg(..), Direction(..), Scope(..))+import Data.GI.GIR.BasicTypes (Alias, Name(..), Transfer(..))+import Data.GI.GIR.Callable (Callable(..))+import Data.GI.GIR.Callback (Callback(..), parseCallback)+import Data.GI.GIR.Constant (Constant(..), parseConstant)+import Data.GI.GIR.Deprecation (DeprecationInfo, deprecatedPragma)+import Data.GI.GIR.Enum (Enumeration(..), parseEnum)+import Data.GI.GIR.Field (Field(..))+import Data.GI.GIR.Flags (Flags(..), parseFlags)+import Data.GI.GIR.Function (Function(..), parseFunction)+import Data.GI.GIR.Interface (Interface(..), parseInterface)+import Data.GI.GIR.Method (Method(..), MethodType(..))+import Data.GI.GIR.Object (Object(..), parseObject)+import Data.GI.GIR.Parser (Parser, runParser)+import Data.GI.GIR.Property (Property(..), PropertyFlag(..))+import Data.GI.GIR.Repository (readGiRepository)+import Data.GI.GIR.Signal (Signal(..))+import Data.GI.GIR.Struct (Struct(..), parseStruct)+import Data.GI.GIR.Union (Union(..), parseUnion)+import Data.GI.GIR.XMLUtils (subelements, childElemsWithLocalName, lookupAttr,+ lookupAttrWithNamespace, GIRXMLNamespace(..),+ xmlLocalName)++import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength)+import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName)+import Data.GI.Base.Utils (allocMem, freeMem)+import Data.GI.CodeGen.LibGIRepository (girRequire, girStructSizeAndOffsets,+ girUnionSizeAndOffsets, girLoadGType)+import Data.GI.CodeGen.GType (gtypeIsBoxed)+import Data.GI.CodeGen.Type (Type)++data GIRInfo = GIRInfo {+ girPCPackages :: [Text],+ girNSName :: Text,+ girNSVersion :: Text,+ girAPIs :: [(Name, API)],+ girCTypes :: M.Map Text Name+ } deriving Show++data GIRNamespace = GIRNamespace {+ nsName :: Text,+ nsVersion :: Text,+ nsAPIs :: [(Name, API)],+ nsCTypes :: [(Text, Name)]+ } deriving (Show)++data GIRInfoParse = GIRInfoParse {+ girIPPackage :: [Maybe Text],+ girIPIncludes :: [Maybe (Text, Text)],+ girIPNamespaces :: [Maybe GIRNamespace]+} deriving (Show)++-- | Path to a node in the GIR file, starting from the document root+-- of the GIR file. This is a very simplified version of something+-- like XPath.+type GIRPath = [GIRNodeSpec]++-- | Node selector for a path in the GIR file.+data GIRNodeSpec = GIRNamed Text -- ^ Node with the given "name" attr.+ | GIRType Text -- ^ Node of the given type.+ | GIRTypedName Text Text -- ^ Combination of the above.+ deriving (Show)++-- | A rule for modifying the GIR file.+data GIRRule = GIRSetAttr (GIRPath, XML.Name) Text -- ^ (Path to element,+ -- attrName), newValue+ deriving (Show)++data API+ = APIConst Constant+ | APIFunction Function+ | APICallback Callback+ | APIEnum Enumeration+ | APIFlags Flags+ | APIInterface Interface+ | APIObject Object+ | APIStruct Struct+ | APIUnion Union+ deriving Show++parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API)+ -> Parser (Name, a) -> (Name, API)+parseAPI ns aliases element wrapper parser =+ case runParser ns aliases element parser of+ Left err -> error $ "Parse error: " ++ T.unpack err+ Right (n, a) -> (n, wrapper a)++parseNSElement :: M.Map Alias Type -> GIRNamespace -> Element -> GIRNamespace+parseNSElement aliases ns@GIRNamespace{..} element+ | lookupAttr "introspectable" element == Just "0" = ns+ | otherwise =+ case nameLocalName (elementName element) of+ "alias" -> ns -- Processed separately+ "constant" -> parse APIConst parseConstant+ "enumeration" -> parse APIEnum parseEnum+ "bitfield" -> parse APIFlags parseFlags+ "function" -> parse APIFunction parseFunction+ "callback" -> parse APICallback parseCallback+ "record" -> parse APIStruct parseStruct+ "union" -> parse APIUnion parseUnion+ "class" -> parse APIObject parseObject+ "interface" -> parse APIInterface parseInterface+ "boxed" -> ns -- Unsupported+ n -> error . T.unpack $ "Unknown GIR element \"" <> n <> "\" when processing namespace \"" <> nsName <> "\", aborting."+ where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace+ parse wrapper parser =+ let (n, api) = parseAPI nsName aliases element wrapper parser+ maybeCType = lookupAttrWithNamespace CGIRNS "type" element+ in ns { nsAPIs = (n, api) : nsAPIs,+ nsCTypes = case maybeCType of+ Just ctype -> (ctype, n) : nsCTypes+ Nothing -> nsCTypes+ }++parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace+parseNamespace element aliases = do+ let attrs = elementAttributes element+ name <- M.lookup "name" attrs+ version <- M.lookup "version" attrs+ let ns = GIRNamespace {+ nsName = name,+ nsVersion = version,+ nsAPIs = [],+ nsCTypes = []+ }+ return (L.foldl' (parseNSElement aliases) ns (subelements element))++parseInclude :: Element -> Maybe (Text, Text)+parseInclude element = do+ name <- M.lookup "name" attrs+ version <- M.lookup "version" attrs+ return (name, version)+ where attrs = elementAttributes element++parsePackage :: Element -> Maybe Text+parsePackage element = M.lookup "name" (elementAttributes element)++parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse+parseRootElement aliases info@GIRInfoParse{..} element =+ case nameLocalName (elementName element) of+ "include" -> info {girIPIncludes = parseInclude element : girIPIncludes}+ "package" -> info {girIPPackage = parsePackage element : girIPPackage}+ "namespace" -> info {girIPNamespaces = parseNamespace element aliases : girIPNamespaces}+ _ -> info++emptyGIRInfoParse :: GIRInfoParse+emptyGIRInfoParse = GIRInfoParse {+ girIPPackage = [],+ girIPIncludes = [],+ girIPNamespaces = []+ }++parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse+parseGIRDocument aliases doc = L.foldl' (parseRootElement aliases) emptyGIRInfoParse (subelements (documentRoot doc))++-- | Parse the list of includes in a given document.+documentListIncludes :: Document -> S.Set (Text, Text)+documentListIncludes doc = S.fromList (mapMaybe parseInclude includes)+ where includes = childElemsWithLocalName "include" (documentRoot doc)++-- | Load a set of dependencies, recursively.+loadDependencies :: Bool -- ^ Verbose+ -> S.Set (Text, Text) -- ^ Requested+ -> M.Map (Text, Text) Document -- ^ Loaded so far+ -> [FilePath] -- ^ extra path to search+ -> [GIRRule] -- ^ fixups+ -> IO (M.Map (Text, Text) Document) -- ^ New loaded set+loadDependencies verbose requested loaded extraPaths rules+ | S.null requested = return loaded+ | otherwise = do+ let (name, version) = S.elemAt 0 requested+ doc <- fixupGIRDocument rules <$>+ readGiRepository verbose name (Just version) extraPaths+ let newLoaded = M.insert (name, version) doc loaded+ loadedSet = S.fromList (M.keys newLoaded)+ newRequested = S.union requested (documentListIncludes doc)+ notYetLoaded = S.difference newRequested loadedSet+ loadDependencies verbose notYetLoaded newLoaded extraPaths rules++-- | Load a given GIR file and recursively its dependencies+loadGIRFile :: Bool -- ^ verbose+ -> Text -- ^ name+ -> Maybe Text -- ^ version+ -> [FilePath] -- ^ extra paths to search+ -> [GIRRule] -- ^ fixups+ -> IO (Document, -- ^ loaded document+ M.Map (Text, Text) Document) -- ^ dependencies+loadGIRFile verbose name version extraPaths rules = do+ doc <- fixupGIRDocument rules <$>+ readGiRepository verbose name version extraPaths+ deps <- loadDependencies verbose (documentListIncludes doc) M.empty+ extraPaths rules+ return (doc, deps)++-- | Turn a GIRInfoParse into a proper GIRInfo, doing some sanity+-- checking along the way.+toGIRInfo :: GIRInfoParse -> Either Text GIRInfo+toGIRInfo info =+ case catMaybes (girIPNamespaces info) of+ [ns] -> Right GIRInfo {+ girPCPackages = (reverse . catMaybes . girIPPackage) info+ , girNSName = nsName ns+ , girNSVersion = nsVersion ns+ , girAPIs = reverse (nsAPIs ns)+ , girCTypes = M.fromList (nsCTypes ns)+ }+ [] -> Left "Found no valid namespace."+ _ -> Left "Found multiple namespaces."++-- | Bare minimum loading and parsing of a single repository, without+-- loading or parsing its dependencies, resolving aliases, or fixing+-- up structs or interfaces.+loadRawGIRInfo :: Bool -- ^ verbose+ -> Text -- ^ name+ -> Maybe Text -- ^ version+ -> [FilePath] -- ^ extra paths to search+ -> IO GIRInfo -- ^ bare parsed document+loadRawGIRInfo verbose name version extraPaths = do+ doc <- readGiRepository verbose name version extraPaths+ case toGIRInfo (parseGIRDocument M.empty doc) of+ Left err -> error . T.unpack $ "Error when raw parsing \"" <> name <> "\": " <> err+ Right docGIR -> return docGIR++-- | Load and parse a GIR file, including its dependencies.+loadGIRInfo :: Bool -- ^ verbose+ -> Text -- ^ name+ -> Maybe Text -- ^ version+ -> [FilePath] -- ^ extra paths to search+ -> [GIRRule] -- ^ fixups+ -> IO (GIRInfo, -- ^ parsed document+ [GIRInfo]) -- ^ parsed deps+loadGIRInfo verbose name version extraPaths rules = do+ (doc, deps) <- loadGIRFile verbose name version extraPaths rules+ let aliases = M.unions (map documentListAliases (doc : M.elems deps))+ parsedDoc = toGIRInfo (parseGIRDocument aliases doc)+ parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)+ case combineErrors parsedDoc parsedDeps of+ Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err+ Right (docGIR, depsGIR) -> do+ if girNSName docGIR == name+ then do+ forM_ (docGIR : depsGIR) $ \info ->+ girRequire (girNSName info) (girNSVersion info)+ (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR+ return (fixedDoc, fixedDeps)+ else error . T.unpack $ "Got unexpected namespace \""+ <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."+ where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]+ -> Either Text (GIRInfo, [GIRInfo])+ combineErrors parsedDoc parsedDeps = do+ doc <- parsedDoc+ deps <- sequence parsedDeps+ return (doc, deps)++foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType)++-- | List the prerequisites for a 'GType' corresponding to an interface.+gtypeInterfaceListPrereqs :: GType -> IO [Text]+gtypeInterfaceListPrereqs (GType cgtype) = do+ nprereqsPtr <- allocMem :: IO (Ptr CUInt)+ ps <- g_type_interface_prerequisites cgtype nprereqsPtr+ nprereqs <- peek nprereqsPtr+ psCGTypes <- unpackStorableArrayWithLength nprereqs ps+ freeMem ps+ freeMem nprereqsPtr+ mapM (fmap T.pack . gtypeName . GType) psCGTypes++-- | The list of prerequisites in GIR files is not always+-- accurate. Instead of relying on this, we instantiate the 'GType'+-- associated to the interface, and listing the interfaces from there.+fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API)+fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do+ prereqs <- case ifTypeInit iface of+ Nothing -> return []+ Just ti -> do+ gtype <- girLoadGType ns ti+ prereqGTypes <- gtypeInterfaceListPrereqs gtype+ forM prereqGTypes $ \p -> do+ case M.lookup p csymbolMap of+ Just pn -> return pn+ Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n+ return (n, APIInterface (iface {ifPrerequisites = prereqs}))+fixupInterface _ (n, api) = return (n, api)++-- | There is not enough info in the GIR files to determine whether a+-- struct is boxed. We find out by instantiating the 'GType'+-- corresponding to the struct (if known) and checking whether it+-- descends from the boxed GType. Similarly, the size of the struct+-- and offset of the fields is hard to compute from the GIR data, we+-- simply reuse the machinery in libgirepository.+fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API)+fixupStruct _ (n, APIStruct s) = do+ fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s+ return (n, APIStruct fixed)+fixupStruct _ api = return api++-- | Find out whether the struct is boxed.+fixupStructIsBoxed :: Name -> Struct -> IO Struct+-- The type for "GVariant" is marked as "intern", we wrap+-- this one natively.+fixupStructIsBoxed (Name "GLib" "Variant") s =+ return (s {structIsBoxed = False})+fixupStructIsBoxed (Name ns _) s = do+ isBoxed <- case structTypeInit s of+ Nothing -> return False+ Just ti -> do+ gtype <- girLoadGType ns ti+ return (gtypeIsBoxed gtype)+ return (s {structIsBoxed = isBoxed})++-- | Fix the size and alignment of fields. This is much easier to do+-- by using libgirepository than reading the GIR file directly.+fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct+fixupStructSizeAndOffsets (Name ns n) s = do+ (size, offsetMap) <- girStructSizeAndOffsets ns n+ return (s { structSize = size+ , structFields = map (fixupField offsetMap) (structFields s)})++-- | Same thing for unions.+fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API)+fixupUnion _ (n, APIUnion u) = do+ fixed <- (fixupUnionSizeAndOffsets n) u+ return (n, APIUnion fixed)+fixupUnion _ api = return api++-- | Like 'fixupStructSizeAndOffset' above.+fixupUnionSizeAndOffsets :: Name -> Union -> IO Union+fixupUnionSizeAndOffsets (Name ns n) u = do+ (size, offsetMap) <- girUnionSizeAndOffsets ns n+ return (u { unionSize = size+ , unionFields = map (fixupField offsetMap) (unionFields u)})++-- | Fixup the offsets of fields using the given offset map.+fixupField :: M.Map Text Int -> Field -> Field+fixupField offsetMap f =+ f {fieldOffset = case M.lookup (fieldName f) offsetMap of+ Nothing -> error $ "Could not find field "+ ++ show (fieldName f)+ Just o -> o }++-- | Fixup parsed GIRInfos: some of the required information is not+-- found in the GIR files themselves, but can be obtained by+-- instantiating the required GTypes from the installed libraries.+fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])+fixupGIRInfos doc deps = (fixup fixupInterface >=>+ fixup fixupStruct >=>+ fixup fixupUnion) (doc, deps)+ where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API))+ -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])+ fixup fixer (doc, deps) = do+ fixedDoc <- fixAPIs fixer doc+ fixedDeps <- mapM (fixAPIs fixer) deps+ return (fixedDoc, fixedDeps)++ fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo+ fixAPIs fixer info = do+ fixedAPIs <- mapM (fixer ctypes) (girAPIs info)+ return $ info {girAPIs = fixedAPIs}++ ctypes :: M.Map Text Name+ ctypes = M.unions (map girCTypes (doc:deps))++-- | Given a XML document containing GIR data, apply the given overrides.+fixupGIRDocument :: [GIRRule] -> XML.Document -> XML.Document+fixupGIRDocument rules doc =+ doc {XML.documentRoot = fixupGIR rules (XML.documentRoot doc)}++-- | Looks for the given path in the given subelements of the given+-- element. If the path is empty apply the corresponding rule,+-- otherwise return the element ummodified.+fixupGIR :: [GIRRule] -> XML.Element -> XML.Element+fixupGIR rules elem =+ elem {XML.elementNodes = map (\e -> foldr applyGIRRule e rules)+ (XML.elementNodes elem)}+ where applyGIRRule :: GIRRule -> XML.Node -> XML.Node+ applyGIRRule (GIRSetAttr (path, attr) newVal) n =+ girSetAttr (path, attr) newVal n++-- | Set an attribute for the child element specified by the given+-- path.+girSetAttr :: (GIRPath, XML.Name) -> Text -> XML.Node -> XML.Node+girSetAttr (spec:rest, attr) newVal n@(XML.NodeElement elem) =+ if specMatch spec n+ then if null rest -- Matched the full path, apply+ then XML.NodeElement (elem {XML.elementAttributes =+ M.insert attr newVal+ (XML.elementAttributes elem)})+ -- Still some selectors to apply+ else XML.NodeElement (elem {XML.elementNodes =+ map (girSetAttr (rest, attr) newVal)+ (XML.elementNodes elem)})+ else n+girSetAttr _ _ n = n++-- | See if a given node specification applies to the given node.+specMatch :: GIRNodeSpec -> XML.Node -> Bool+specMatch (GIRType t) (XML.NodeElement elem) =+ XML.nameLocalName (XML.elementName elem) == t+specMatch (GIRNamed name) (XML.NodeElement elem) =+ M.lookup (xmlLocalName "name") (XML.elementAttributes elem) == Just name+specMatch (GIRTypedName t name) (XML.NodeElement elem) =+ XML.nameLocalName (XML.elementName elem) == t &&+ M.lookup (xmlLocalName "name") (XML.elementAttributes elem) == Just name+specMatch _ _ = False
+ lib/Data/GI/CodeGen/Cabal.hs view
@@ -0,0 +1,184 @@+module Data.GI.CodeGen.Cabal+ ( genCabalProject+ , cabalConfig+ , setupHs+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (fromMaybe)+import Data.Version (Version(..))+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)+import Text.Read++import Data.GI.CodeGen.API (GIRInfo(..))+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Config (Config(..))+import Data.GI.CodeGen.Overrides (pkgConfigMap, cabalPkgVersion)+import Data.GI.CodeGen.PkgConfig (pkgConfigGetVersion)+import Data.GI.CodeGen.ProjectInfo (homepage, license, authors, maintainers)+import Data.GI.CodeGen.Util (padTo, tshow)++import Paths_haskell_gi (version)++cabalConfig :: Text+cabalConfig = T.unlines ["optimization: False"]++setupHs :: Text+setupHs = T.unlines ["#!/usr/bin/env runhaskell",+ "import Distribution.Simple",+ "main = defaultMain"]++haskellGIAPIVersion :: Int+haskellGIAPIVersion = (head . versionBranch) version++-- | Obtain the minor version. That is, if the given version numbers+-- are x.y.z, so branch is [x,y,z], we return y.+minorVersion :: [Int] -> Int+minorVersion (_:y:_) = y+minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "."++-- | Obtain the haskell-gi minor version. Notice that we only append+-- the minor version here, ignoring revisions. (So if the version is+-- x.y.z, we drop the "z" part.) This gives us a mechanism for+-- releasing bug-fix releases of haskell-gi without increasing the+-- necessary dependency on haskell-gi-base, which only depends on x.y.+haskellGIMinor :: Int+haskellGIMinor = minorVersion (versionBranch version)++{- |++If the haskell-gi version is of the form x.y[.z] and the pkgconfig+version of the package being wrapped is a.b.c, this gives something of+the form x.a.b.y.++This strange seeming-rule is so that the packages that we produce+follow the PVP, assuming that the package being wrapped follows the+usual semantic versioning convention (http://semver.org) that+increases in "a" indicate non-backwards compatible changes, increases+in "b" backwards compatible additions to the API, and increases in "c"+denote API compatible changes (so we do not need to regenerate+bindings for these, at least in principle, so we do not encode them in+the cabal version).++In order to follow the PVP, then everything we need to do in the+haskell-gi side is to increase x everytime the generated API changes+(for a fixed a.b.c version).++In any case, if such "strange" package numbers are undesired, or the+wrapped package does not follow semver, it is possible to add an+explicit cabal-pkg-version override. This needs to be maintained by+hand (including in the list of dependencies of packages depending on+this one), so think carefully before using this override!++-}+giModuleVersion :: Int -> Int -> Text+giModuleVersion major minor =+ (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor,+ haskellGIMinor]++-- | Determine the next version for which the minor of the package has+-- been bumped.+giNextMinor :: Int -> Int -> Text+giNextMinor major minor = (T.intercalate "." . map tshow)+ [haskellGIAPIVersion, major, minor+1]++-- | Determine the pkg-config name and installed version (major.minor+-- only) for a given module, or throw an exception if that fails.+tryPkgConfig :: Text -> Text -> [Text] -> Bool+ -> M.Map Text Text+ -> ExcCodeGen (Text, Int, Int)+tryPkgConfig name version packages verbose overridenNames =+ liftIO (pkgConfigGetVersion name version packages verbose overridenNames) >>= \case+ Just (n,v) ->+ case readMajorMinor v of+ Just (major, minor) -> return (n, major, minor)+ Nothing -> notImplementedError $+ "Cannot parse version \""+ <> v <> "\" for module " <> name+ Nothing -> missingInfoError $+ "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <>+ "Try adding an override with the proper package name:\n"+ <> "pkg-config-name " <> name <> " [matching pkg-config name here]"++-- | Given a string a.b.c..., representing a version number, determine+-- the major and minor versions, i.e. "a" and "b". If successful,+-- return (a,b).+readMajorMinor :: Text -> Maybe (Int, Int)+readMajorMinor version =+ case T.splitOn "." version of+ (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b)+ _ -> Nothing++-- | Try to generate the cabal project. In case of error return the+-- corresponding error string.+genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> BaseVersion ->+ CodeGen (Maybe Text)+genCabalProject gir deps exposedModules minBaseVersion =+ handleCGExc (return . Just . describeCGError) $ do+ cfg <- config+ let pkMap = pkgConfigMap (overrides cfg)+ name = girNSName gir+ pkgVersion = girNSVersion gir+ packages = girPCPackages gir++ line $ "-- Autogenerated, do not edit."+ line $ padTo 20 "name:" <> "gi-" <> T.toLower name+ (pcName, major, minor) <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap+ let cabalVersion = fromMaybe (giModuleVersion major minor)+ (cabalPkgVersion $ overrides cfg)+ line $ padTo 20 "version:" <> cabalVersion+ line $ padTo 20 "synopsis:" <> name+ <> " bindings"+ line $ padTo 20 "description:" <> "Bindings for " <> name+ <> ", autogenerated by haskell-gi."+ line $ padTo 20 "homepage:" <> homepage+ line $ padTo 20 "license:" <> license+ line $ padTo 20 "license-file:" <> "LICENSE"+ line $ padTo 20 "author:" <> authors+ line $ padTo 20 "maintainer:" <> maintainers+ line $ padTo 20 "category:" <> "Bindings"+ line $ padTo 20 "build-type:" <> "Simple"+ line $ padTo 20 "cabal-version:" <> ">=1.10"+ blank+ line $ "library"+ indent $ do+ line $ padTo 20 "default-language:" <> "Haskell2010"+ line $ padTo 20 "default-extensions:" <> "NoImplicitPrelude, ScopedTypeVariables, CPP, OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts"+ line $ padTo 20 "other-extensions:" <> "PatternSynonyms ViewPatterns"+ line $ padTo 20 "ghc-options:" <> "-fno-warn-unused-imports -fno-warn-warnings-deprecations"+ line $ padTo 20 "exposed-modules:" <> head exposedModules+ forM_ (tail exposedModules) $ \mod ->+ line $ padTo 20 "" <> mod+ line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= "+ <> tshow major <> "." <> tshow minor+ line $ padTo 20 "build-depends: base >= "+ <> showBaseVersion minBaseVersion <> " && <5,"+ indent $ do+ line $ "haskell-gi-base >= "+ <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor+ <> " && < " <> tshow (haskellGIAPIVersion + 1) <> ","+ forM_ deps $ \dep -> do+ let depName = girNSName dep+ depVersion = girNSVersion dep+ depPackages = girPCPackages dep+ (_, depMajor, depMinor) <- tryPkgConfig depName depVersion+ depPackages (verbose cfg) pkMap+ line $ "gi-" <> T.toLower depName <> " >= "+ <> giModuleVersion depMajor depMinor+ <> " && < "+ <> giNextMinor depMajor depMinor+ <> ","+ -- Our usage of these is very basic, no reason to put any+ -- strong upper bounds.+ line "bytestring >= 0.10,"+ line "containers >= 0.5,"+ line "text >= 1.0,"+ line "transformers >= 0.3"++ return Nothing -- successful generation, no error
+ lib/Data/GI/CodeGen/CabalHooks.hs view
@@ -0,0 +1,63 @@+-- | Convenience hooks for writing custom @Setup.hs@ files for+-- bindings.+module Data.GI.CodeGen.CabalHooks+ ( confCodeGenHook+ ) where++import qualified Distribution.ModuleName as MN+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup+import Distribution.PackageDescription++import Data.GI.CodeGen.API (loadGIRInfo)+import Data.GI.CodeGen.Code (genCode, writeModuleTree)+import Data.GI.CodeGen.CodeGen (genModule)+import Data.GI.CodeGen.Config (Config(..))+import Data.GI.CodeGen.Overrides (parseOverridesFile, girFixups,+ filterAPIsAndDeps)+import Data.GI.CodeGen.Util (ucFirst)++import Data.Maybe (fromJust)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++type ConfHook = (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags+ -> IO LocalBuildInfo++-- | A convenience helper for `confHook`, such that bindings for the+-- given module are generated in the @configure@ step of @cabal@.+confCodeGenHook :: Text -- ^ name+ -> Text -- ^ version+ -> Bool -- ^ verbose+ -> Maybe FilePath -- ^ overrides file+ -> Maybe FilePath -- ^ output dir+ -> ConfHook -- ^ previous `confHook`+ -> ConfHook+confCodeGenHook name version verbosity overrides outputDir+ defaultConfHook (gpd, hbi) flags = do+ ovsData <- case overrides of+ Nothing -> return ""+ Just fname -> TIO.readFile fname+ ovs <- parseOverridesFile (T.lines ovsData) >>= \case+ Left err -> error $ "Error when parsing overrides file: "+ ++ T.unpack err+ Right ovs -> return ovs++ (gir, girDeps) <- loadGIRInfo verbosity name (Just version) [] (girFixups ovs)+ let (apis, deps) = filterAPIsAndDeps ovs gir girDeps+ allAPIs = M.union apis deps+ cfg = Config {modName = Just name,+ verbose = verbosity,+ overrides = ovs}++ m <- genCode cfg allAPIs ["GI", ucFirst name] (genModule apis)+ moduleList <- writeModuleTree verbosity outputDir m++ let em' = map (MN.fromString . T.unpack) moduleList+ ctd' = ((condTreeData . fromJust . condLibrary) gpd) {exposedModules = em'}+ cL' = ((fromJust . condLibrary) gpd) {condTreeData = ctd'}+ gpd' = gpd {condLibrary = Just cL'}++ defaultConfHook (gpd', hbi) flags
+ lib/Data/GI/CodeGen/Callable.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE LambdaCase #-}+module Data.GI.CodeGen.Callable+ ( genCallable++ , hOutType+ , arrayLengths+ , arrayLengthsMap+ , callableSignature+ , fixupCallerAllocates++ , wrapMaybe+ , inArgInterfaces+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM, forM_, when)+import Data.Bool (bool)+import Data.List (nub, (\\))+import Data.Maybe (isJust)+import Data.Tuple (swap)+import Data.Typeable (TypeRep, typeOf)+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Text (Text)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.Transfer+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util++import Text.Show.Pretty (ppShow)++hOutType :: Callable -> [Arg] -> Bool -> ExcCodeGen TypeRep+hOutType callable outArgs ignoreReturn = do+ hReturnType <- case returnType callable of+ Nothing -> return $ typeOf ()+ Just r -> if ignoreReturn+ then return $ typeOf ()+ else haskellType r+ hOutArgTypes <- forM outArgs $ \outarg ->+ wrapMaybe outarg >>= bool+ (haskellType (argType outarg))+ (maybeT <$> haskellType (argType outarg))+ nullableReturnType <- maybe (return False) typeIsNullable (returnType callable)+ let maybeHReturnType = if returnMayBeNull callable && not ignoreReturn+ && nullableReturnType+ then maybeT hReturnType+ else hReturnType+ return $ case (outArgs, tshow maybeHReturnType) of+ ([], _) -> maybeHReturnType+ (_, "()") -> "(,)" `con` hOutArgTypes+ _ -> "(,)" `con` (maybeHReturnType : hOutArgTypes)++mkForeignImport :: Text -> Callable -> Bool -> CodeGen ()+mkForeignImport symbol callable throwsGError = do+ line first+ indent $ do+ mapM_ (\a -> line =<< fArgStr a) (args callable)+ when throwsGError $+ line $ padTo 40 "Ptr (Ptr GError) -> " <> "-- error"+ line =<< last+ where+ first = "foreign import ccall \"" <> symbol <> "\" " <>+ symbol <> " :: "+ fArgStr arg = do+ ft <- foreignType $ argType arg+ weAlloc <- isJust <$> requiresAlloc (argType arg)+ let ft' = if direction arg == DirectionIn || weAlloc+ || argCallerAllocates arg+ then+ ft+ else+ ptr ft+ let start = tshow ft' <> " -> "+ return $ padTo 40 start <> "-- " <> (argCName arg)+ <> " : " <> tshow (argType arg)+ last = tshow <$> io <$> case returnType callable of+ Nothing -> return $ typeOf ()+ Just r -> foreignType r++-- | Given an argument to a function, return whether it should be+-- wrapped in a maybe type (useful for nullable types). We do some+-- sanity checking to make sure that the argument is actually nullable+-- (a relatively common annotation mistake is to mix up (optional)+-- with (nullable)).+wrapMaybe :: Arg -> CodeGen Bool+wrapMaybe arg = if mayBeNull arg+ then typeIsNullable (argType arg)+ else return False++-- Given the list of arguments returns the list of constraints and the+-- list of types in the signature.+inArgInterfaces :: [Arg] -> ExcCodeGen ([Text], [Text])+inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs+ where+ consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([Text], [Text])+ consAndTypes _ [] = return ([], [])+ consAndTypes letters (arg:args) = do+ (ls, t, cons) <- argumentType letters $ argType arg+ t' <- wrapMaybe arg >>= bool (return t)+ (return $ "Maybe (" <> t <> ")")+ (restCons, restTypes) <- consAndTypes ls args+ return (cons <> restCons, t' : restTypes)++-- Given a callable, return a list of (array, length) pairs, where in+-- each pair "length" is the argument holding the length of the+-- (non-zero-terminated, non-fixed size) C array.+arrayLengthsMap :: Callable -> [(Arg, Arg)] -- List of (array, length)+arrayLengthsMap callable = go (args callable) []+ where+ go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]+ go [] acc = acc+ go (a:as) acc = case argType a of+ TCArray False fixedSize length _ ->+ if fixedSize > -1 || length == -1+ then go as acc+ else go as $ (a, (args callable)!!length) : acc+ _ -> go as acc++-- Return the list of arguments of the callable that contain length+-- arguments, including a possible length for the result of calling+-- the function.+arrayLengths :: Callable -> [Arg]+arrayLengths callable = map snd (arrayLengthsMap callable) <>+ -- Often one of the arguments is just the length of+ -- the result.+ case returnType callable of+ Just (TCArray False (-1) length _) ->+ if length > -1+ then [(args callable)!!length]+ else []+ _ -> []++-- This goes through a list of [(a,b)], and tags every entry where the+-- "b" field has occurred before with the value of "a" for which it+-- occurred. (The first appearance is not tagged.)+classifyDuplicates :: Ord b => [(a, b)] -> [(a, b, Maybe a)]+classifyDuplicates args = doClassify Map.empty args+ where doClassify :: Ord b => Map.Map b a -> [(a, b)] -> [(a, b, Maybe a)]+ doClassify _ [] = []+ doClassify found ((value, key):args) =+ (value, key, Map.lookup key found) :+ doClassify (Map.insert key value found) args++-- Read the length of in array arguments from the corresponding+-- Haskell objects. A subtlety is that sometimes a single length+-- argument is expected from the C side to encode the length of+-- various lists. Ideally we would encode this in the types, but the+-- resulting API would be rather cumbersome. We insted perform runtime+-- checks to make sure that the given lists have the same length.+readInArrayLengths :: Name -> Callable -> [Arg] -> ExcCodeGen ()+readInArrayLengths name callable hInArgs = do+ let lengthMaps = classifyDuplicates $ arrayLengthsMap callable+ forM_ lengthMaps $ \(array, length, duplicate) ->+ when (array `elem` hInArgs) $+ case duplicate of+ Nothing -> readInArrayLength array length+ Just previous -> checkInArrayLength name array length previous++-- Read the length of an array into the corresponding variable.+readInArrayLength :: Arg -> Arg -> ExcCodeGen ()+readInArrayLength array length = do+ let lvar = escapedArgName length+ avar = escapedArgName array+ wrapMaybe array >>= bool+ (do+ al <- computeArrayLength avar (argType array)+ line $ "let " <> lvar <> " = " <> al)+ (do+ line $ "let " <> lvar <> " = case " <> avar <> " of"+ indent $ indent $ do+ line $ "Nothing -> 0"+ let jarray = "j" <> ucFirst avar+ al <- computeArrayLength jarray (argType array)+ line $ "Just " <> jarray <> " -> " <> al)++-- Check that the given array has a length equal to the given length+-- variable.+checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen ()+checkInArrayLength n array length previous = do+ let name = lowerName n+ funcName = namespace n <> "." <> name+ lvar = escapedArgName length+ avar = escapedArgName array+ expectedLength = avar <> "_expected_length_"+ pvar = escapedArgName previous+ wrapMaybe array >>= bool+ (do+ al <- computeArrayLength avar (argType array)+ line $ "let " <> expectedLength <> " = " <> al)+ (do+ line $ "let " <> expectedLength <> " = case " <> avar <> " of"+ indent $ indent $ do+ line $ "Nothing -> 0"+ let jarray = "j" <> ucFirst avar+ al <- computeArrayLength jarray (argType array)+ line $ "Just " <> jarray <> " -> " <> al)+ line $ "when (" <> expectedLength <> " /= " <> lvar <> ") $"+ indent $ line $ "error \"" <> funcName <> " : length of '" <> avar <>+ "' does not agree with that of '" <> pvar <> "'.\""++-- Whether to skip the return value in the generated bindings. The+-- C convention is that functions throwing an error and returning+-- a gboolean set the boolean to TRUE iff there is no error, so+-- the information is always implicit in whether we emit an+-- exception or not, so the return value can be omitted from the+-- generated bindings without loss of information (and omitting it+-- gives rise to a nicer API). See+-- https://bugzilla.gnome.org/show_bug.cgi?id=649657+skipRetVal :: Callable -> Bool -> Bool+skipRetVal callable throwsGError =+ (skipReturn callable) ||+ (throwsGError && returnType callable == Just (TBasicType TBoolean))++freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text]) ->+ Callable -> Map.Map Text Text -> ExcCodeGen [Text]+freeInArgs' freeFn callable nameMap = concat <$> actions+ where+ actions :: ExcCodeGen [[Text]]+ actions = forM (args callable) $ \arg ->+ case Map.lookup (escapedArgName arg) nameMap of+ Just name -> freeFn arg name $+ -- Pass in the length argument in case it's needed.+ case argType arg of+ TCArray False (-1) (-1) _ -> undefined+ TCArray False (-1) length _ ->+ escapedArgName $ (args callable)!!length+ _ -> undefined+ Nothing -> badIntroError $ "freeInArgs: do not understand " <> tshow arg++-- Return the list of actions freeing the memory associated with the+-- callable variables. This is run if the call to the C function+-- succeeds, if there is an error freeInArgsOnError below is called+-- instead.+freeInArgs = freeInArgs' freeInArg++-- Return the list of actions freeing the memory associated with the+-- callable variables. This is run in case there is an error during+-- the call.+freeInArgsOnError = freeInArgs' freeInArgOnError++-- Marshall the haskell arguments into their corresponding C+-- equivalents. omitted gives a list of DirectionIn arguments that+-- should be ignored, as they will be dealt with separately.+prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen Text+prepareArgForCall omitted arg = do+ isCallback <- findAPI (argType arg) >>=+ \case Just (APICallback _) -> return True+ _ -> return False+ when (isCallback && direction arg /= DirectionIn) $+ notImplementedError "Only callbacks with DirectionIn are supported"++ case direction arg of+ DirectionIn -> if arg `elem` omitted+ then return . escapedArgName $ arg+ else if isCallback+ then prepareInCallback arg+ else prepareInArg arg+ DirectionInout -> prepareInoutArg arg+ DirectionOut -> prepareOutArg arg++prepareInArg :: Arg -> ExcCodeGen Text+prepareInArg arg = do+ let name = escapedArgName arg+ wrapMaybe arg >>= bool+ (convert name $ hToF (argType arg) (transfer arg))+ (do+ let maybeName = "maybe" <> ucFirst name+ line $ maybeName <> " <- case " <> name <> " of"+ indent $ do+ line $ "Nothing -> return nullPtr"+ let jName = "j" <> ucFirst name+ line $ "Just " <> jName <> " -> do"+ indent $ do+ converted <- convert jName $ hToF (argType arg)+ (transfer arg)+ line $ "return " <> converted+ return maybeName)++-- Callbacks are a fairly special case, we treat them separately.+prepareInCallback :: Arg -> ExcCodeGen Text+prepareInCallback arg = do+ let name = escapedArgName arg+ ptrName = "ptr" <> name+ scope = argScope arg++ (maker, wrapper) <- case argType arg of+ (TInterface ns n) ->+ do+ prefix <- qualify ns+ return $ (prefix <> "mk" <> n,+ prefix <> lcFirst n <> "Wrapper")+ _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg)++ when (scope == ScopeTypeAsync) $ do+ ft <- tshow <$> foreignType (argType arg)+ line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))"++ wrapMaybe arg >>= bool+ (do+ let name' = prime name+ p = if (scope == ScopeTypeAsync)+ then parenthesize $ "Just " <> ptrName+ else "Nothing"+ line $ name' <> " <- " <> maker <> " "+ <> parenthesize (wrapper <> " " <> p <> " " <> name)+ when (scope == ScopeTypeAsync) $+ line $ "poke " <> ptrName <> " " <> name'+ return name')+ (do+ let maybeName = "maybe" <> ucFirst name+ line $ maybeName <> " <- case " <> name <> " of"+ indent $ do+ line $ "Nothing -> return (castPtrToFunPtr nullPtr)"+ let jName = "j" <> ucFirst name+ jName' = prime jName+ line $ "Just " <> jName <> " -> do"+ indent $ do+ let p = if (scope == ScopeTypeAsync)+ then parenthesize $ "Just " <> ptrName+ else "Nothing"+ line $ jName' <> " <- " <> maker <> " "+ <> parenthesize (wrapper <> " "+ <> p <> " " <> jName)+ when (scope == ScopeTypeAsync) $+ line $ "poke " <> ptrName <> " " <> jName'+ line $ "return " <> jName'+ return maybeName)++prepareInoutArg :: Arg -> ExcCodeGen Text+prepareInoutArg arg = do+ name' <- prepareInArg arg+ ft <- foreignType $ argType arg+ allocInfo <- requiresAlloc (argType arg)+ case allocInfo of+ Just (isBoxed, n) -> do+ let allocator = if isBoxed+ then "callocBoxedBytes"+ else "callocBytes"+ wrapMaybe arg >>= bool+ (do+ name'' <- genConversion (prime name') $+ literal $ M $ allocator <> " " <> tshow n <>+ " :: " <> tshow (io ft)+ line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n+ return name'')+ -- The semantics of this case are somewhat undefined.+ (notImplementedError "Nullable inout structs not supported")+ Nothing -> do+ if argCallerAllocates arg+ then return name'+ else do+ name'' <- genConversion (prime name') $+ literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)+ line $ "poke " <> name'' <> " " <> name'+ return name''++prepareOutArg :: Arg -> CodeGen Text+prepareOutArg arg = do+ let name = escapedArgName arg+ ft <- foreignType $ argType arg+ allocInfo <- requiresAlloc (argType arg)+ case allocInfo of+ Just (isBoxed, n) -> do+ let allocator = if isBoxed+ then "callocBoxedBytes"+ else "callocBytes"+ genConversion name $ literal $ M $ allocator <> " " <> tshow n <>+ " :: " <> tshow (io ft)+ Nothing ->+ genConversion name $+ literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)++-- Convert a non-zero terminated out array, stored in a variable+-- named "aname", into the corresponding Haskell object.+convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text ->+ Transfer -> (Text -> Text) -> ExcCodeGen Text+convertOutCArray callable t@(TCArray False fixed length _) aname+ nameMap transfer primeLength = do+ if fixed > -1+ then do+ unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer+ -- Free the memory associated with the array+ freeContainerType transfer t aname undefined+ return unpacked+ else do+ when (length == -1) $+ badIntroError $ "Unknown length for \"" <> aname <> "\""+ let lname = escapedArgName $ (args callable)!!length+ lname' <- case Map.lookup lname nameMap of+ Just n -> return n+ Nothing ->+ badIntroError $ "Couldn't find out array length " <>+ lname+ let lname'' = primeLength lname'+ unpacked <- convert aname $ unpackCArray lname'' t transfer+ -- Free the memory associated with the array+ freeContainerType transfer t aname lname''+ return unpacked++-- Remove the warning, this should never be reached.+convertOutCArray _ t _ _ _ _ =+ terror $ "convertOutCArray : unexpected " <> tshow t++-- Read the array lengths for out arguments.+readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen ()+readOutArrayLengths callable nameMap = do+ let lNames = nub $ map escapedArgName $+ filter ((/= DirectionIn) . direction) $+ arrayLengths callable+ forM_ lNames $ \lname -> do+ lname' <- case Map.lookup lname nameMap of+ Just n -> return n+ Nothing ->+ badIntroError $ "Couldn't find out array length " <>+ lname+ genConversion lname' $ apply $ M "peek"++-- Touch DirectionIn arguments so we are sure that they exist when the+-- C function was called.+touchInArg :: Arg -> ExcCodeGen ()+touchInArg arg = when (direction arg /= DirectionOut) $ do+ let name = escapedArgName arg+ case elementType (argType arg) of+ Just a -> do+ managed <- isManaged a+ when managed $ wrapMaybe arg >>= bool+ (line $ "mapM_ touchManagedPtr " <> name)+ (line $ "whenJust " <> name <> " (mapM_ touchManagedPtr)")+ Nothing -> do+ managed <- isManaged (argType arg)+ when managed $ wrapMaybe arg >>= bool+ (line $ "touchManagedPtr " <> name)+ (line $ "whenJust " <> name <> " touchManagedPtr")++-- Find the association between closure arguments and their+-- corresponding callback.+closureToCallbackMap :: Callable -> ExcCodeGen (Map.Map Int Arg)+closureToCallbackMap callable =+ -- The introspection info does not specify the closure for destroy+ -- notify's associated with a callback, since it is implicitly the+ -- same one as the ScopeTypeNotify callback associated with the+ -- DestroyNotify.+ go (filter (not . (`elem` destroyers)) $ args callable) Map.empty++ where destroyers = map (args callable!!) . filter (/= -1) . map argDestroy+ $ args callable++ go :: [Arg] -> Map.Map Int Arg -> ExcCodeGen (Map.Map Int Arg)+ go [] m = return m+ go (arg:as) m =+ if argScope arg == ScopeTypeInvalid+ then go as m+ else case argClosure arg of+ (-1) -> go as m+ c -> case Map.lookup c m of+ Just _ -> notImplementedError $+ "Closure for multiple callbacks unsupported"+ <> T.pack (ppShow arg) <> "\n"+ <> T.pack (ppShow callable)+ Nothing -> go as $ Map.insert c arg m++-- user_data style arguments.+prepareClosures :: Callable -> Map.Map Text Text -> ExcCodeGen ()+prepareClosures callable nameMap = do+ m <- closureToCallbackMap callable+ let closures = filter (/= -1) . map argClosure $ args callable+ forM_ closures $ \closure ->+ case Map.lookup closure m of+ Nothing -> badIntroError $ "Closure not found! "+ <> T.pack (ppShow callable)+ <> "\n" <> T.pack (ppShow m)+ <> "\n" <> tshow closure+ Just cb -> do+ let closureName = escapedArgName $ (args callable)!!closure+ n = escapedArgName cb+ n' <- case Map.lookup n nameMap of+ Just n -> return n+ Nothing -> badIntroError $ "Cannot find closure name!! "+ <> T.pack (ppShow callable) <> "\n"+ <> T.pack (ppShow nameMap)+ case argScope cb of+ ScopeTypeInvalid -> badIntroError $ "Invalid scope! "+ <> T.pack (ppShow callable)+ ScopeTypeNotified -> do+ line $ "let " <> closureName <> " = castFunPtrToPtr " <> n'+ case argDestroy cb of+ (-1) -> badIntroError $+ "ScopeTypeNotified without destructor! "+ <> T.pack (ppShow callable)+ k -> let destroyName =+ escapedArgName $ (args callable)!!k in+ line $ "let " <> destroyName <> " = safeFreeFunPtrPtr"+ ScopeTypeAsync ->+ line $ "let " <> closureName <> " = nullPtr"+ ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr"++freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen ()+freeCallCallbacks callable nameMap =+ forM_ (args callable) $ \arg -> do+ let name = escapedArgName arg+ name' <- case Map.lookup name nameMap of+ Just n -> return n+ Nothing -> badIntroError $ "Could not find " <> name+ <> " in " <> T.pack (ppShow callable) <> "\n"+ <> T.pack (ppShow nameMap)+ when (argScope arg == ScopeTypeCall) $+ line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name'++formatHSignature :: Callable -> Bool -> ExcCodeGen ()+formatHSignature callable throwsGError = do+ (constraints, vars) <- callableSignature callable throwsGError+ indent $ do+ line $ "(" <> T.intercalate ", " constraints <> ") =>"+ forM_ (zip ("" : repeat "-> ") vars) $ \(prefix, (t, name)) ->+ line $ withComment (prefix <> t) name++-- | The Haskell signature for the given callable. It returns a tuple+-- ([constraints], [(type, argname)]).+callableSignature :: Callable -> Bool -> ExcCodeGen ([Text], [(Text, Text)])+callableSignature callable throwsGError = do+ let (hInArgs, _) = callableHInArgs callable+ (argConstraints, types) <- inArgInterfaces hInArgs+ let constraints = ("MonadIO m" : argConstraints)+ ignoreReturn = skipRetVal callable throwsGError+ outType <- hOutType callable (callableHOutArgs callable) ignoreReturn+ let allNames = map escapedArgName hInArgs ++ ["result"]+ allTypes = types ++ [tshow ("m" `con` [outType])]+ return (constraints, zip allTypes allNames)++-- | "In" arguments for the given callable on the Haskell side,+-- together with the omitted arguments.+callableHInArgs :: Callable -> ([Arg], [Arg])+callableHInArgs callable =+ let inArgs = filter ((/= DirectionOut) . direction) $ args callable+ -- We do not expose user_data arguments,+ -- destroynotify arguments, and C array length+ -- arguments to Haskell code.+ closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs+ destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs+ omitted = arrayLengths callable <> closures <> destroyers+ in (filter (`notElem` omitted) inArgs, omitted)++-- | "Out" arguments for the given callable on the Haskell side.+callableHOutArgs :: Callable -> [Arg]+callableHOutArgs callable =+ let outArgs = filter ((/= DirectionIn) . direction) $ args callable+ in filter (`notElem` (arrayLengths callable)) outArgs++-- | Convert the result of the foreign call to Haskell.+convertResult :: Callable -> Text -> Bool -> Map.Map Text Text ->+ ExcCodeGen Text+convertResult callable symbol ignoreReturn nameMap =+ if ignoreReturn || returnType callable == Nothing+ then return (error "convertResult: unreachable code reached, bug!")+ else do+ nullableReturnType <- maybe (return False) typeIsNullable (returnType callable)+ if returnMayBeNull callable && nullableReturnType+ then do+ line $ "maybeResult <- convertIfNonNull result $ \\result' -> do"+ indent $ do+ converted <- unwrappedConvertResult "result'"+ line $ "return " <> converted+ return "maybeResult"+ else do+ when nullableReturnType $+ line $ "checkUnexpectedReturnNULL \"" <> symbol+ <> "\" result"+ unwrappedConvertResult "result"++ where+ unwrappedConvertResult rname =+ case returnType callable of+ -- Arrays without length information are just passed+ -- along.+ Just (TCArray False (-1) (-1) _) -> return rname+ -- Not zero-terminated C arrays require knowledge of the+ -- length, so we deal with them directly.+ Just (t@(TCArray False _ _ _)) ->+ convertOutCArray callable t rname nameMap+ (returnTransfer callable) prime+ Just t -> do+ result <- convert rname $ fToH t (returnTransfer callable)+ freeContainerType (returnTransfer callable) t rname undefined+ return result+ Nothing -> return (error "unwrappedConvertResult: bug!")++-- | Marshal a foreign out argument to Haskell, returning the name of+-- the variable containing the converted Haskell value.+convertOutArg :: Callable -> Map.Map Text Text -> Arg -> ExcCodeGen Text+convertOutArg callable nameMap arg = do+ let name = escapedArgName arg+ inName <- case Map.lookup name nameMap of+ Just name' -> return name'+ Nothing -> badIntroError $ "Parameter " <> name <> " not found!"+ case argType arg of+ -- Passed along as a raw pointer+ TCArray False (-1) (-1) _ ->+ if argCallerAllocates arg+ then return inName+ else genConversion inName $ apply $ M "peek"+ t@(TCArray False _ _ _) -> do+ aname' <- if argCallerAllocates arg+ then return inName+ else genConversion inName $ apply $ M "peek"+ let arrayLength = if argCallerAllocates arg+ then id+ else prime+ wrapArray a = convertOutCArray callable t a+ nameMap (transfer arg) arrayLength+ wrapMaybe arg >>= bool+ (wrapArray aname')+ (do line $ "maybe" <> ucFirst aname'+ <> " <- convertIfNonNull " <> aname'+ <> " $ \\" <> prime aname' <> " -> do"+ indent $ do+ wrapped <- wrapArray (prime aname')+ line $ "return " <> wrapped+ return $ "maybe" <> ucFirst aname')+ t -> do+ weAlloc <- isJust <$> requiresAlloc t+ peeked <- if weAlloc || argCallerAllocates arg+ then return inName+ else genConversion inName $ apply $ M "peek"+ -- If we alloc we always take control of the resulting+ -- memory, otherwise we may leak.+ let transfer' = if weAlloc || argCallerAllocates arg+ then TransferEverything+ else transfer arg+ result <- do+ let wrap ptr = convert ptr $ fToH (argType arg) transfer'+ wrapMaybe arg >>= bool+ (wrap peeked)+ (do line $ "maybe" <> ucFirst peeked+ <> " <- convertIfNonNull " <> peeked+ <> " $ \\" <> prime peeked <> " -> do"+ indent $ do+ wrapped <- wrap (prime peeked)+ line $ "return " <> wrapped+ return $ "maybe" <> ucFirst peeked)+ -- Free the memory associated with the out argument+ freeContainerType transfer' t peeked undefined+ return result++-- | Convert the list of out arguments to Haskell, returning the+-- names of the corresponding variables containing the marshaled values.+convertOutArgs :: Callable -> Map.Map Text Text -> [Arg] -> ExcCodeGen [Text]+convertOutArgs callable nameMap hOutArgs =+ forM hOutArgs (convertOutArg callable nameMap)++-- | Invoke the given C function, taking care of errors.+invokeCFunction :: Callable -> Text -> Bool -> Bool -> [Text] -> CodeGen ()+invokeCFunction callable symbol throwsGError ignoreReturn argNames = do+ let returnBind = case returnType callable of+ Nothing -> ""+ _ -> if ignoreReturn+ then "_ <- "+ else "result <- "+ maybeCatchGErrors = if throwsGError+ then "propagateGError $ "+ else ""+ line $ returnBind <> maybeCatchGErrors+ <> symbol <> (T.concat . map (" " <>)) argNames++-- | Return the result of the call, possibly including out arguments.+returnResult :: Callable -> Bool -> Text -> [Text] -> CodeGen ()+returnResult callable ignoreReturn result pps =+ if ignoreReturn || returnType callable == Nothing+ then case pps of+ [] -> line "return ()"+ (pp:[]) -> line $ "return " <> pp+ _ -> line $ "return (" <> T.intercalate ", " pps <> ")"+ else case pps of+ [] -> line $ "return " <> result+ _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")"++-- | Generate a Haskell wrapper for the given foreign function.+genHaskellWrapper :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()+genHaskellWrapper n symbol callable throwsGError = group $ do+ let name = lowerName n+ (hInArgs, omitted) = callableHInArgs callable+ hOutArgs = callableHOutArgs callable+ ignoreReturn = skipRetVal callable throwsGError++ line $ name <> " ::"+ formatHSignature callable ignoreReturn+ line $ name <> " " <> T.intercalate " " (map escapedArgName hInArgs) <> " = liftIO $ do"+ indent (genWrapperBody n symbol callable throwsGError+ ignoreReturn hInArgs hOutArgs omitted)++-- | Generate the body of the Haskell wrapper for the given foreign symbol.+genWrapperBody :: Name -> Text -> Callable -> Bool ->+ Bool -> [Arg] -> [Arg] -> [Arg] ->+ ExcCodeGen ()+genWrapperBody n symbol callable throwsGError+ ignoreReturn hInArgs hOutArgs omitted = do+ readInArrayLengths n callable hInArgs+ inArgNames <- forM (args callable) $ \arg ->+ prepareArgForCall omitted arg+ -- Map from argument names to names passed to the C function+ let nameMap = Map.fromList $ flip zip inArgNames+ $ map escapedArgName $ args callable+ prepareClosures callable nameMap+ if throwsGError+ then do+ line "onException (do"+ indent $ do+ invokeCFunction callable symbol throwsGError+ ignoreReturn inArgNames+ readOutArrayLengths callable nameMap+ result <- convertResult callable symbol ignoreReturn nameMap+ pps <- convertOutArgs callable nameMap hOutArgs+ freeCallCallbacks callable nameMap+ forM_ (args callable) touchInArg+ mapM_ line =<< freeInArgs callable nameMap+ returnResult callable ignoreReturn result pps+ line " ) (do"+ indent $ do+ freeCallCallbacks callable nameMap+ actions <- freeInArgsOnError callable nameMap+ case actions of+ [] -> line $ "return ()"+ _ -> mapM_ line actions+ line " )"+ else do+ invokeCFunction callable symbol throwsGError+ ignoreReturn inArgNames+ readOutArrayLengths callable nameMap+ result <- convertResult callable symbol ignoreReturn nameMap+ pps <- convertOutArgs callable nameMap hOutArgs+ freeCallCallbacks callable nameMap+ forM_ (args callable) touchInArg+ mapM_ line =<< freeInArgs callable nameMap+ returnResult callable ignoreReturn result pps++-- | caller-allocates arguments are arguments that the caller+-- allocates, and the called function modifies. They are marked as+-- 'out' argumens in the introspection data, we treat them as 'inout'+-- arguments instead. The semantics are somewhat tricky: for memory+-- management purposes they should be treated as "in" arguments, but+-- from the point of view of the exposed API they should be treated as+-- "inout". Unfortunately we cannot always just assume that they are+-- purely "out", so in many cases the generated API is somewhat+-- suboptimal (since the initial values are not important): for+-- example for g_io_channel_read_chars the size of the buffer to read+-- is determined by the caller-allocates argument. As a compromise, we+-- assume that we can allocate anything that is not a TCArray.+fixupCallerAllocates :: Callable -> Callable+fixupCallerAllocates c =+ c{args = map (fixupLength . fixupArg . normalize) (args c)}+ where fixupArg :: Arg -> Arg+ fixupArg a = if argCallerAllocates a+ then a {direction = DirectionInout}+ else a++ lengthsMap :: Map.Map Arg Arg+ lengthsMap = Map.fromList (map swap (arrayLengthsMap c))++ -- Length arguments of caller-allocates arguments should be+ -- treated as "in".+ fixupLength :: Arg -> Arg+ fixupLength a = case Map.lookup a lengthsMap of+ Nothing -> a+ Just array ->+ if argCallerAllocates array+ then a {direction = DirectionIn}+ else a++ -- We impose that out or inout arguments of non-array type+ -- are never caller-allocates.+ normalize :: Arg -> Arg+ normalize (a@Arg{argType = TCArray _ _ _ _}) = a+ normalize a = a {argCallerAllocates = False}++genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()+genCallable n symbol callable throwsGError = do+ group $ do+ line $ "-- Args : " <> (tshow $ args callable)+ line $ "-- Lengths : " <> (tshow $ arrayLengths callable)+ line $ "-- returnType : " <> (tshow $ returnType callable)+ line $ "-- throws : " <> (tshow throwsGError)+ line $ "-- Skip return : " <> (tshow $ skipReturn callable)+ when (skipReturn callable && returnType callable /= Just (TBasicType TBoolean)) $+ do line "-- XXX return value ignored, but it is not a boolean."+ line "-- This may be a memory leak?"++ let callable' = fixupCallerAllocates callable++ mkForeignImport symbol callable' throwsGError++ blank++ line $ deprecatedPragma (lowerName n) (callableDeprecated callable)+ exportMethod (lowerName n) (lowerName n)+ genHaskellWrapper n symbol callable' throwsGError
+ lib/Data/GI/CodeGen/Code.hs view
@@ -0,0 +1,789 @@+module Data.GI.CodeGen.Code+ ( Code(..)+ , ModuleInfo(..)+ , ModuleFlag(..)+ , BaseCodeGen+ , CodeGen+ , ExcCodeGen+ , CGError(..)+ , genCode+ , evalCodeGen++ , writeModuleTree+ , writeModuleCode+ , codeToText+ , transitiveModuleDeps+ , minBaseVersion+ , BaseVersion(..)+ , showBaseVersion++ , loadDependency+ , getDeps+ , recurseWithAPIs++ , handleCGExc+ , describeCGError+ , notImplementedError+ , badIntroError+ , missingInfoError++ , indent+ , bline+ , line+ , blank+ , group+ , hsBoot+ , submodule+ , setLanguagePragmas+ , setGHCOptions+ , setModuleFlags+ , setModuleMinBase+ , addModuleDocumentation++ , exportToplevel+ , exportModule+ , exportDecl+ , exportMethod+ , exportProperty+ , exportSignal++ , findAPI+ , findAPIByName+ , getAPIs++ , config+ , currentModule++ -- From Data.Monoid, for convenience+ , (<>)+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+import Data.Monoid (Monoid(..))+#endif+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Except+import qualified Data.Foldable as F+import Data.Maybe (fromMaybe, catMaybes)+import Data.Monoid ((<>))+import Data.Sequence (Seq, ViewL ((:<)), (><), (|>), (<|))+import qualified Data.Map.Strict as M+import qualified Data.Sequence as S+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++import System.Directory (createDirectoryIfMissing)+import System.FilePath (joinPath, takeDirectory)++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.ProjectInfo (authors, license, maintainers)+import Data.GI.GIR.Documentation (Documentation(..))++data Code+ = NoCode -- ^ No code+ | Line Text -- ^ A single line, indented to current indentation+ | Indent Code -- ^ Indented region+ | Sequence (Seq Code) -- ^ The basic sequence of code+ | Group Code -- ^ A grouped set of lines+ deriving (Eq, Show)++instance Monoid Code where+ mempty = NoCode++ NoCode `mappend` NoCode = NoCode+ x `mappend` NoCode = x+ NoCode `mappend` x = x+ (Sequence a) `mappend` (Sequence b) = Sequence (a >< b)+ (Sequence a) `mappend` b = Sequence (a |> b)+ a `mappend` (Sequence b) = Sequence (a <| b)+ a `mappend` b = Sequence (a <| b <| S.empty)++type Deps = Set.Set Text+type ModuleName = [Text]++-- | Subsection of the haddock documentation where the export should+-- be located.+type HaddockSection = Text++-- | Symbol to export.+type SymbolName = Text++-- | Possible exports for a given module. Every export type+-- constructor has two parameters: the section of the haddocks where+-- it should appear, and the symbol name to export in the export list+-- of the module.+data Export = Export {+ exportType :: ExportType -- ^ Which kind of export.+ , exportSymbol :: SymbolName -- ^ Actual symbol to export.+ } deriving (Show, Eq, Ord)++-- | Possible types of exports.+data ExportType = ExportTypeDecl -- ^ A type declaration.+ | ExportToplevel -- ^ An export in no specific section.+ | ExportMethod HaddockSection -- ^ A method for a struct/union, etc.+ | ExportProperty HaddockSection -- ^ A property for an object/interface.+ | ExportSignal HaddockSection -- ^ A signal for an object/interface.+ | ExportModule -- ^ Reexport of a whole module.+ deriving (Show, Eq, Ord)++-- | Information on a generated module.+data ModuleInfo = ModuleInfo {+ moduleName :: ModuleName -- ^ Full module name: ["GI", "Gtk", "Label"].+ , moduleCode :: Code -- ^ Generated code for the module.+ , bootCode :: Code -- ^ Interface going into the .hs-boot file.+ , submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative+ -- module name.+ , moduleDeps :: Deps -- ^ Set of dependencies for this module.+ , moduleExports :: Seq Export -- ^ Exports for the module.+ , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.+ , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module.+ , moduleFlags :: Set.Set ModuleFlag -- ^ Flags for the module.+ , moduleDoc :: Maybe Text -- ^ Documentation for the module.+ , moduleMinBase :: BaseVersion -- ^ Minimal version of base the+ -- module will work on.+ }++-- | Flags for module code generation.+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.+data BaseVersion = Base47 -- ^ 4.7.0+ | Base48 -- ^ 4.8.0+ deriving (Show, Eq, Ord)++-- | A `Text` representation of the given base version bound.+showBaseVersion :: BaseVersion -> Text+showBaseVersion Base47 = "4.7"+showBaseVersion Base48 = "4.8"++-- | Generate the empty module.+emptyModule :: ModuleName -> ModuleInfo+emptyModule m = ModuleInfo { moduleName = m+ , moduleCode = NoCode+ , bootCode = NoCode+ , submodules = M.empty+ , moduleDeps = Set.empty+ , moduleExports = S.empty+ , modulePragmas = Set.empty+ , moduleGHCOpts = Set.empty+ , moduleFlags = Set.empty+ , moduleDoc = Nothing+ , moduleMinBase = Base47+ }++-- | Information for the code generator.+data CodeGenConfig = CodeGenConfig {+ hConfig :: Config -- ^ Ambient config.+ , loadedAPIs :: M.Map Name API -- ^ APIs available to the generator.+ }++data CGError = CGErrorNotImplemented Text+ | CGErrorBadIntrospectionInfo Text+ | CGErrorMissingInfo Text+ deriving (Show)++type BaseCodeGen excType a =+ ReaderT CodeGenConfig (StateT ModuleInfo (ExceptT excType IO)) a++-- | The code generator monad, for generators that cannot throw+-- errors. The fact that they cannot throw errors is encoded in the+-- forall, which disallows any operation on the error, except+-- discarding it or passing it along without inspecting. This last+-- operation is useful in order to allow embedding `CodeGen`+-- computations inside `ExcCodeGen` computations, while disallowing+-- the opposite embedding without explicit error handling.+type CodeGen a = forall e. BaseCodeGen e a++-- | Code generators that can throw errors.+type ExcCodeGen a = BaseCodeGen CGError a++-- | Run a `CodeGen` with given `Config` and initial `ModuleInfo`,+-- returning either the resulting exception, or the result and final+-- state of the codegen.+runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> ModuleInfo ->+ IO (Either e (a, ModuleInfo))+runCodeGen cg cfg state = runExceptT (runStateT (runReaderT cg cfg) state)++-- | This is useful when we plan run a subgenerator, and `mconcat` the+-- result to the original structure later.+cleanInfo :: ModuleInfo -> ModuleInfo+cleanInfo info = info { moduleCode = NoCode, submodules = M.empty,+ bootCode = NoCode, moduleExports = S.empty,+ moduleDoc = Nothing, moduleMinBase = Base47 }++-- | Run the given code generator using the state and config of an+-- ambient CodeGen, but without adding the generated code to+-- `moduleCode`, instead returning it explicitly.+recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code)+recurseCG cg = do+ cfg <- ask+ oldInfo <- get+ -- Start the subgenerator with no code and no submodules.+ let info = cleanInfo oldInfo+ liftIO (runCodeGen cg cfg info) >>= \case+ Left e -> throwError e+ Right (r, new) -> put (mergeInfoState oldInfo new) >>+ return (r, moduleCode new)++-- | Like `recurse`, giving explicitly the set of loaded APIs for the+-- subgenerator.+recurseWithAPIs :: M.Map Name API -> CodeGen () -> CodeGen ()+recurseWithAPIs apis cg = do+ cfg <- ask+ oldInfo <- get+ -- Start the subgenerator with no code and no submodules.+ let info = cleanInfo oldInfo+ cfg' = cfg {loadedAPIs = apis}+ liftIO (runCodeGen cg cfg' info) >>= \case+ Left e -> throwError e+ Right (_, new) -> put (mergeInfo oldInfo new)++-- | Merge everything but the generated code for the two given `ModuleInfo`.+mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo+mergeInfoState oldState newState =+ let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState)+ newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState)+ newExports = moduleExports oldState <> moduleExports newState+ newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState)+ newGHCOpts = Set.union (moduleGHCOpts oldState) (moduleGHCOpts newState)+ newFlags = Set.union (moduleFlags oldState) (moduleFlags newState)+ newBoot = bootCode oldState <> bootCode newState+ newDoc = moduleDoc oldState <> moduleDoc newState+ newMinBase = max (moduleMinBase oldState) (moduleMinBase newState)+ in oldState {moduleDeps = newDeps, submodules = newSubmodules,+ moduleExports = newExports, modulePragmas = newPragmas,+ moduleGHCOpts = newGHCOpts, moduleFlags = newFlags,+ bootCode = newBoot, moduleDoc = newDoc,+ moduleMinBase = newMinBase }++-- | Merge the infos, including code too.+mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo+mergeInfo oldInfo newInfo =+ let info = mergeInfoState oldInfo newInfo+ in info { moduleCode = moduleCode oldInfo <> moduleCode newInfo }++-- | Add the given submodule to the list of submodules of the current+-- module.+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+ 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)++-- | Try running the given `action`, and if it fails run `fallback`+-- instead.+handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a+handleCGExc fallback+ action = do+ cfg <- ask+ oldInfo <- get+ let info = cleanInfo oldInfo+ liftIO (runCodeGen action cfg info) >>= \case+ Left e -> fallback e+ Right (r, newInfo) -> do+ put (mergeInfo oldInfo newInfo)+ return r++-- | Return the currently loaded set of dependencies.+getDeps :: CodeGen Deps+getDeps = moduleDeps <$> get++-- | Return the ambient configuration for the code generator.+config :: CodeGen Config+config = hConfig <$> ask++-- | Return the name of the current module.+currentModule :: CodeGen Text+currentModule = do+ s <- get+ return (T.intercalate "." (moduleName s))++-- | Return the list of APIs available to the generator.+getAPIs :: CodeGen (M.Map Name API)+getAPIs = loadedAPIs <$> ask++-- | Due to the `forall` in the definition of `CodeGen`, if we want to+-- run the monad transformer stack until we get an `IO` action, our+-- only option is ignoring the possible error code from+-- `runExceptT`. This is perfectly safe, since there is no way to+-- construct a computation in the `CodeGen` monad that throws an+-- exception, due to the higher rank type.+unwrapCodeGen :: CodeGen a -> CodeGenConfig -> ModuleInfo ->+ IO (a, ModuleInfo)+unwrapCodeGen cg cfg info =+ runCodeGen cg cfg info >>= \case+ Left _ -> error "unwrapCodeGen:: The impossible happened!"+ Right (r, newInfo) -> return (r, newInfo)++-- | Like `evalCodeGen`, but discard the resulting output value.+genCode :: Config -> M.Map Name API -> ModuleName -> CodeGen () ->+ IO ModuleInfo+genCode cfg apis mName cg = snd <$> evalCodeGen cfg apis mName cg++-- | Run a code generator, and return the information for the+-- generated module together with the return value of the generator.+evalCodeGen :: Config -> M.Map Name API -> ModuleName -> CodeGen a ->+ IO (a, ModuleInfo)+evalCodeGen cfg apis mName cg = do+ let initialInfo = emptyModule mName+ cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis}+ unwrapCodeGen cg cfg' initialInfo++-- | Mark the given dependency as used by the module.+loadDependency :: Text -> CodeGen ()+loadDependency name = do+ deps <- getDeps+ unless (Set.member name deps) $ do+ let newDeps = Set.insert name deps+ modify' $ \s -> s {moduleDeps = newDeps}++-- | Return the transitive set of dependencies, i.e. the union of+-- those of the module and (transitively) its submodules.+transitiveModuleDeps :: ModuleInfo -> Deps+transitiveModuleDeps minfo =+ Set.unions (moduleDeps minfo+ : map transitiveModuleDeps (M.elems $ submodules minfo))++-- | Return the minimal base version supported by the module and all+-- its submodules.+minBaseVersion :: ModuleInfo -> BaseVersion+minBaseVersion minfo =+ maximum (moduleMinBase minfo+ : map minBaseVersion (M.elems $ submodules minfo))++-- | Give a friendly textual description of the error for presenting+-- to the user.+describeCGError :: CGError -> Text+describeCGError (CGErrorNotImplemented e) = "Not implemented: " <> tshow e+describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " <> tshow e+describeCGError (CGErrorMissingInfo e) = "Missing info: " <> tshow e++notImplementedError :: Text -> ExcCodeGen a+notImplementedError s = throwError $ CGErrorNotImplemented s++badIntroError :: Text -> ExcCodeGen a+badIntroError s = throwError $ CGErrorBadIntrospectionInfo s++missingInfoError :: Text -> ExcCodeGen a+missingInfoError s = throwError $ CGErrorMissingInfo s++findAPI :: Type -> CodeGen (Maybe API)+findAPI TError = Just <$> findAPIByName (Name "GLib" "Error")+findAPI (TInterface ns n) = Just <$> findAPIByName (Name ns n)+findAPI _ = return Nothing++findAPIByName :: Name -> CodeGen API+findAPIByName n@(Name ns _) = do+ apis <- getAPIs+ case M.lookup n apis of+ Just api -> return api+ Nothing ->+ terror $ "couldn't find API description for " <> ns <> "." <> name n++-- | Add some code to the current generator.+tellCode :: Code -> CodeGen ()+tellCode c = modify' (\s -> s {moduleCode = moduleCode s <> c})++-- | Print out a (newline-terminated) line.+line :: Text -> CodeGen ()+line = tellCode . Line++-- | Print out the given line both to the normal module, and to the+-- HsBoot file.+bline :: Text -> CodeGen ()+bline l = hsBoot (line l) >> line l++-- | A blank line+blank :: CodeGen ()+blank = line ""++-- | Increase the indent level for code generation.+indent :: BaseCodeGen e a -> BaseCodeGen e a+indent cg = do+ (x, code) <- recurseCG cg+ tellCode (Indent code)+ return x++-- | Group a set of related code.+group :: BaseCodeGen e a -> BaseCodeGen e a+group cg = do+ (x, code) <- recurseCG cg+ tellCode (Group code)+ blank+ return x++-- | Write the given code into the .hs-boot file for the current module.+hsBoot :: BaseCodeGen e a -> BaseCodeGen e a+hsBoot cg = do+ (x, code) <- recurseCG cg+ modify' (\s -> s{bootCode = bootCode s <> code})+ return x++-- | Add a export to the current module.+export :: Export -> CodeGen ()+export e =+ modify' $ \s -> s{moduleExports = moduleExports s |> e}++-- | Reexport a whole module.+exportModule :: SymbolName -> CodeGen ()+exportModule m = export (Export ExportModule m)++-- | Export a toplevel (i.e. belonging to no section) symbol.+exportToplevel :: SymbolName -> CodeGen ()+exportToplevel t = export (Export ExportToplevel t)++-- | Add a type declaration-related export.+exportDecl :: SymbolName -> CodeGen ()+exportDecl d = export (Export ExportTypeDecl d)++-- | Add a method export under the given section.+exportMethod :: HaddockSection -> SymbolName -> CodeGen ()+exportMethod s n = export (Export (ExportMethod s) n)++-- | Add a property-related export under the given section.+exportProperty :: HaddockSection -> SymbolName -> CodeGen ()+exportProperty s n = export (Export (ExportProperty s) n)++-- | Add a signal-related export under the given section.+exportSignal :: HaddockSection -> SymbolName -> CodeGen ()+exportSignal s n = export (Export (ExportSignal s) n)++-- | Set the language pragmas for the current module.+setLanguagePragmas :: [Text] -> CodeGen ()+setLanguagePragmas ps =+ modify' $ \s -> s{modulePragmas = Set.fromList ps}++-- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma).+setGHCOptions :: [Text] -> CodeGen ()+setGHCOptions opts =+ modify' $ \s -> s{moduleGHCOpts = Set.fromList opts}++-- | Set the given flags for the module.+setModuleFlags :: [ModuleFlag] -> CodeGen ()+setModuleFlags flags =+ modify' $ \s -> s{moduleFlags = Set.fromList flags}++-- | Set the minimum base version supported by the current module.+setModuleMinBase :: BaseVersion -> CodeGen ()+setModuleMinBase v =+ modify' $ \s -> s{moduleMinBase = max v (moduleMinBase s)}++-- | Add the given text to the module-level documentation for the+-- module being generated.+addModuleDocumentation :: Maybe Documentation -> CodeGen ()+addModuleDocumentation Nothing = return ()+addModuleDocumentation (Just doc) =+ modify' $ \s -> s{moduleDoc = moduleDoc s <> Just (docText doc)}++-- | Return a text representation of the `Code`.+codeToText :: Code -> Text+codeToText c = T.concat $ str 0 c []+ where+ str :: Int -> Code -> [Text] -> [Text]+ str _ NoCode cont = cont+ str n (Line s) cont = paddedLine n s : cont+ str n (Indent c) cont = str (n + 1) c cont+ str n (Sequence s) cont = deseq n (S.viewl s) cont+ str n (Group c) cont = str n c cont++ deseq _ S.EmptyL cont = cont+ deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont)++-- | Pad a line to the given number of leading spaces, and add a+-- newline at the end.+paddedLine :: Int -> Text -> Text+paddedLine n s = T.replicate (n * 4) " " <> s <> "\n"++-- | Put a (padded) comma at the end of the text.+comma :: Text -> Text+comma s = padTo 40 s <> ","++-- | Format the list of exported modules.+formatExportedModules :: [Export] -> Maybe Text+formatExportedModules [] = Nothing+formatExportedModules exports =+ Just . T.concat . map ( paddedLine 1+ . comma+ . ("module " <>)+ . exportSymbol)+ . filter ((== ExportModule) . exportType) $ exports++-- | Format the toplevel exported symbols.+formatToplevel :: [Export] -> Maybe Text+formatToplevel [] = Nothing+formatToplevel exports =+ Just . T.concat . map (paddedLine 1 . comma . exportSymbol)+ . filter ((== ExportToplevel) . exportType) $ exports++-- | Format the type declarations section.+formatTypeDecls :: [Export] -> Maybe Text+formatTypeDecls exports =+ let exportedTypes = filter ((== ExportTypeDecl) . exportType) exports+ in if exportedTypes == []+ then Nothing+ else Just . T.unlines $ [ "-- * Exported types"+ , T.concat . map ( paddedLine 1+ . comma+ . exportSymbol )+ $ exportedTypes ]++-- | Format a given section made of subsections.+formatSection :: Text -> (Export -> Maybe (HaddockSection, SymbolName)) ->+ [Export] -> Maybe Text+formatSection section filter exports =+ if M.null exportedSubsections+ then Nothing+ else Just . T.unlines $ [" -- * " <> section+ , ( T.unlines+ . map formatSubsection+ . M.toList ) exportedSubsections]++ where+ filteredExports :: [(HaddockSection, SymbolName)]+ filteredExports = catMaybes (map filter exports)++ exportedSubsections :: M.Map HaddockSection (Set.Set SymbolName)+ exportedSubsections = foldr extract M.empty filteredExports++ extract :: (HaddockSection, SymbolName) ->+ M.Map Text (Set.Set Text) -> M.Map Text (Set.Set Text)+ extract (subsec, m) secs =+ M.insertWith Set.union subsec (Set.singleton m) secs++ formatSubsection :: (HaddockSection, Set.Set SymbolName) -> Text+ formatSubsection (subsec, symbols) =+ T.unlines [ "-- ** " <> subsec+ , ( T.concat+ . map (paddedLine 1 . comma)+ . Set.toList ) symbols]++-- | Format the list of methods.+formatMethods :: [Export] -> Maybe Text+formatMethods = formatSection "Methods" toMethod+ where toMethod :: Export -> Maybe (HaddockSection, SymbolName)+ toMethod (Export (ExportMethod s) m) = Just (s, m)+ toMethod _ = Nothing++-- | Format the list of properties.+formatProperties :: [Export] -> Maybe Text+formatProperties = formatSection "Properties" toProperty+ where toProperty :: Export -> Maybe (HaddockSection, SymbolName)+ toProperty (Export (ExportProperty s) m) = Just (s, m)+ toProperty _ = Nothing++-- | Format the list of signals.+formatSignals :: [Export] -> Maybe Text+formatSignals = formatSection "Signals" toSignal+ where toSignal :: Export -> Maybe (HaddockSection, SymbolName)+ toSignal (Export (ExportSignal s) m) = Just (s, m)+ toSignal _ = Nothing++-- | Format the given export list. This is just the inside of the+-- parenthesis.+formatExportList :: [Export] -> Text+formatExportList exports =+ T.unlines . catMaybes $ [ formatExportedModules exports+ , formatToplevel exports+ , formatTypeDecls exports+ , formatMethods exports+ , formatProperties exports+ , formatSignals exports ]++-- | Write down the list of language pragmas.+languagePragmas :: [Text] -> Text+languagePragmas [] = ""+languagePragmas ps = "{-# LANGUAGE " <> T.intercalate ", " ps <> " #-}\n"++-- | Write down the list of GHC options.+ghcOptions :: [Text] -> Text+ghcOptions [] = ""+ghcOptions opts = "{-# OPTIONS_GHC " <> T.intercalate ", " opts <> " #-}\n"++-- | Standard fields for every module.+standardFields :: Text+standardFields = T.unlines [ "Copyright : " <> authors+ , "License : " <> license+ , "Maintainer : " <> maintainers ]++-- | The haddock header for the module, including optionally a description.+moduleHaddock :: Maybe Text -> Text+moduleHaddock Nothing = T.unlines ["{- |", standardFields <> "-}"]+moduleHaddock (Just description) = T.unlines ["{- |", standardFields,+ description, "-}"]++-- | Generic module prelude. We reexport all of the submodules.+modulePrelude :: Text -> [Export] -> [Text] -> Text+modulePrelude name [] [] = "module " <> name <> " () where\n"+modulePrelude name exports [] =+ "module " <> name <> "\n ( "+ <> formatExportList exports+ <> " ) where\n"+modulePrelude name [] reexportedModules =+ "module " <> name <> "\n ( "+ <> formatExportList (map (Export ExportModule) reexportedModules)+ <> " ) where\n\n"+ <> T.unlines (map ("import " <>) reexportedModules)+modulePrelude name exports reexportedModules =+ "module " <> name <> "\n ( "+ <> formatExportList (map (Export ExportModule) reexportedModules)+ <> "\n"+ <> formatExportList exports+ <> " ) 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++-- | Standard imports.+moduleImports :: Text+moduleImports = T.unlines [ "import Data.GI.Base.ShortPrelude"+ , ""+ , "import qualified Data.GI.Base.Attributes as GI.Attributes"+ , "import qualified Data.Text as T"+ , "import qualified Data.ByteString.Char8 as B"+ , "import qualified Data.Map as Map" ]++-- | Write to disk the code for a module, under the given base+-- directory. Does not write submodules recursively, for that use+-- `writeModuleTree`.+writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO ()+writeModuleInfo verbose dirPrefix minfo = do+ let submoduleNames = map (moduleName) (M.elems (submodules minfo))+ -- We reexport any submodules.+ submoduleExports = map dotModuleName submoduleNames+ fname = moduleNameToPath dirPrefix (moduleName minfo) ".hs"+ dirname = takeDirectory fname+ code = codeToText (moduleCode minfo)+ pragmas = languagePragmas (Set.toList $ modulePragmas minfo)+ optionsGHC = ghcOptions (Set.toList $ moduleGHCOpts minfo)+ prelude = modulePrelude (dotModuleName $ moduleName minfo)+ (F.toList (moduleExports minfo))+ submoduleExports+ 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+ 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])+ when (bootCode minfo /= NoCode) $ do+ let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot"+ TIO.writeFile bootFName (genHsBoot minfo)++-- | Generate the .hs-boot file for the given module.+genHsBoot :: ModuleInfo -> Text+genHsBoot minfo =+ "module " <> (dotModuleName . moduleName) minfo <> " where\n\n" <>+ moduleImports <> "\n" <>+ codeToText (bootCode minfo)++-- | Construct the filename corresponding to the given module.+moduleNameToPath :: Maybe FilePath -> ModuleName -> FilePath -> FilePath+moduleNameToPath dirPrefix mn ext =+ joinPath (fromMaybe "" dirPrefix : map T.unpack mn) ++ ext++-- | Turn an abstract module name into its dotted representation. For+-- instance, ["GI", "Gtk", "Types"] -> GI.Gtk.Types.+dotModuleName :: ModuleName -> Text+dotModuleName mn = T.intercalate "." mn++-- | 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+ submoduleNames <- concat <$> forM (M.elems (submodules minfo))+ (writeModuleCode verbose dirPrefix)+ writeModuleInfo verbose dirPrefix minfo+ return $ (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
+ lib/Data/GI/CodeGen/CodeGen.hs view
@@ -0,0 +1,549 @@+module Data.GI.CodeGen.CodeGen+ ( genConstant+ , genFunction+ , genModule+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Traversable (traverse)+#endif+import Control.Monad (forM, forM_, when, unless, filterM)+import Data.List (nub)+import Data.Tuple (swap)+import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe)+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)++import Foreign.Storable (sizeOf)+import Foreign.C (CUInt)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Callable (genCallable)+import Data.GI.CodeGen.Constant (genConstant)+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Fixups (dropMovedItems, guessPropertyNullability)+import Data.GI.CodeGen.GObject+import Data.GI.CodeGen.Inheritance (instanceTree, fullObjectMethodList,+ fullInterfaceMethodList)+import Data.GI.CodeGen.Properties (genInterfaceProperties, genObjectProperties,+ genNamespacedPropLabels)+import Data.GI.CodeGen.OverloadedSignals (genInterfaceSignals, genObjectSignals)+import Data.GI.CodeGen.OverloadedMethods (genMethodList, genMethodInfo,+ genUnsupportedMethodInfo)+import Data.GI.CodeGen.Signal (genSignal, genCallback)+import Data.GI.CodeGen.Struct (genStructOrUnionFields, extractCallbacksInStruct,+ fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion)+import Data.GI.CodeGen.SymbolNaming (upperName, classConstraint, noName)+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util (tshow)++genFunction :: Name -> Function -> CodeGen ()+genFunction n (Function symbol throws fnMovedTo callable) =+ -- Only generate the function if it has not been moved.+ when (Nothing == fnMovedTo) $+ submodule "Functions" $ group $ do+ line $ "-- function " <> symbol+ handleCGExc (\e -> line ("-- XXX Could not generate function "+ <> symbol+ <> "\n-- Error was : " <> describeCGError e))+ (genCallable n symbol callable throws)++genBoxedObject :: Name -> Text -> CodeGen ()+genBoxedObject n typeInit = do+ name' <- upperName n++ group $ do+ line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>+ typeInit <> " :: "+ indent $ line "IO GType"+ group $ do+ line $ "instance BoxedObject " <> name' <> " where"+ indent $ line $ "boxedType _ = c_" <> typeInit++ hsBoot $ line $ "instance BoxedObject " <> name' <> " where"++genEnumOrFlags :: Name -> Enumeration -> ExcCodeGen ()+genEnumOrFlags n@(Name ns name) (Enumeration fields eDomain _maybeTypeInit storageBytes isDeprecated) = do+ -- Conversion functions expect enums and flags to map to CUInt,+ -- which we assume to be of 32 bits. Fail early, instead of giving+ -- strange errors at runtime.+ when (sizeOf (0 :: CUInt) /= 4) $+ notImplementedError $ "Unsupported CUInt size: " <> tshow (sizeOf (0 :: CUInt))+ when (storageBytes /= 4) $+ notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes++ name' <- upperName n+ fields' <- forM fields $ \(fieldName, value) -> do+ n <- upperName $ Name ns (name <> "_" <> fieldName)+ return (n, value)++ line $ deprecatedPragma name' isDeprecated++ group $ do+ exportDecl (name' <> "(..)")+ line $ "data " <> name' <> " = "+ indent $+ case fields' of+ ((fieldName, _value):fs) -> do+ line $ " " <> fieldName+ forM_ fs $ \(n, _) -> line $ "| " <> n+ line $ "| Another" <> name' <> " Int"+ line "deriving (Show, Eq)"+ _ -> return ()+ group $ do+ line $ "instance Enum " <> name' <> " where"+ indent $ do+ forM_ fields' $ \(n, v) ->+ line $ "fromEnum " <> n <> " = " <> tshow v+ line $ "fromEnum (Another" <> name' <> " k) = k"+ let valueNames = M.toList . M.fromListWith (curry snd) $ map swap fields'+ blank+ indent $ do+ forM_ valueNames $ \(v, n) ->+ line $ "toEnum " <> tshow v <> " = " <> n+ line $ "toEnum k = Another" <> name' <> " k"+ maybe (return ()) (genErrorDomain name') eDomain++genBoxedEnum :: Name -> Text -> CodeGen ()+genBoxedEnum n typeInit = do+ name' <- upperName n++ group $ do+ line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>+ typeInit <> " :: "+ indent $ line "IO GType"+ group $ do+ line $ "instance BoxedEnum " <> name' <> " where"+ indent $ line $ "boxedEnumType _ = c_" <> typeInit++genEnum :: Name -> Enumeration -> CodeGen ()+genEnum n@(Name _ name) enum = submodule "Enums" $ 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+ Nothing -> return ()+ Just ti -> genBoxedEnum n ti)++genBoxedFlags :: Name -> Text -> CodeGen ()+genBoxedFlags n typeInit = do+ name' <- upperName n++ group $ do+ line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>+ typeInit <> " :: "+ indent $ line "IO GType"+ group $ do+ line $ "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+ 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++ case enumTypeInit enum of+ Nothing -> return ()+ Just ti -> genBoxedFlags n ti++ name' <- upperName n+ group $ line $ "instance IsGFlag " <> name')++genErrorDomain :: Text -> Text -> CodeGen ()+genErrorDomain name' domain = do+ group $ do+ line $ "instance GErrorClass " <> name' <> " where"+ indent $ line $+ "gerrorClassDomain _ = \"" <> domain <> "\""+ -- Generate type specific error handling (saves a bit of typing, and+ -- it's clearer to read).+ group $ do+ let catcher = "catch" <> name'+ line $ catcher <> " ::"+ indent $ do+ line "IO a ->"+ line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->"+ line "IO a"+ line $ catcher <> " = catchGErrorJustDomain"+ group $ do+ let handler = "handle" <> name'+ line $ handler <> " ::"+ indent $ do+ line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->"+ line "IO a ->"+ line "IO a"+ line $ handler <> " = handleGErrorJustDomain"+ exportToplevel ("catch" <> name')+ exportToplevel ("handle" <> name')++genStruct :: Name -> Struct -> CodeGen ()+genStruct n s = unless (ignoreStruct n s) $ do+ name' <- upperName n++ submodule "Structs" $ submodule name' $ do+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ hsBoot decl+ decl++ addModuleDocumentation (structDocumentation s)++ when (structIsBoxed s) $+ genBoxedObject n (fromJust $ structTypeInit s)+ exportDecl (name' <> ("(..)"))++ -- Generate a builder for a structure filled with zeroes.+ genZeroStruct n s++ noName name'++ -- Generate code for fields.+ genStructOrUnionFields n (structFields s)++ -- Methods+ 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)++genUnion :: Name -> Union -> CodeGen ()+genUnion n u = do+ name' <- upperName n++ submodule "Unions" $ submodule name' $ do+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ hsBoot decl+ decl++ when (unionIsBoxed u) $+ genBoxedObject n (fromJust $ unionTypeInit u)+ exportDecl (name' <> "(..)")++ -- Generate a builder for a structure filled with zeroes.+ genZeroUnion n u++ noName name'++ -- Generate code for fields.+ genStructOrUnionFields n (unionFields u)++ -- Methods+ 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)++-- Add the implicit object argument to methods of an object. Since we+-- are prepending an argument we need to adjust the offset of the+-- length arguments of CArrays, and closure and destroyer offsets.+fixMethodArgs :: Name -> Callable -> Callable+fixMethodArgs cn c = c { args = args' , returnType = returnType' }+ where+ returnType' = maybe Nothing (Just . fixCArrayLength) (returnType c)+ args' = objArg : map (fixDestroyers . fixClosures . fixLengthArg) (args c)++ fixLengthArg :: Arg -> Arg+ fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)}++ fixCArrayLength :: Type -> Type+ fixCArrayLength (TCArray zt fixed length t) =+ if length > -1+ then TCArray zt fixed (length+1) t+ else TCArray zt fixed length t+ fixCArrayLength t = t++ fixDestroyers :: Arg -> Arg+ fixDestroyers arg = let destroy = argDestroy arg in+ if destroy > -1+ then arg {argDestroy = destroy + 1}+ else arg++ fixClosures :: Arg -> Arg+ fixClosures arg = let closure = argClosure arg in+ if closure > -1+ then arg {argClosure = closure + 1}+ else arg++ objArg = Arg {+ argCName = "_obj",+ argType = TInterface (namespace cn) (name cn),+ direction = DirectionIn,+ mayBeNull = False,+ argScope = ScopeTypeInvalid,+ argClosure = -1,+ argDestroy = -1,+ argCallerAllocates = False,+ transfer = TransferNothing }++-- For constructors we want to return the actual type of the object,+-- rather than a generic superclass (so Gtk.labelNew returns a+-- Gtk.Label, rather than a Gtk.Widget)+fixConstructorReturnType :: Bool -> Name -> Callable -> Callable+fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' }+ where+ returnType' = if returnsGObject then+ Just (TInterface (namespace cn) (name cn))+ else+ returnType c++genMethod :: Name -> Method -> ExcCodeGen ()+genMethod cn m@(Method {+ methodName = mn,+ methodSymbol = sym,+ methodCallable = c,+ methodType = t,+ methodThrows = throws+ }) = do+ name' <- upperName cn+ returnsGObject <- maybe (return False) isGObject (returnType c)+ line $ "-- method " <> name' <> "::" <> name mn+ line $ "-- method type : " <> tshow t+ let -- Mangle the name to namespace it to the class.+ mn' = mn { name = name cn <> "_" <> name mn }+ let c' = if Constructor == t+ then fixConstructorReturnType returnsGObject cn c+ else c+ c'' = if OrdinaryMethod == t+ then fixMethodArgs cn c'+ else c'+ genCallable mn' sym c'' throws++ genMethodInfo cn (m {methodCallable = c''})++-- Type casting with type checking+genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen ()+genGObjectCasts isIU n cn_ parents = do+ name' <- upperName n+ qualifiedParents <- traverse upperName parents++ 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'+ group $ do+ exportDecl className+ bline $ "class GObject o => " <> className <> " o"+ bline $ "instance (GObject o, IsDescendantOf " <> name' <> " o) => "+ <> className <> " o"++ -- Safe downcasting.+ group $ do+ let safeCast = "to" <> name'+ exportDecl safeCast+ line $ safeCast <> " :: " <> className <> " o => o -> IO " <> name'+ line $ safeCast <> " = unsafeCastTo " <> name'++-- Wrap a given Object. We enforce that every Object that we wrap is a+-- GObject. This is the case for everything except the ParamSpec* set+-- of objects, we deal with these separately.+genObject :: Name -> Object -> CodeGen ()+genObject n o = do+ 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' <> "(..)")++ -- 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'++ 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)++ genObjectProperties n o+ genNamespacedPropLabels n (objProperties o) (objMethods o)+ 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)++genInterface :: Name -> Interface -> CodeGen ()+genInterface n iface = do+ name' <- upperName n++ submodule "Interfaces" $ submodule name' $ do+ line $ "-- interface " <> name' <> " "+ line $ deprecatedPragma name' $ ifDeprecated iface+ bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ exportDecl (name' <> "(..)")++ noName name'++ 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)++ genInterfaceProperties n iface+ genNamespacedPropLabels n (ifProperties iface) (ifMethods iface)+ 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++ 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 <> " = '[]"++ -- 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)++-- Some type libraries include spurious interface/struct methods,+-- where a method Mod.Foo::func also appears as an ordinary function+-- in the list of APIs. If we find a matching function (without the+-- "moved-to" annotation), we don't generate the method.+--+-- It may be more expedient to keep a map of symbol -> function.+symbolFromFunction :: Text -> CodeGen Bool+symbolFromFunction sym = do+ apis <- getAPIs+ return $ any (hasSymbol sym . snd) $ M.toList apis+ where+ hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2,+ fnMovedTo = movedTo })) =+ sym1 == sym2 && movedTo == Nothing+ hasSymbol _ _ = False++genAPI :: Name -> API -> CodeGen ()+genAPI n (APIConst c) = genConstant n c+genAPI n (APIFunction f) = genFunction n f+genAPI n (APIEnum e) = genEnum n e+genAPI n (APIFlags f) = genFlags n f+genAPI n (APICallback c) = genCallback n c+genAPI n (APIStruct s) = genStruct n s+genAPI n (APIUnion u) = genUnion n u+genAPI n (APIObject o) = genObject n o+genAPI n (APIInterface i) = genInterface n i++genModule' :: M.Map Name API -> CodeGen ()+genModule' apis = do+ mapM_ (uncurry genAPI)+ -- We provide these ourselves+ $ filter ((`notElem` [ Name "GLib" "Array"+ , Name "GLib" "Error"+ , Name "GLib" "HashTable"+ , Name "GLib" "List"+ , Name "GLib" "SList"+ , Name "GLib" "Variant"+ , Name "GObject" "Value"+ , Name "GObject" "Closure"]) . fst)+ $ mapMaybe (traverse dropMovedItems)+ -- Some callback types are defined inside structs+ $ map fixAPIStructs+ -- Try to guess nullability of properties when there is no+ -- nullability info in the GIR.+ $ map guessPropertyNullability+ $ M.toList+ $ apis++ -- 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 ()++genModule :: M.Map Name API -> CodeGen ()+genModule apis = do+ -- Reexport Data.GI.Base for convenience (so it does not need to be+ -- imported separately).+ line "import Data.GI.Base"+ exportModule "Data.GI.Base"++ -- Some API symbols are embedded into structures, extract these and+ -- inject them into the set of APIs loaded and being generated.+ let embeddedAPIs = (M.fromList+ . concatMap extractCallbacksInStruct+ . M.toList) apis+ allAPIs <- getAPIs+ recurseWithAPIs (M.union allAPIs embeddedAPIs)+ (genModule' (M.union apis embeddedAPIs))
+ lib/Data/GI/CodeGen/Config.hs view
@@ -0,0 +1,15 @@+module Data.GI.CodeGen.Config+ ( Config(..)+ ) where++import Data.Text (Text)+import Data.GI.CodeGen.Overrides (Overrides)++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+ }
+ lib/Data/GI/CodeGen/Constant.hs view
@@ -0,0 +1,107 @@+module Data.GI.CodeGen.Constant+ ( genConstant+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Data.Text (Text)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util (tshow)++-- | Data for a bidrectional pattern synonym. It is either a simple+-- one of the form "pattern Name = value :: Type" or an explicit one+-- of the form+-- > pattern Name <- (view -> value) :: Type where+-- > Name = expression value :: Type+data PatternSynonym = SimpleSynonym PSValue PSType+ | ExplicitSynonym PSView PSExpression PSValue PSType++-- Some simple types for legibility+type PSValue = Text+type PSType = Text+type PSView = Text+type PSExpression = Text++writePattern :: Text -> PatternSynonym -> CodeGen ()+writePattern name (SimpleSynonym value t) = line $+ "pattern " <> name <> " = " <> value <> " :: " <> t+writePattern name (ExplicitSynonym view expression value t) = do+ -- Supported only on ghc >= 7.10+ setModuleMinBase Base48+ line $ "pattern " <> name <> " <- (" <> view <> " -> "+ <> value <> ") :: " <> t <> " where"+ indent $ line $+ name <> " = " <> expression <> " " <> value <> " :: " <> t++genConstant :: Name -> Constant -> CodeGen ()+genConstant (Name _ name) (Constant t value deprecated) =+ submodule "Constants" $ group $ do+ setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables",+ "ViewPatterns"]+ line $ deprecatedPragma name deprecated++ handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)+ (assignValue name t value >>+ exportToplevel ("pattern " <> name))++-- | Assign to the given name the given constant value, in a way that+-- can be assigned to the corresponding Haskell type.+assignValue :: Text -> Type -> Text -> ExcCodeGen ()+assignValue name t@(TBasicType TPtr) value = do+ ht <- tshow <$> haskellType t+ writePattern name (ExplicitSynonym "ptrToIntPtr" "intPtrToPtr" value ht)+assignValue name t@(TBasicType b) value = do+ ht <- tshow <$> haskellType t+ hv <- showBasicType b value+ writePattern name (SimpleSynonym hv ht)+assignValue name t@(TInterface _ _) value = do+ ht <- tshow <$> haskellType t+ api <- findAPI t+ case api of+ Just (APIEnum _) ->+ writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht)+ Just (APIFlags _) -> do+ -- gflagsToWord and wordToGFlags are polymorphic, so in this+ -- case we need to specialize so the type of the pattern is+ -- not ambiguous.+ let wordValue = "(" <> value <> " :: Word64)"+ writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" wordValue ht)+ _ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t+assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t++-- | Show a basic type, in a way that can be assigned to the+-- corresponding Haskell type.+showBasicType :: BasicType -> Text -> ExcCodeGen Text+showBasicType TInt i = return i+showBasicType TUInt i = return i+showBasicType TLong i = return i+showBasicType TULong i = return i+showBasicType TInt8 i = return i+showBasicType TUInt8 i = return i+showBasicType TInt16 i = return i+showBasicType TUInt16 i = return i+showBasicType TInt32 i = return i+showBasicType TUInt32 i = return i+showBasicType TInt64 i = return i+showBasicType TUInt64 i = return i+showBasicType TBoolean "0" = return "False"+showBasicType TBoolean "false" = return "False"+showBasicType TBoolean "1" = return "True"+showBasicType TBoolean "true" = return "True"+showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" <> b <> "\""+showBasicType TFloat f = return f+showBasicType TDouble d = return d+showBasicType TUTF8 s = return . tshow $ s+showBasicType TFileName fn = return . tshow $ fn+showBasicType TUniChar c = return $ "'" <> c <> "'"+showBasicType TGType gtype = return $ "GType " <> gtype+showBasicType TIntPtr ptr = return ptr+showBasicType TUIntPtr ptr = return ptr+-- We take care of this one separately above+showBasicType TPtr _ = notImplementedError $ "Cannot directly show a pointer"
+ lib/Data/GI/CodeGen/Conversions.hs view
@@ -0,0 +1,827 @@+{-# LANGUAGE PatternGuards, DeriveFunctor #-}++module Data.GI.CodeGen.Conversions+ ( convert+ , genConversion+ , unpackCArray+ , computeArrayLength++ , hToF+ , fToH+ , haskellType+ , foreignType++ , argumentType+ , elementType+ , elementMap+ , elementTypeAndMap++ , isManaged+ , typeIsNullable+ , typeIsPtr++ , getIsScalar+ , requiresAlloc++ , apply+ , mapC+ , literal+ , Constructor(..)+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>), pure, Applicative)+#endif+import Control.Monad (when)+import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)+import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word+import GHC.Exts (IsString(..))++import Foreign.C.Types (CInt, CUInt, CLong, CULong)+import Foreign.Storable (sizeOf)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.GObject+import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util++-- | The free monad.+data Free f r = Free (f (Free f r)) | Pure r++instance Functor f => Functor (Free f) where+ fmap f = go where+ go (Pure a) = Pure (f a)+ go (Free fa) = Free (go <$> fa)++instance (Functor f) => Applicative (Free f) where+ pure = Pure+ Pure a <*> Pure b = Pure $ a b+ Pure a <*> Free mb = Free $ fmap a <$> mb+ Free ma <*> b = Free $ (<*> b) <$> ma++instance (Functor f) => Monad (Free f) where+ return = Pure+ (Free x) >>= f = Free (fmap (>>= f) x)+ (Pure r) >>= f = f r++-- | Lift some command to the Free monad.+liftF :: (Functor f) => f r -> Free f r+liftF command = Free (fmap Pure command)++-- String identifying a constructor in the generated code, which is+-- either (by default) a pure function (indicated by the P+-- constructor) or a function returning values on a monad (M+-- constructor). 'Id' denotes the identity function.+data Constructor = P Text | M Text | Id+ deriving (Eq,Show)+instance IsString Constructor where+ fromString = P . T.pack++data FExpr next = Apply Constructor next+ | MapC Map Constructor next+ | Literal Constructor next+ deriving (Show, Functor)++type Converter = Free FExpr ()++-- Different available maps.+data Map = Map | MapFirst | MapSecond+ deriving (Show)++-- Naming for the maps.+mapName :: Map -> Text+mapName Map = "map"+mapName MapFirst = "mapFirst"+mapName MapSecond = "mapSecond"++-- Naming for the monadic versions of the maps that we use+monadicMapName :: Map -> Text+monadicMapName Map = "mapM"+monadicMapName MapFirst = "mapFirstA"+monadicMapName MapSecond = "mapSecondA"++apply :: Constructor -> Converter+apply f = liftF $ Apply f ()++mapC :: Constructor -> Converter+mapC f = liftF $ MapC Map f ()++mapFirst :: Constructor -> Converter+mapFirst f = liftF $ MapC MapFirst f ()++mapSecond :: Constructor -> Converter+mapSecond f = liftF $ MapC MapSecond f ()++literal :: Constructor -> Converter+literal f = liftF $ Literal f ()++genConversion :: Text -> Converter -> CodeGen Text+genConversion l (Pure ()) = return l+genConversion l (Free k) = do+ let l' = prime l+ case k of+ Apply (P f) next ->+ do line $ "let " <> l' <> " = " <> f <> " " <> l+ genConversion l' next+ Apply (M f) next ->+ do line $ l' <> " <- " <> f <> " " <> l+ genConversion l' next+ Apply Id next -> genConversion l next++ MapC m (P f) next ->+ do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l+ genConversion l' next+ MapC m (M f) next ->+ do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l+ genConversion l' next+ MapC _ Id next -> genConversion l next++ Literal (P f) next ->+ do line $ "let " <> l <> " = " <> f+ genConversion l next+ Literal (M f) next ->+ do line $ l <> " <- " <> f+ genConversion l next+ Literal Id next -> genConversion l next++-- Given an array, together with its type, return the code for reading+-- its length.+computeArrayLength :: Text -> Type -> ExcCodeGen Text+computeArrayLength array (TCArray _ _ _ t) = do+ reader <- findReader+ return $ "fromIntegral $ " <> reader <> " " <> array+ where findReader = case t of+ TBasicType TUInt8 -> return "B.length"+ TBasicType _ -> return "length"+ TInterface _ _ -> return "length"+ TCArray{} -> return "length"+ _ -> notImplementedError $+ "Don't know how to compute length of " <> tshow t+computeArrayLength _ t =+ notImplementedError $ "computeArrayLength called on non-CArray type "+ <> tshow t++convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text+convert l c = do+ c' <- c+ genConversion l c'++hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor+hObjectToF t transfer =+ if transfer == TransferEverything+ then do+ isGO <- isGObject t+ if isGO+ then return $ M "refObject"+ else badIntroError "Transferring a non-GObject object"+ -- castPtr since we accept any instance of the class associated with+ -- the GObject, not just the precise type of the GObject, while the+ -- foreign function declaration requires a pointer of the precise+ -- type.+ else return "unsafeManagedPtrCastPtr"++hVariantToF :: Transfer -> CodeGen Constructor+hVariantToF transfer =+ if transfer == TransferEverything+ then return $ M "refGVariant"+ else return "unsafeManagedPtrGetPtr"++hParamSpecToF :: Transfer -> CodeGen Constructor+hParamSpecToF transfer =+ if transfer == TransferEverything+ then return $ M "refGParamSpec"+ else return "unsafeManagedPtrGetPtr"++hBoxedToF :: Transfer -> CodeGen Constructor+hBoxedToF transfer =+ if transfer == TransferEverything+ then return $ M "copyBoxed"+ else return "unsafeManagedPtrGetPtr"++hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor+hStructToF s transfer =+ if transfer /= TransferEverything || structIsBoxed s then+ hBoxedToF transfer+ else do+ when (structSize s == 0) $+ badIntroError "Transferring a non-boxed struct with unknown size!"+ return "unsafeManagedPtrGetPtr"++hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor+hUnionToF u transfer =+ if transfer /= TransferEverything || unionIsBoxed u then+ hBoxedToF transfer+ else do+ when (unionSize u == 0) $+ badIntroError "Transferring a non-boxed union with unknown size!"+ return "unsafeManagedPtrGetPtr"++-- Given the Haskell and Foreign types, returns the name of the+-- function marshalling between both.+hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer+ -> ExcCodeGen Constructor+hToF' t a hType fType transfer+ | ( hType == fType ) = return Id+ | TError <- t = hBoxedToF transfer+ | TVariant <- t = hVariantToF transfer+ | TParamSpec <- t = hParamSpecToF transfer+ | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"+ | Just (APIFlags _) <- a = return "gflagsToWord"+ | Just (APIObject _) <- a = hObjectToF t transfer+ | Just (APIInterface _) <- a = hObjectToF t transfer+ | Just (APIStruct s) <- a = hStructToF s transfer+ | Just (APIUnion u) <- a = hUnionToF u transfer+ -- Converting callback types requires more context, we leave that+ -- as a special case to be implemented by the caller.+ | Just (APICallback _) <- a = error "Cannot handle callback type here!! "+ | TByteArray <- t = return $ M "packGByteArray"+ | TCArray True _ _ (TBasicType TUTF8) <- t =+ return $ M "packZeroTerminatedUTF8CArray"+ | TCArray True _ _ (TBasicType TFileName) <- t =+ return $ M "packZeroTerminatedFileNameArray"+ | TCArray True _ _ (TBasicType TPtr) <- t =+ return $ M "packZeroTerminatedPtrArray"+ | TCArray True _ _ (TBasicType TUInt8) <- t =+ return $ M "packZeroTerminatedByteString"+ | TCArray True _ _ (TBasicType TBoolean) <- t =+ return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))"+ | TCArray True _ _ (TBasicType TGType) <- t =+ return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)"+ | TCArray True _ _ (TBasicType _) <- t =+ return $ M "packZeroTerminatedStorableArray"+ | TCArray False _ _ (TBasicType TUTF8) <- t =+ return $ M "packUTF8CArray"+ | TCArray False _ _ (TBasicType TFileName) <- t =+ return $ M "packFileNameArray"+ | TCArray False _ _ (TBasicType TPtr) <- t =+ return $ M "packPtrArray"+ | TCArray False _ _ (TBasicType TUInt8) <- t =+ return $ M "packByteString"+ | TCArray False _ _ (TBasicType TBoolean) <- t =+ return $ M "(packMapStorableArray (fromIntegral . fromEnum))"+ | TCArray False _ _ (TBasicType TGType) <- t =+ return $ M "(packMapStorableArray gtypeToCGType)"+ | TCArray False _ _ (TBasicType TFloat) <- t =+ return $ M "(packMapStorableArray realToFrac)"+ | TCArray False _ _ (TBasicType TDouble) <- t =+ return $ M "(packMapStorableArray realToFrac)"+ | TCArray False _ _ (TBasicType _) <- t =+ return $ M "packStorableArray"+ | TCArray{} <- t = notImplementedError $+ "Don't know how to pack C array of type " <> tshow t+ | otherwise = case (tshow hType, tshow fType) of+ ("T.Text", "CString") -> return $ M "textToCString"+ ("[Char]", "CString") -> return $ M "stringToCString"+ ("Char", "CInt") -> return "(fromIntegral . ord)"+ ("Bool", "CInt") -> return "(fromIntegral . fromEnum)"+ ("Float", "CFloat") -> return "realToFrac"+ ("Double", "CDouble") -> return "realToFrac"+ ("GType", "CGType") -> return "gtypeToCGType"+ _ -> notImplementedError $+ "Don't know how to convert "+ <> tshow hType <> " into "+ <> tshow fType <> ".\n"+ <> "Internal type: "+ <> tshow t++getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor+getForeignConstructor t transfer = do+ a <- findAPI t+ hType <- haskellType t+ fType <- foreignType t+ hToF' t a hType fType transfer++hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter+hToF_PackedType t packer transfer = do+ innerConstructor <- getForeignConstructor t transfer+ return $ do+ mapC innerConstructor+ apply (M packer)++-- | Try to find the `hash` and `equal` functions appropriate for the+-- given type, when used as a key in a GHashTable.+hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text)+hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual")+hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual")+hashTableKeyMappings t =+ notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported."++-- | `GHashTable` tries to fit every type into a pointer, the+-- following function tries to find the appropriate+-- (destroy,packer,unpacker) for the given type.+hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text)+hashTablePtrPackers (TBasicType TPtr) =+ return ("Nothing", "ptrPackPtr", "ptrUnpackPtr")+hashTablePtrPackers (TBasicType TUTF8) =+ return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr")+hashTablePtrPackers t =+ notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported."++hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter+hToF_PackGHashTable keys elems = do+ -- We will be adding elements to the Hash list with appropriate+ -- destructors, so we always want a fresh copy.+ keysConstructor <- getForeignConstructor keys TransferEverything+ elemsConstructor <- getForeignConstructor elems TransferEverything+ (keyHash, keyEqual) <- hashTableKeyMappings keys+ (keyDestroy, keyPack, _) <- hashTablePtrPackers keys+ (elemDestroy, elemPack, _) <- hashTablePtrPackers elems+ return $ do+ apply (P "Map.toList")+ mapFirst keysConstructor+ mapSecond elemsConstructor+ mapFirst (P keyPack)+ mapSecond (P elemPack)+ apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual,+ keyDestroy, elemDestroy]))++hToF :: Type -> Transfer -> ExcCodeGen Converter+hToF (TGList t) transfer = hToF_PackedType t "packGList" transfer+hToF (TGSList t) transfer = hToF_PackedType t "packGSList" transfer+hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer+hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer+hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb+-- Arrays without length info are just passed along.+hToF (TCArray False (-1) (-1) _) _ = return $ Pure ()+hToF (TCArray zt _ _ t@(TCArray{})) transfer = do+ let packer = if zt+ then "packZeroTerminated"+ else "pack"+ hToF_PackedType t (packer <> "PtrArray") transfer++hToF (TCArray zt _ _ t@(TInterface _ _)) transfer = do+ isScalar <- getIsScalar t+ let packer = if zt+ then "packZeroTerminated"+ else "pack"+ if isScalar+ then hToF_PackedType t (packer <> "StorableArray") transfer+ else do+ api <- findAPI t+ let size = case api of+ Just (APIStruct s) -> structSize s+ Just (APIUnion u) -> unionSize u+ _ -> 0+ if size == 0 || zt+ then hToF_PackedType t (packer <> "PtrArray") transfer+ else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer++hToF t transfer = do+ a <- findAPI t+ hType <- haskellType t+ fType <- foreignType t+ constructor <- hToF' t a hType fType transfer+ return $ apply constructor++boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor+boxedForeignPtr constructor transfer = return $+ case transfer of+ TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor+ _ -> M $ parenthesize $ "newBoxed " <> constructor++suForeignPtr :: Bool -> Int -> TypeRep -> Transfer -> CodeGen Constructor+suForeignPtr isBoxed size hType transfer = do+ let constructor = T.pack . tyConName . typeRepTyCon $ hType+ if isBoxed then+ boxedForeignPtr constructor transfer+ else case size of+ 0 -> do+ line "-- XXX Wrapping a foreign struct/union with no known destructor, leak?"+ return $ M $ parenthesize $+ "\\x -> " <> constructor <> " <$> newForeignPtr_ x"+ n -> return $ M $ parenthesize $+ case transfer of+ TransferEverything -> "wrapPtr " <> constructor+ _ -> "newPtr " <> tshow n <> " " <> constructor++structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor+structForeignPtr s =+ suForeignPtr (structIsBoxed s) (structSize s)++unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor+unionForeignPtr u =+ suForeignPtr (unionIsBoxed u) (unionSize u)++fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor+fObjectToH t hType transfer = do+ let constructor = T.pack . tyConName . typeRepTyCon $ hType+ isGO <- isGObject t+ case transfer of+ TransferEverything ->+ if isGO+ then return $ M $ parenthesize $ "wrapObject " <> constructor+ else badIntroError "Got a transfer of something not a GObject"+ _ ->+ if isGO+ then return $ M $ parenthesize $ "newObject " <> constructor+ else badIntroError "Wrapping not a GObject with no copy..."++fCallbackToH :: Callback -> TypeRep -> Transfer -> ExcCodeGen Constructor+fCallbackToH _ _ _ =+ notImplementedError "Wrapping foreign callbacks is not supported yet"++fVariantToH :: Transfer -> CodeGen Constructor+fVariantToH transfer =+ return $ M $ case transfer of+ TransferEverything -> "wrapGVariantPtr"+ _ -> "newGVariantFromPtr"++fParamSpecToH :: Transfer -> CodeGen Constructor+fParamSpecToH transfer =+ return $ M $ case transfer of+ TransferEverything -> "wrapGParamSpecPtr"+ _ -> "newGParamSpecFromPtr"++fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer+ -> ExcCodeGen Constructor+fToH' t a hType fType transfer+ | ( hType == fType ) = return Id+ | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)"+ | Just (APIFlags _) <- a = return "wordToGFlags"+ | TError <- t = boxedForeignPtr "GError" transfer+ | TVariant <- t = fVariantToH transfer+ | TParamSpec <- t = fParamSpecToH transfer+ | Just (APIStruct s) <- a = structForeignPtr s hType transfer+ | Just (APIUnion u) <- a = unionForeignPtr u hType transfer+ | Just (APIObject _) <- a = fObjectToH t hType transfer+ | Just (APIInterface _) <- a = fObjectToH t hType transfer+ | Just (APICallback c) <- a = fCallbackToH c hType transfer+ | TCArray True _ _ (TBasicType TUTF8) <- t =+ return $ M "unpackZeroTerminatedUTF8CArray"+ | TCArray True _ _ (TBasicType TFileName) <- t =+ return $ M "unpackZeroTerminatedFileNameArray"+ | TCArray True _ _ (TBasicType TUInt8) <- t =+ return $ M "unpackZeroTerminatedByteString"+ | TCArray True _ _ (TBasicType TPtr) <- t =+ return $ M "unpackZeroTerminatedPtrArray"+ | TCArray True _ _ (TBasicType TBoolean) <- t =+ return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))"+ | TCArray True _ _ (TBasicType TGType) <- t =+ return $ M "(unpackMapZeroTerminatedStorableArray GType)"+ | TCArray True _ _ (TBasicType TFloat) <- t =+ return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"+ | TCArray True _ _ (TBasicType TDouble) <- t =+ return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"+ | TCArray True _ _ (TBasicType _) <- t =+ return $ M "unpackZeroTerminatedStorableArray"+ | TCArray{} <- t = notImplementedError $+ "Don't know how to unpack C array of type " <> tshow t+ | TByteArray <- t = return $ M "unpackGByteArray"+ | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet"+ | otherwise = case (tshow fType, tshow hType) of+ ("CString", "T.Text") -> return $ M "cstringToText"+ ("CString", "[Char]") -> return $ M "cstringToString"+ ("CInt", "Char") -> return "(chr . fromIntegral)"+ ("CInt", "Bool") -> return "(/= 0)"+ ("CFloat", "Float") -> return "realToFrac"+ ("CDouble", "Double") -> return "realToFrac"+ ("CGType", "GType") -> return "GType"+ _ ->+ notImplementedError $ "Don't know how to convert "+ <> tshow fType <> " into "+ <> tshow hType <> ".\n"+ <> "Internal type: "+ <> tshow t++getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor+getHaskellConstructor t transfer = do+ a <- findAPI t+ hType <- haskellType t+ fType <- foreignType t+ fToH' t a hType fType transfer++fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter+fToH_PackedType t unpacker transfer = do+ innerConstructor <- getHaskellConstructor t transfer+ return $ do+ apply (M unpacker)+ mapC innerConstructor++fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter+fToH_UnpackGHashTable keys elems transfer = do+ keysConstructor <- getHaskellConstructor keys transfer+ (_,_,keysUnpack) <- hashTablePtrPackers keys+ elemsConstructor <- getHaskellConstructor elems transfer+ (_,_,elemsUnpack) <- hashTablePtrPackers elems+ return $ do+ apply (M "unpackGHashTable")+ mapFirst (P keysUnpack)+ mapFirst keysConstructor+ mapSecond (P elemsUnpack)+ mapSecond elemsConstructor+ apply (P "Map.fromList")++fToH :: Type -> Transfer -> ExcCodeGen Converter++fToH (TGList t) transfer = fToH_PackedType t "unpackGList" transfer+fToH (TGSList t) transfer = fToH_PackedType t "unpackGSList" transfer+fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer+fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer+fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer+-- Arrays without length info are just passed along.+fToH (TCArray False (-1) (-1) _) _ = return $ Pure ()+fToH (TCArray True _ _ t@(TCArray{})) transfer =+ fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer+fToH (TCArray True _ _ t@(TInterface _ _)) transfer = do+ isScalar <- getIsScalar t+ if isScalar+ then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer+ else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer++fToH t transfer = do+ a <- findAPI t+ hType <- haskellType t+ fType <- foreignType t+ constructor <- fToH' t a hType fType transfer+ return $ apply constructor++unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter+unpackCArray length (TCArray False _ _ t) transfer =+ case t of+ TBasicType TUTF8 -> return $ apply $ M $ parenthesize $+ "unpackUTF8CArrayWithLength " <> length+ TBasicType TFileName -> return $ apply $ M $ parenthesize $+ "unpackFileNameArrayWithLength " <> length+ TBasicType TUInt8 -> return $ apply $ M $ parenthesize $+ "unpackByteStringWithLength " <> length+ TBasicType TPtr -> return $ apply $ M $ parenthesize $+ "unpackPtrArrayWithLength " <> length+ TBasicType TBoolean -> return $ apply $ M $ parenthesize $+ "unpackMapStorableArrayWithLength (/= 0) " <> length+ TBasicType TGType -> return $ apply $ M $ parenthesize $+ "unpackMapStorableArrayWithLength GType " <> length+ TBasicType TFloat -> return $ apply $ M $ parenthesize $+ "unpackMapStorableArrayWithLength realToFrac " <> length+ TBasicType TDouble -> return $ apply $ M $ parenthesize $+ "unpackMapStorableArrayWithLength realToFrac " <> length+ TBasicType _ -> return $ apply $ M $ parenthesize $+ "unpackStorableArrayWithLength " <> length+ TInterface _ _ -> do+ a <- findAPI t+ isScalar <- getIsScalar t+ hType <- haskellType t+ fType <- foreignType t+ innerConstructor <- fToH' t a hType fType transfer+ let (boxed, size) = case a of+ Just (APIStruct s) -> (structIsBoxed s, structSize s)+ Just (APIUnion u) -> (unionIsBoxed u, unionSize u)+ _ -> (False, 0)+ let unpacker | isScalar = "unpackStorableArrayWithLength"+ | (size == 0) = "unpackPtrArrayWithLength"+ | boxed = "unpackBoxedArrayWithLength " <> tshow size+ | otherwise = "unpackBlockArrayWithLength " <> tshow size+ return $ do+ apply $ M $ parenthesize $ unpacker <> " " <> length+ mapC innerConstructor+ _ -> notImplementedError $+ "unpackCArray : Don't know how to unpack C Array of type " <> tshow t++unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type."++-- Given a type find the typeclasses the type belongs to, and return+-- the representation of the type in the function signature and the+-- list of typeclass constraints for the type.+argumentType :: [Char] -> Type -> CodeGen ([Char], Text, [Text])+argumentType [] _ = error "out of letters"+argumentType letters (TGList a) = do+ (ls, name, constraints) <- argumentType letters a+ return (ls, "[" <> name <> "]", constraints)+argumentType letters (TGSList a) = do+ (ls, name, constraints) <- argumentType letters a+ return (ls, "[" <> name <> "]", constraints)+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 (APIObject _) -> do+ isGO <- isGObject t+ if isGO+ then return (ls, T.singleton l,+ [classConstraint s <> " " <> T.singleton l])+ else return (letters, s, [])+ _ -> return (letters, s, [])++haskellBasicType TPtr = ptr $ typeOf ()+haskellBasicType TBoolean = typeOf True+-- For all the platforms that we support (and those supported by glib)+-- we have gint == gint32. Encoding this assumption in the types saves+-- conversions.+haskellBasicType TInt = case sizeOf (0 :: CInt) of+ 4 -> typeOf (0 :: Int32)+ n -> error ("Unsupported `gint' length: " +++ show n)+haskellBasicType TUInt = case sizeOf (0 :: CUInt) of+ 4 -> typeOf (0 :: Word32)+ n -> error ("Unsupported `guint' length: " +++ show n)+haskellBasicType TLong = typeOf (0 :: CLong)+haskellBasicType TULong = typeOf (0 :: CULong)+haskellBasicType TInt8 = typeOf (0 :: Int8)+haskellBasicType TUInt8 = typeOf (0 :: Word8)+haskellBasicType TInt16 = typeOf (0 :: Int16)+haskellBasicType TUInt16 = typeOf (0 :: Word16)+haskellBasicType TInt32 = typeOf (0 :: Int32)+haskellBasicType TUInt32 = typeOf (0 :: Word32)+haskellBasicType TInt64 = typeOf (0 :: Int64)+haskellBasicType TUInt64 = typeOf (0 :: Word64)+haskellBasicType TGType = "GType" `con` []+haskellBasicType TUTF8 = "T.Text" `con` []+haskellBasicType TFloat = typeOf (0 :: Float)+haskellBasicType TDouble = typeOf (0 :: Double)+haskellBasicType TUniChar = typeOf ('\0' :: Char)+haskellBasicType TFileName = "[Char]" `con` []+haskellBasicType TIntPtr = "CIntPtr" `con` []+haskellBasicType TUIntPtr = "CUIntPtr" `con` []++-- This translates GI types to the types used for generated Haskell code.+haskellType :: Type -> CodeGen TypeRep+haskellType (TBasicType bt) = return $ haskellBasicType bt+-- We cannot really do anything sensible for a foreign array with no+-- length info, so just pass the pointer along.+haskellType (TCArray False (-1) (-1) t) =+ ptr <$> foreignType t+haskellType (TCArray _ _ _ (TBasicType TUInt8)) =+ return $ "ByteString" `con` []+haskellType (TCArray _ _ _ a) = do+ inner <- haskellType a+ return $ "[]" `con` [inner]+haskellType (TGArray a) = do+ inner <- haskellType a+ return $ "[]" `con` [inner]+haskellType (TPtrArray a) = do+ inner <- haskellType a+ return $ "[]" `con` [inner]+haskellType (TByteArray) = return $ "ByteString" `con` []+haskellType (TGList a) = do+ inner <- haskellType a+ return $ "[]" `con` [inner]+haskellType (TGSList a) = do+ inner <- haskellType a+ return $ "[]" `con` [inner]+haskellType (TGHash a b) = do+ innerA <- haskellType a+ innerB <- haskellType b+ return $ "Map.Map" `con` [innerA, innerB]+haskellType TError = return $ "GError" `con` []+haskellType TVariant = return $ "GVariant" `con` []+haskellType TParamSpec = return $ "GParamSpec" `con` []+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` []+ return $ case api of+ Just (APIFlags _) -> "[]" `con` [tname]+ _ -> tname++foreignBasicType TBoolean = "CInt" `con` []+foreignBasicType TUTF8 = "CString" `con` []+foreignBasicType TFileName = "CString" `con` []+foreignBasicType TUniChar = "CInt" `con` []+foreignBasicType TFloat = "CFloat" `con` []+foreignBasicType TDouble = "CDouble" `con` []+foreignBasicType TGType = "CGType" `con` []+foreignBasicType t = haskellBasicType t++-- This translates GI types to the types used in foreign function calls.+foreignType :: Type -> CodeGen TypeRep+foreignType (TBasicType t) = return $ foreignBasicType t+foreignType (TCArray False (-1) (-1) t) =+ ptr <$> foreignType t+foreignType (TCArray zt _ _ t) = do+ api <- findAPI t+ let size = case api of+ Just (APIStruct s) -> structSize s+ Just (APIUnion u) -> unionSize u+ _ -> 0+ if size == 0 || zt+ then ptr <$> foreignType t+ else foreignType t+foreignType (TGArray a) = do+ inner <- foreignType a+ return $ ptr ("GArray" `con` [inner])+foreignType (TPtrArray a) = do+ inner <- foreignType a+ return $ ptr ("GPtrArray" `con` [inner])+foreignType (TByteArray) = return $ ptr ("GByteArray" `con` [])+foreignType (TGList a) = do+ inner <- foreignType a+ return $ ptr ("GList" `con` [inner])+foreignType (TGSList a) = do+ inner <- foreignType a+ return $ ptr ("GSList" `con` [inner])+foreignType (TGHash a b) = do+ innerA <- foreignType a+ innerB <- foreignType b+ return $ ptr ("GHashTable" `con` [innerA, innerB])+foreignType t@TError = ptr <$> haskellType t+foreignType t@TVariant = ptr <$> haskellType t+foreignType t@TParamSpec = ptr <$> haskellType t+foreignType (TInterface "GObject" "Value") = return $ ptr $ "GValue" `con` []+foreignType (TInterface "GObject" "Closure") =+ return $ ptr $ "Closure" `con` []+foreignType t@(TInterface ns n) = do+ isScalar <- getIsScalar t+ 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` []++getIsScalar :: Type -> CodeGen Bool+getIsScalar t = do+ a <- findAPI t+ case a of+ Nothing -> return False+ (Just (APIEnum _)) -> return True+ (Just (APIFlags _)) -> return True+ _ -> return False++-- Whether the given type corresponds to a struct we allocate+-- ourselves. If we need to allocate the struct we return its size in+-- bytes and whether the type is boxed, otherwise we return Nothing.+requiresAlloc :: Type -> CodeGen (Maybe (Bool, Int))+requiresAlloc t = do+ api <- findAPI t+ case api of+ Just (APIStruct s) -> case structSize s of+ 0 -> return Nothing+ n -> return (Just (structIsBoxed s, n))+ _ -> return Nothing++-- Returns whether the given type corresponds to a ManagedPtr+-- instance (a thin wrapper over a ForeignPtr).+isManaged :: Type -> CodeGen Bool+isManaged t = do+ a <- findAPI t+ case a of+ Just (APIObject _) -> return True+ Just (APIInterface _) -> return True+ Just (APIStruct _) -> return True+ Just (APIUnion _) -> return True+ _ -> return False++-- | Returns whether the given type is represented by a pointer on the+-- C side.+typeIsPtr :: Type -> CodeGen Bool+typeIsPtr (TBasicType TPtr) = return True+typeIsPtr (TBasicType TUTF8) = return True+typeIsPtr (TBasicType TFileName) = return True+typeIsPtr t = do+ ft <- foreignType t+ return (tyConName (typeRepTyCon ft) `elem` ["Ptr", "FunPtr"])++-- | Returns whether the given type should be represented by a+-- `Maybe` type on the Haskell side. This applies to all properties+-- which have a C representation in terms of pointers, except for+-- G(S)Lists, for which NULL is a valid G(S)List, and raw pointers,+-- which we just pass through to the Haskell side. Notice that+-- introspection annotations can override this.+typeIsNullable :: Type -> CodeGen Bool+typeIsNullable t = case t of+ TBasicType TPtr -> return False+ TGList _ -> return False+ TGSList _ -> return False+ _ -> typeIsPtr t++-- If the given type maps to a list in Haskell, return the type of the+-- elements, and the function that maps over them.+elementTypeAndMap :: Type -> Text -> Maybe (Type, Text)+-- Passed along as a raw pointer.+elementTypeAndMap (TCArray False (-1) (-1) _) _ = Nothing+-- ByteString+elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing+elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray")+elementTypeAndMap (TCArray False (-1) _ t) len =+ Just (t, parenthesize $ "mapCArrayWithLength " <> len)+elementTypeAndMap (TCArray False fixed _ t) _ =+ Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed)+elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray")+elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray")+elementTypeAndMap (TGList t) _ = Just (t, "mapGList")+elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList")+-- GHashTable is treated separately, see Transfer.hs+elementTypeAndMap _ _ = Nothing++-- Return just the element type.+elementType :: Type -> Maybe Type+elementType t = fst <$> elementTypeAndMap t undefined++-- Return just the map.+elementMap :: Type -> Text -> Maybe Text+elementMap t len = snd <$> elementTypeAndMap t len
+ lib/Data/GI/CodeGen/Fixups.hs view
@@ -0,0 +1,118 @@+-- | Various fixups in the introspection data.+module Data.GI.CodeGen.Fixups+ ( dropMovedItems+ , guessPropertyNullability+ ) where++import Data.Maybe (isNothing, isJust)+import Data.Monoid ((<>))+import qualified Data.Text as T++import Data.GI.CodeGen.API++-- | Remove functions and methods annotated with "moved-to".+dropMovedItems :: API -> Maybe API+dropMovedItems (APIFunction f) = if fnMovedTo f == Nothing+ then Just (APIFunction f)+ else Nothing+dropMovedItems (APIInterface i) =+ (Just . APIInterface) i {ifMethods = filterMovedMethods (ifMethods i)}+dropMovedItems (APIObject o) =+ (Just . APIObject) o {objMethods = filterMovedMethods (objMethods o)}+dropMovedItems (APIStruct s) =+ (Just . APIStruct) s {structMethods = filterMovedMethods (structMethods s)}+dropMovedItems (APIUnion u) =+ (Just . APIUnion) u {unionMethods = filterMovedMethods (unionMethods u)}+dropMovedItems a = Just a++-- | Drop the moved methods.+filterMovedMethods :: [Method] -> [Method]+filterMovedMethods = filter (isNothing . methodMovedTo)++-- | GObject-introspection does not currently support nullability+-- annotations, so we try to guess the nullability from the+-- nullability annotations of the curresponding get/set methods, which+-- in principle should be reliable.+guessPropertyNullability :: (Name, API) -> (Name, API)+guessPropertyNullability (n, APIObject obj) =+ (n, APIObject (guessObjectPropertyNullability obj))+guessPropertyNullability (n, APIInterface iface) =+ (n, APIInterface (guessInterfacePropertyNullability iface))+guessPropertyNullability other = other++-- | Guess nullability for the properties of an object.+guessObjectPropertyNullability :: Object -> Object+guessObjectPropertyNullability obj =+ obj {objProperties = map (guessNullability (objMethods obj))+ (objProperties obj)}++-- | Guess nullability for the properties of an interface.+guessInterfacePropertyNullability :: Interface -> Interface+guessInterfacePropertyNullability iface =+ iface {ifProperties = map (guessNullability (ifMethods iface))+ (ifProperties iface)}++-- | Guess the nullability for a property, given the list of methods+-- for the object/interface.+guessNullability :: [Method] -> Property -> Property+guessNullability methods = guessReadNullability methods+ . guessWriteNullability methods++-- | Guess whether "get" on the given property may return NULL, based+-- on the corresponding "get_prop_name" method, if it exists.+guessReadNullability :: [Method] -> Property -> Property+guessReadNullability methods p+ | isJust (propReadNullable p) = p+ | otherwise = p {propReadNullable = nullableGetter}+ where+ nullableGetter :: Maybe Bool+ nullableGetter =+ let prop_name = T.replace "-" "_" (propName p)+ in case findMethod methods ("get_" <> prop_name) of+ Nothing -> Nothing+ -- Check that it looks like a sensible getter+ -- for the property.+ Just m ->+ let c = methodCallable m+ in if length (args c) == 0 &&+ returnType c == Just (propType p) &&+ returnTransfer c == TransferNothing &&+ skipReturn c == False &&+ methodThrows m == False &&+ methodType m == OrdinaryMethod &&+ methodMovedTo m == Nothing+ then Just (returnMayBeNull c)+ else Nothing++-- | Guess whether "set" on the given property may return NULL, based+-- on the corresponding "set_prop_name" method, if it exists.+guessWriteNullability :: [Method] -> Property -> Property+guessWriteNullability methods p+ | isJust (propWriteNullable p) = p+ | otherwise = p {propWriteNullable = nullableSetter}+ where+ nullableSetter :: Maybe Bool+ nullableSetter =+ let prop_name = T.replace "-" "_" (propName p)+ in case findMethod methods ("set_" <> prop_name) of+ Nothing -> Nothing+ -- Check that it looks like a sensible setter.+ Just m ->+ let c = methodCallable m+ in if length (args c) == 1 &&+ (argType . head . args) c == propType p &&+ returnType c == Nothing &&+ (transfer . head . args) c == TransferNothing &&+ (direction . head . args) c == DirectionIn &&+ methodMovedTo m == Nothing &&+ methodType m == OrdinaryMethod &&+ methodThrows m == False+ then Just ((mayBeNull . head . args) c)+ else Nothing++-- | Find the first method with the given name, if any.+findMethod :: [Method] -> T.Text -> Maybe Method+findMethod methods n =+ case filter ((== n) . name . methodName) methods of+ [m] -> Just m+ _ -> Nothing
+ lib/Data/GI/CodeGen/GObject.hs view
@@ -0,0 +1,52 @@+module Data.GI.CodeGen.GObject+ ( isGObject+ , apiIsGObject+ , nameIsGObject+ , isInitiallyUnowned+ , apiIsInitiallyUnowned+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Type++-- Returns whether the given type is a descendant of the given parent.+typeDoParentSearch :: Name -> Type -> CodeGen Bool+typeDoParentSearch parent (TInterface ns n) = findAPIByName name >>=+ apiDoParentSearch parent name+ where name = Name ns n+typeDoParentSearch _ _ = return False++apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool+apiDoParentSearch parent n api+ | parent == n = return True+ | otherwise = case api of+ APIObject o ->+ case objParent o of+ Just (Name pns pn) -> typeDoParentSearch parent (TInterface pns pn)+ Nothing -> return False+ APIInterface iface ->+ do let prs = ifPrerequisites iface+ prereqs <- zip prs <$> mapM findAPIByName prs+ or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs+ _ -> return False++isGObject :: Type -> CodeGen Bool+isGObject = typeDoParentSearch $ Name "GObject" "Object"++-- | Check whether the given name descends from GObject.+nameIsGObject :: Name -> CodeGen Bool+nameIsGObject n = findAPIByName n >>= apiIsGObject n++apiIsGObject :: Name -> API -> CodeGen Bool+apiIsGObject = apiDoParentSearch $ Name "GObject" "Object"++isInitiallyUnowned :: Type -> CodeGen Bool+isInitiallyUnowned = typeDoParentSearch $ Name "GObject" "InitiallyUnowned"++apiIsInitiallyUnowned :: Name -> API -> CodeGen Bool+apiIsInitiallyUnowned = apiDoParentSearch $ Name "GObject" "InitiallyUnowned"
+ lib/Data/GI/CodeGen/GType.hsc view
@@ -0,0 +1,24 @@+module Data.GI.CodeGen.GType+ ( GType -- Reexport from Data.GI.Base.BasicTypes for convenience+ , gtypeIsA+ , gtypeIsBoxed+ ) where++#include <glib-object.h>++import Foreign.C+import System.IO.Unsafe (unsafePerformIO)+import Data.GI.Base.BasicTypes (CGType, GType(..))++foreign import ccall unsafe "g_type_is_a" g_type_is_a ::+ CGType -> CGType -> IO CInt++gtypeIsA :: GType -> GType -> Bool+gtypeIsA (GType gtype) (GType is_a) = (/= 0) $+ unsafePerformIO $ g_type_is_a gtype is_a++gtypeBoxed :: GType+gtypeBoxed = GType #const G_TYPE_BOXED++gtypeIsBoxed :: GType -> Bool+gtypeIsBoxed gtype = gtypeIsA gtype gtypeBoxed
+ lib/Data/GI/CodeGen/Inheritance.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.GI.CodeGen.Inheritance+ ( fullObjectPropertyList+ , fullInterfacePropertyList+ , fullObjectSignalList+ , fullInterfaceSignalList+ , fullObjectMethodList+ , fullInterfaceMethodList+ , instanceTree+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (foldM, when)+import qualified Data.Map as M+import Data.Text (Text)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code (findAPIByName, CodeGen, line, (<>))+import Data.GI.CodeGen.Util (tshow)++-- | Find the parent of a given object when building the+-- instanceTree. For the purposes of the binding we do not need to+-- distinguish between GObject.Object and GObject.InitiallyUnowned.+getParent :: API -> Maybe Name+getParent (APIObject o) = rename $ objParent o+ where+ rename :: Maybe Name -> Maybe Name+ rename (Just (Name "GObject" "InitiallyUnowned")) =+ Just (Name "GObject" "Object")+ rename x = x+getParent _ = Nothing++-- | Compute the (ordered) list of parents of the current object.+instanceTree :: Name -> CodeGen [Name]+instanceTree n = do+ api <- findAPIByName n+ case getParent api of+ Just p -> (p :) <$> instanceTree p+ Nothing -> return []++-- A class for qualities of an object/interface that it inherits from+-- its ancestors. Properties and Signals are two classes of interest.+class Inheritable i where+ ifInheritables :: Interface -> [i]+ objInheritables :: Object -> [i]+ iName :: i -> Text++instance Inheritable Property where+ ifInheritables = ifProperties+ objInheritables = objProperties+ iName = propName++instance Inheritable Signal where+ ifInheritables = ifSignals+ objInheritables = objSignals+ iName = sigName++instance Inheritable Method where+ ifInheritables = ifMethods+ objInheritables = objMethods+ iName = name . methodName++-- Returns a list of all inheritables defined for this object+-- (including those defined by its ancestors and the interfaces it+-- implements), together with the name of the interface defining the+-- property.+apiInheritables :: Inheritable i => Name -> CodeGen [(Name, i)]+apiInheritables n = do+ api <- findAPIByName n+ case api of+ APIInterface iface -> return $ map ((,) n) (ifInheritables iface)+ APIObject object -> return $ map ((,) n) (objInheritables object)+ _ -> error $ "apiInheritables : Unexpected API : " ++ show n++fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)]+fullAPIInheritableList n = do+ api <- findAPIByName n+ case api of+ APIInterface iface -> fullInterfaceInheritableList n iface+ APIObject object -> fullObjectInheritableList n object+ _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n++fullObjectInheritableList :: Inheritable i => Name -> Object ->+ CodeGen [(Name, i)]+fullObjectInheritableList n obj = do+ iT <- instanceTree n+ (++) <$> (concat <$> mapM apiInheritables (n : iT))+ <*> (concat <$> mapM apiInheritables (objInterfaces obj))++fullInterfaceInheritableList :: Inheritable i => Name -> Interface ->+ CodeGen [(Name, i)]+fullInterfaceInheritableList n iface =+ (++) (map ((,) n) (ifInheritables iface))+ <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface))++-- It is sometimes the case that a property name or signal is defined+-- both in an object and in one of its ancestors/implemented+-- interfaces. This is harmless if the properties are isomorphic+-- (there will be more than one qualified set of property+-- setters/getters that we can call, but they are all isomorphic). If+-- they are not isomorphic we refuse to set either, and print a+-- warning in the generated code.+removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) =>+ Bool -> [(Name, i)] -> CodeGen [(Name, i)]+removeDuplicates verbose inheritables =+ (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables+ where+ filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) ->+ CodeGen (M.Map Text (Bool, Name, i))+ filterDups m (name, prop) =+ case M.lookup (iName prop) m of+ Just (tainted, n, p)+ | tainted -> return m+ | (p == prop) -> return m -- Duplicated, but isomorphic property+ | otherwise ->+ do when verbose $ do+ line "--- XXX Duplicated object with different types:"+ line $ " --- " <> tshow n <> " -> " <> tshow p+ line $ " --- " <> tshow name <> " -> " <> tshow prop+ -- Tainted+ return $ M.insert (iName prop) (True, n, p) m+ Nothing -> return $ M.insert (iName prop) (False, name, prop) m+ filterTainted :: [(Text, (Bool, Name, i))] -> [(Name, i)]+ filterTainted xs =+ [(name, prop) | (_, (tainted, name, prop)) <- xs, not tainted]++-- | List all properties defined for an object, including those+-- defined by its ancestors.+fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)]+fullObjectPropertyList n o = fullObjectInheritableList n o >>=+ removeDuplicates True++-- | List all properties defined for an interface, including those+-- defined by its prerequisites.+fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)]+fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>=+ removeDuplicates True++-- | List all signals defined for an object, including those+-- defined by its ancestors.+fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)]+fullObjectSignalList n o = fullObjectInheritableList n o >>=+ removeDuplicates True++-- | List all signals defined for an interface, including those+-- defined by its prerequisites.+fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)]+fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>=+ removeDuplicates True++-- | List all methods defined for an object, including those defined+-- by its ancestors.+fullObjectMethodList :: Name -> Object -> CodeGen [(Name, Method)]+fullObjectMethodList n o = fullObjectInheritableList n o >>=+ removeDuplicates False++-- | List all methods defined for an interface, including those+-- defined by its prerequisites.+fullInterfaceMethodList :: Name -> Interface -> CodeGen [(Name, Method)]+fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>=+ removeDuplicates False
+ lib/Data/GI/CodeGen/LibGIRepository.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | A minimal wrapper for libgirepository.+module Data.GI.CodeGen.LibGIRepository+ ( girRequire+ , girStructSizeAndOffsets+ , girUnionSizeAndOffsets+ , girLoadGType+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad (forM, when)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.C.Types (CInt(..), CSize(..))+import Foreign.C.String (CString)+import Foreign (nullPtr, Ptr, ForeignPtr, FunPtr, peek)++import Data.GI.Base.BasicConversions (withTextCString, cstringToText)+import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType)+import Data.GI.Base.GError (GError, checkGError)+import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)+import Data.GI.Base.Utils (allocMem, freeMem)++-- | Wrapper for 'GIBaseInfo'+newtype BaseInfo = BaseInfo (ForeignPtr BaseInfo)++-- | Wrapper for 'GITypelib'+newtype Typelib = Typelib (Ptr Typelib)++foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType++instance BoxedObject BaseInfo where+ boxedType _ = c_g_base_info_gtype_get_type++foreign import ccall "g_irepository_require" g_irepository_require ::+ Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError)+ -> IO (Ptr Typelib)++-- | Ensure that the given version of the namespace is loaded. If that+-- is not possible we error out.+girRequire :: Text -> Text -> IO Typelib+girRequire ns version =+ withTextCString ns $ \cns ->+ withTextCString version $ \cversion -> do+ typelib <- checkGError (g_irepository_require nullPtr cns cversion 0)+ (error $ "Could not load typelib for "+ ++ show ns ++ " version "+ ++ show version)+ return (Typelib typelib)++foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name ::+ Ptr () -> CString -> CString -> IO (Ptr BaseInfo)++-- | Find a given baseinfo by name, or give an error if it cannot be+-- found.+girFindByName :: Text -> Text -> IO BaseInfo+girFindByName ns name =+ withTextCString ns $ \cns ->+ withTextCString name $ \cname -> do+ ptr <- g_irepository_find_by_name nullPtr cns cname+ if ptr == nullPtr+ then error ("Could not find " ++ T.unpack ns ++ "::" ++ T.unpack name)+ else wrapBoxed BaseInfo ptr++foreign import ccall "g_field_info_get_offset" g_field_info_get_offset ::+ Ptr BaseInfo -> IO CInt+foreign import ccall "g_base_info_get_name" g_base_info_get_name ::+ Ptr BaseInfo -> IO CString++foreign import ccall "g_struct_info_get_size" g_struct_info_get_size ::+ Ptr BaseInfo -> IO CSize+foreign import ccall "g_struct_info_get_n_fields" g_struct_info_get_n_fields ::+ Ptr BaseInfo -> IO CInt+foreign import ccall "g_struct_info_get_field" g_struct_info_get_field ::+ Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)++-- | Find out the size of a struct, and the map from field names to+-- offsets inside the struct.+girStructSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)+girStructSizeAndOffsets ns name = do+ baseinfo <- girFindByName ns name+ withManagedPtr baseinfo $ \si -> do+ size <- g_struct_info_get_size si+ nfields <- g_struct_info_get_n_fields si+ fieldOffsets <- forM [0..(nfields-1)] $ \i -> do+ fieldInfo <- (g_struct_info_get_field si i+ >>= wrapBoxed BaseInfo)+ withManagedPtr fieldInfo $ \fi -> do+ fname <- (g_base_info_get_name fi >>= cstringToText)+ fOffset <- g_field_info_get_offset fi+ return (fname, fromIntegral fOffset)+ return (fromIntegral size, M.fromList fieldOffsets)++foreign import ccall "g_union_info_get_size" g_union_info_get_size ::+ Ptr BaseInfo -> IO CSize+foreign import ccall "g_union_info_get_n_fields" g_union_info_get_n_fields ::+ Ptr BaseInfo -> IO CInt+foreign import ccall "g_union_info_get_field" g_union_info_get_field ::+ Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)++-- | Find out the size of a union, and the map from field names to+-- offsets inside the union.+girUnionSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)+girUnionSizeAndOffsets ns name = do+ baseinfo <- girFindByName ns name+ withManagedPtr baseinfo $ \ui -> do+ size <- g_union_info_get_size ui+ nfields <- g_union_info_get_n_fields ui+ fieldOffsets <- forM [0..(nfields-1)] $ \i -> do+ fieldInfo <- (g_union_info_get_field ui i+ >>= wrapBoxed BaseInfo)+ withManagedPtr fieldInfo $ \fi -> do+ fname <- (g_base_info_get_name fi >>= cstringToText)+ fOffset <- g_field_info_get_offset fi+ return (fname, fromIntegral fOffset)+ return (fromIntegral size, M.fromList fieldOffsets)++foreign import ccall "g_typelib_symbol" g_typelib_symbol ::+ Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt++-- | Load a symbol from the dynamic library associated to the given namespace.+girSymbol :: forall a. Text -> Text -> IO (FunPtr a)+girSymbol ns symbol = do+ typelib <- withTextCString ns $ \cns ->+ checkGError (g_irepository_require nullPtr cns nullPtr 0)+ (error $ "Could not load typelib " ++ show ns)+ funPtrPtr <- allocMem :: IO (Ptr (FunPtr a))+ result <- withTextCString symbol $ \csymbol ->+ g_typelib_symbol typelib csymbol funPtrPtr+ when (result /= 1) $+ error ("Could not resolve symbol " ++ show symbol ++ " in namespace "+ ++ show ns)+ funPtr <- peek funPtrPtr+ freeMem funPtrPtr+ return funPtr++type GTypeInit = IO CGType+foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit++-- | Load a GType given the namespace where it lives and the type init+-- function.+girLoadGType :: Text -> Text -> IO GType+girLoadGType ns typeInit = do+ funPtr <- girSymbol ns typeInit+ GType <$> gtypeInit funPtr
+ lib/Data/GI/CodeGen/OverloadedLabels.hs view
@@ -0,0 +1,94 @@+module Data.GI.CodeGen.OverloadedLabels+ ( genOverloadedLabels+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Data.Maybe (isNothing)+import Control.Monad (forM_)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.Util (lcFirst)++-- | A list of all overloadable identifiers in the set of APIs (current+-- properties and methods).+findOverloaded :: [(Name, API)] -> CodeGen [Text]+findOverloaded apis = S.toList <$> go apis S.empty+ where+ go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)+ go [] set = return set+ go ((_, api):apis) set =+ case api of+ APIInterface iface -> go apis (scanInterface iface set)+ APIObject object -> go apis (scanObject object set)+ APIStruct s -> go apis (scanStruct s set)+ APIUnion u -> go apis (scanUnion u set)+ _ -> go apis set++ scanObject :: Object -> S.Set Text -> S.Set Text+ scanObject o set =+ let props = (map propToLabel . objProperties) o+ methods = (map methodToLabel . filterMethods . objMethods) o+ in S.unions [set, S.fromList props, S.fromList methods]++ scanInterface :: Interface -> S.Set Text -> S.Set Text+ scanInterface i set =+ let props = (map propToLabel . ifProperties) i+ methods = (map methodToLabel . filterMethods . ifMethods) i+ in S.unions [set, S.fromList props, S.fromList methods]++ scanStruct :: Struct -> S.Set Text -> S.Set Text+ scanStruct s set =+ let attrs = (map fieldToLabel . filterFields . structFields) s+ methods = (map methodToLabel . filterMethods . structMethods) s+ in S.unions [set, S.fromList attrs, S.fromList methods]++ scanUnion :: Union -> S.Set Text -> S.Set Text+ scanUnion u set =+ let attrs = (map fieldToLabel . filterFields . unionFields) u+ methods = (map methodToLabel . filterMethods . unionMethods) u+ in S.unions [set, S.fromList attrs, S.fromList methods]++ propToLabel :: Property -> Text+ propToLabel = lcFirst . hyphensToCamelCase . propName++ methodToLabel :: Method -> Text+ methodToLabel = lowerName . methodName++ fieldToLabel :: Field -> Text+ fieldToLabel = lcFirst . underscoresToCamelCase . fieldName++ filterMethods :: [Method] -> [Method]+ filterMethods = filter (\m -> (isNothing . methodMovedTo) m &&+ methodType m == OrdinaryMethod)++ filterFields :: [Field] -> [Field]+ filterFields = filter (\f -> fieldVisible f &&+ (not . T.null . fieldName) f)++genOverloadedLabel :: Text -> CodeGen ()+genOverloadedLabel l = group $ do+ line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a"+ line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \""+ <> l <> "\")"+ exportToplevel ("_" <> l)++genOverloadedLabels :: [(Name, API)] -> CodeGen ()+genOverloadedLabels allAPIs = do+ setLanguagePragmas ["DataKinds", "FlexibleContexts"]+ setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]++ line $ "import Data.Proxy (Proxy(..))"+ line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))"+ blank++ labels <- findOverloaded allAPIs+ forM_ labels $ \l -> do+ genOverloadedLabel l+ blank
+ lib/Data/GI/CodeGen/OverloadedMethods.hs view
@@ -0,0 +1,106 @@+module Data.GI.CodeGen.OverloadedMethods+ ( genMethodList+ , genMethodInfo+ , genUnsupportedMethodInfo+ ) where++import Control.Monad (forM, forM_, when)+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.Util (ucFirst)++-- | Qualified name for the info for a given method.+methodInfoName :: Name -> Method -> CodeGen Text+methodInfoName n method = do+ n' <- upperName n+ let mn' = (ucFirst . lowerName . methodName) method+ return $ n' <> mn' <> "MethodInfo"++-- | Appropriate instances so overloaded labels are properly resolved.+genMethodResolver :: Text -> CodeGen ()+genMethodResolver n = do+ group $ do+ line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "+ <> "MethodInfo info " <> n <> " p) => IsLabelProxy t ("+ <> n <> " -> p) where"+ indent $ line $ "fromLabelProxy _ = overloadedMethod (MethodProxy :: MethodProxy info)"+ group $ do+ line $ "#if MIN_VERSION_base(4,9,0)"+ line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "+ <> "MethodInfo info " <> n <> " p) => IsLabel t ("+ <> n <> " -> p) where"+ indent $ line $ "fromLabel _ = overloadedMethod (MethodProxy :: MethodProxy info)"+ line $ "#endif"++-- | Generate the `MethodList` instance given the list of methods for+-- the given named type.+genMethodList :: Name -> [(Name, Method)] -> CodeGen ()+genMethodList n methods = do+ name <- upperName n+ let filteredMethods = filter isOrdinaryMethod methods+ gets = filter isGet filteredMethods+ sets = filter isSet filteredMethods+ others = filter (\m -> not (isSet m || isGet m)) filteredMethods+ orderedMethods = others ++ gets ++ sets+ infos <- forM orderedMethods $ \(owner, method) ->+ do mi <- methodInfoName owner method+ return ((lowerName . methodName) method, mi)+ group $ do+ let resolver = "Resolve" <> name <> "Method"+ line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where"+ indent $ forM_ infos $ \(label, info) -> do+ line $ resolver <> " \"" <> label <> "\" o = " <> info+ indent $ line $ resolver <> " l o = MethodResolutionFailed l o"++ genMethodResolver name++ where isOrdinaryMethod :: (Name, Method) -> Bool+ isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod++ isGet :: (Name, Method) -> Bool+ isGet (_, m) = "get_" `T.isPrefixOf` (name . methodName) m++ isSet :: (Name, Method) -> Bool+ isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m++-- | Generate the `MethodInfo` type and instance for the given method.+genMethodInfo :: Name -> Method -> ExcCodeGen ()+genMethodInfo n m =+ when (methodType m == OrdinaryMethod) $+ group $ do+ infoName <- methodInfoName n m+ let callable = fixupCallerAllocates (methodCallable m)+ (constraints, types) <- callableSignature callable (methodThrows m)+ bline $ "data " <> infoName+ -- This should not happen, since ordinary methods always+ -- have the instance as first argument.+ when (null types) $+ error $ "Internal error: too few parameters! " ++ show m+ let (obj:otherTypes) = map fst types+ sigConstraint = "signature ~ (" <> T.intercalate " -> " otherTypes+ <> ")"+ line $ "instance (" <> T.intercalate ", " (sigConstraint : constraints)+ <> ") => MethodInfo " <> infoName <> " " <> obj <> " signature where"+ let mn = methodName m+ mangled = lowerName (mn {name = name n <> "_" <> name mn})+ indent $ line $ "overloadedMethod _ = " <> mangled+ exportMethod mangled infoName++-- | Generate a method info that is not actually callable, but rather+-- gives a type error when trying to use it.+genUnsupportedMethodInfo :: Name -> Method -> CodeGen ()+genUnsupportedMethodInfo n m = do+ infoName <- methodInfoName n m+ line $ "-- XXX: Dummy instance, since code generation failed.\n"+ <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi."+ bline $ "data " <> infoName+ line $ "instance (p ~ (), o ~ MethodResolutionFailed \""+ <> lowerName (methodName m) <> "\" " <> name n+ <> ") => MethodInfo " <> infoName <> " o p where"+ indent $ line $ "overloadedMethod _ = undefined"+ exportMethod "Unsupported methods" infoName
+ lib/Data/GI/CodeGen/OverloadedSignals.hs view
@@ -0,0 +1,122 @@+module Data.GI.CodeGen.OverloadedSignals+ ( genObjectSignals+ , genInterfaceSignals+ , genOverloadedSignalConnectors+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, when)+import Data.Text (Text)+import qualified Data.Text as T++import qualified Data.Set as S++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+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.Util (lcFirst, ucFirst)++-- A list of distinct signal names for all GObjects appearing in the+-- given list of APIs.+findSignalNames :: [(Name, API)] -> CodeGen [Text]+findSignalNames apis = S.toList <$> go apis S.empty+ where+ go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)+ go [] set = return set+ go ((_, api):apis) set =+ case api of+ APIInterface iface ->+ go apis $ insertSignals (ifSignals iface) set+ APIObject object ->+ go apis $ insertSignals (objSignals object) set+ _ -> go apis set++ insertSignals :: [Signal] -> S.Set Text -> S.Set Text+ insertSignals props set = foldr (S.insert . sigName) set props++-- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ...+genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen ()+genOverloadedSignalConnectors allAPIs = do+ setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP",+ -- For ghc 7.8 support+ "RankNTypes", "ScopedTypeVariables", "TypeFamilies"]+ setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]++ line "import Data.GI.Base.Signals (SignalProxy(..))"+ line "import Data.GI.Base.Overloading (ResolveSignal)"+ blank+ signalNames <- findSignalNames allAPIs+ forM_ signalNames $ \sn -> group $ do+ let camelName = hyphensToCamelCase sn+ line $ "#if MIN_VERSION_base(4,8,0)"+ line $ "pattern " <> camelName <>+ " :: SignalProxy object (ResolveSignal \""+ <> lcFirst camelName <> "\" object)"+ line $ "pattern " <> camelName <> " = SignalProxy"+ line $ "#else"+ line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. "+ <> "info ~ ResolveSignal \"" <> lcFirst camelName+ <> "\" object => SignalProxy object info"+ line $ "#endif"+ exportDecl $ "pattern " <> camelName++-- | Qualified name for the "(sigName, info)" tag for a given signal.+signalInfoName :: Name -> Signal -> CodeGen Text+signalInfoName n signal = do+ n' <- upperName n+ return $ n' <> (ucFirst . signalHaskellName . sigName) signal+ <> "SignalInfo"++-- | Generate the given signal instance for the given API object.+genInstance :: Name -> Signal -> CodeGen ()+genInstance owner signal = group $ do+ name <- upperName owner+ let sn = (ucFirst . signalHaskellName . sigName) signal+ si <- signalInfoName owner signal+ bline $ "data " <> si+ line $ "instance SignalInfo " <> si <> " where"+ indent $ do+ let signalConnectorName = name <> sn+ cbHaskellType = signalConnectorName <> "Callback"+ line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType+ line $ "connectSignal _ = " <> "connect" <> name <> sn+ exportSignal sn si++-- | Signal instances for (GObject-derived) objects.+genObjectSignals :: Name -> Object -> CodeGen ()+genObjectSignals n o = do+ name <- upperName n+ isGO <- apiIsGObject n (APIObject o)+ when isGO $ do+ mapM_ (genInstance n) (objSignals o)+ infos <- fullObjectSignalList n o >>=+ mapM (\(owner, signal) -> do+ si <- signalInfoName owner signal+ return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal+ <> "\", " <> si <> ")")+ group $ do+ let signalListType = name <> "SignalList"+ line $ "type instance 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+ mapM_ (genInstance n) (ifSignals iface)+ infos <- fullInterfaceSignalList n iface >>=+ mapM (\(owner, signal) -> do+ si <- signalInfoName owner signal+ return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal+ <> "\", " <> si <> ")")+ group $ do+ let signalListType = name <> "SignalList"+ line $ "type instance SignalList " <> name <> " = " <> signalListType+ line $ "type " <> signalListType <> " = ('[ "+ <> T.intercalate ", " infos <> "] :: [(Symbol, *)])"
+ lib/Data/GI/CodeGen/Overrides.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE ViewPatterns #-}+module Data.GI.CodeGen.Overrides+ ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups)+ , parseOverridesFile+ , filterAPIsAndDeps+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Traversable (traverse)+#endif++import Control.Monad.Except+import Control.Monad.State+import Control.Monad.Writer++import Data.Maybe (isJust)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Text (Text)++import qualified System.Info as SI+import qualified System.Environment as SE++import Data.GI.CodeGen.API+import qualified Text.XML as XML+import Data.GI.GIR.XMLUtils (xmlLocalName, xmlNSName,+ GIRXMLNamespace(CGIRNS, GLibGIRNS))++data Overrides = Overrides {+ -- | Ignored elements of a given API.+ ignoredElems :: M.Map Name (S.Set Text),+ -- | Ignored APIs (all elements in this API will just be discarded).+ ignoredAPIs :: S.Set Name,+ -- | Structs for which accessors should not be auto-generated.+ sealedStructs :: S.Set Name,+ -- | Mapping from GObject Introspection namespaces to pkg-config+ pkgConfigMap :: M.Map Text Text,+ -- | Version number for the generated .cabal package.+ cabalPkgVersion :: Maybe Text,+ -- | Prefered version of the namespace.+ nsChooseVersion :: M.Map Text Text,+ -- | Fixups for the GIR data.+ girFixups :: [GIRRule]+} deriving (Show)++-- | Construct the generic config for a module.+defaultOverrides :: Overrides+defaultOverrides = Overrides {+ ignoredElems = M.empty,+ ignoredAPIs = S.empty,+ sealedStructs = S.empty,+ pkgConfigMap = M.empty,+ cabalPkgVersion = Nothing,+ nsChooseVersion = M.empty,+ girFixups = [] }++-- | There is a sensible notion of zero and addition of Overridess,+-- encode this so that we can view the parser as a writer monad of+-- configs.+instance Monoid Overrides where+ mempty = defaultOverrides+ mappend a b = Overrides {+ ignoredAPIs = ignoredAPIs a <> ignoredAPIs b,+ sealedStructs = sealedStructs a <> sealedStructs b,+ ignoredElems = M.unionWith S.union (ignoredElems a) (ignoredElems b),+ pkgConfigMap = pkgConfigMap a <> pkgConfigMap b,+ cabalPkgVersion = if isJust (cabalPkgVersion b)+ then cabalPkgVersion b+ else cabalPkgVersion a,+ nsChooseVersion = nsChooseVersion a <> nsChooseVersion b,+ girFixups = girFixups a <> girFixups b+ }++-- | The state of the overrides parser.+data ParserState = ParserState {+ currentNS :: Maybe Text -- ^ The current namespace.+ , flags :: [ParserFlag] -- ^ Currently loaded flags.+ } deriving (Show)++-- | Default, empty, parser state.+emptyParserState :: ParserState+emptyParserState = ParserState {+ currentNS = Nothing+ , flags = []+ }++-- | Conditional flags for the parser+data ParserFlag = FlagLinux+ | FlagOSX+ | FlagWindows+ deriving (Show)++-- | Get the current namespace.+getNS :: Parser (Maybe Text)+getNS = currentNS <$> get++-- | Run the given parser only if the flags can be satisfied.+withFlags :: Parser () -> Parser ()+withFlags p = do+ fs <- flags <$> get+ check <- and <$> liftIO (traverse checkFlag fs)+ if check+ then p+ else return ()++-- | Check whether the given flag holds.+checkFlag :: ParserFlag -> IO Bool+checkFlag FlagLinux = checkOS "linux"+checkFlag FlagOSX = checkOS "darwin"+checkFlag FlagWindows = checkOS "mingw32"++-- | Check whether we are running under the given OS. We take the OS+-- from `System.Info.os`, but it is possible to override this value by+-- setting the environment variable @HASKELL_GI_OVERRIDE_OS@.+checkOS :: String -> IO Bool+checkOS os = SE.lookupEnv "HASKELL_GI_OVERRIDE_OS" >>= \case+ Nothing -> return (SI.os == os)+ Just ov -> return (ov == os)++-- | We have a bit of context (the current namespace), and can fail,+-- encode this in a monad.+type Parser a = WriterT Overrides (StateT ParserState (ExceptT Text IO)) a++-- | Parse the given config file (as a set of lines) for a given+-- introspection namespace, filling in the configuration as needed. In+-- case the parsing fails we return a description of the error+-- instead.+parseOverridesFile :: [Text] -> IO (Either Text Overrides)+parseOverridesFile ls =+ runExceptT $ flip evalStateT emptyParserState $ execWriterT $+ mapM (parseOneLine . T.strip) ls++-- | Parse a single line of the config file, modifying the+-- configuration as appropriate.+parseOneLine :: Text -> Parser ()+-- Empty lines+parseOneLine line | T.null line = return ()+-- Comments+parseOneLine (T.stripPrefix "#" -> Just _) = return ()+parseOneLine (T.stripPrefix "namespace " -> Just ns) =+ withFlags $ modify' (\s -> s {currentNS = (Just . T.strip) ns})+parseOneLine (T.stripPrefix "ignore " -> Just ign) =+ withFlags $ getNS >>= parseIgnore ign+parseOneLine (T.stripPrefix "seal " -> Just s) =+ withFlags $ getNS >>= parseSeal s+parseOneLine (T.stripPrefix "pkg-config-name " -> Just s) =+ withFlags $ parsePkgConfigName s+parseOneLine (T.stripPrefix "cabal-pkg-version " -> Just s) =+ withFlags $ parseCabalPkgVersion s+parseOneLine (T.stripPrefix "namespace-version " -> Just s) =+ withFlags $ parseNsVersion s+parseOneLine (T.stripPrefix "set-attr " -> Just s) =+ withFlags $ parseSetAttr s+parseOneLine (T.stripPrefix "if " -> Just s) =+ withFlags $ parseIf s+parseOneLine (T.stripPrefix "endif" -> Just s) = parseEndif s+parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"."++-- | Ignored elements.+parseIgnore :: Text -> Maybe Text -> Parser ()+parseIgnore _ Nothing =+ throwError "'ignore' requires a namespace to be defined first."+parseIgnore (T.words -> [T.splitOn "." -> [api,elem]]) (Just ns) =+ tell $ defaultOverrides {ignoredElems = M.singleton (Name ns api)+ (S.singleton elem)}+parseIgnore (T.words -> [T.splitOn "." -> [api]]) (Just ns) =+ tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns api)}+parseIgnore ignore _ =+ throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " <> ignore <> "\" instead.")++-- | Sealed structures.+parseSeal :: Text -> Maybe Text -> Parser ()+parseSeal _ Nothing = throwError "'seal' requires a namespace to be defined first."+parseSeal (T.words -> [s]) (Just ns) = tell $+ defaultOverrides {sealedStructs = S.singleton (Name ns s)}+parseSeal seal _ =+ throwError ("seal syntax is of the form \"seal name\".\nGot \"seal "+ <> seal <> "\" instead.")++-- | Mapping from GObject Introspection namespaces to pkg-config.+parsePkgConfigName :: Text -> Parser ()+parsePkgConfigName (T.words -> [gi,pc]) = tell $+ defaultOverrides {pkgConfigMap =+ M.singleton (T.toLower gi) pc}+parsePkgConfigName t =+ throwError ("pkg-config-name syntax is of the form\n" <>+ "\t\"pkg-config-name gi-namespace pk-name\"\n" <>+ "Got \"pkg-config-name " <> t <> "\" instead.")++-- | Choose a preferred namespace version to load.+parseNsVersion :: Text -> Parser ()+parseNsVersion (T.words -> [ns,version]) = tell $+ defaultOverrides {nsChooseVersion =+ M.singleton ns version}+parseNsVersion t =+ throwError ("namespace-version syntax is of the form\n" <>+ "\t\"namespace-version namespace version\"\n" <>+ "Got \"namespace-version " <> t <> "\" instead.")++-- | Specifying the cabal package version by hand.+parseCabalPkgVersion :: Text -> Parser ()+parseCabalPkgVersion (T.words -> [version]) = tell $+ defaultOverrides {cabalPkgVersion = Just version}+parseCabalPkgVersion t =+ throwError ("cabal-pkg-version syntax is of the form\n" <>+ "\t\"cabal-pkg-version version\"\n" <>+ "Got \"cabal-pkg-version " <> t <> "\" instead.")++-- | Set a given attribute in the GIR file.+parseSetAttr :: Text -> Parser ()+parseSetAttr (T.words -> [path, attr, newVal]) = do+ pathSpec <- parsePathSpec path+ parsedAttr <- parseXMLName attr+ tell $ defaultOverrides {girFixups =+ [GIRSetAttr (pathSpec, parsedAttr) newVal]}+parseSetAttr t =+ throwError ("set-attr syntax is of the form\n" <>+ "\t\"set-attr nodePath attrName newValue\"\n" <>+ "Got \"set-attr " <> t <> "\" instead.")++-- | Parse a path specification, which is of the form+-- "nodeSpec1/nodeSpec2/../nodeSpecN", where nodeSpec is a node+-- specification of the form "nodeType[:name attribute]".+parsePathSpec :: Text -> Parser GIRPath+parsePathSpec spec = mapM parseNodeSpec (T.splitOn "/" spec)++-- | Parse a single node specification.+parseNodeSpec :: Text -> Parser GIRNodeSpec+parseNodeSpec spec = case T.splitOn "@" spec of+ [n] -> return (GIRNamed n)+ ["", t] -> return (GIRType t)+ [n, t] -> return (GIRTypedName t n)+ _ -> throwError ("Could not understand node spec \""+ <> spec <> "\".")++-- | Parse an XML name, with an optional prefix.+parseXMLName :: Text -> Parser XML.Name+parseXMLName a = case T.splitOn ":" a of+ [n] -> return (xmlLocalName n)+ ["c", n] -> return (xmlNSName CGIRNS n)+ ["glib", n] -> return (xmlNSName GLibGIRNS n)+ _ -> throwError ("Could not understand xml name \""+ <> a <> "\".")++-- | Parse a 'if' directive.+parseIf :: Text -> Parser ()+parseIf cond = case T.words cond of+ [] -> throwError ("Empty 'if' condition.")+ ["linux"] -> setFlag FlagLinux+ ["osx"] -> setFlag FlagOSX+ ["windows"] -> setFlag FlagWindows+ _ -> throwError ("Unknown condition \"" <> cond <> "\".")+ where setFlag :: ParserFlag -> Parser ()+ setFlag flag = modify' (\s -> s {flags = flag : flags s})++-- | Parse an 'endif' directive.+parseEndif :: Text -> Parser ()+parseEndif rest = case T.words rest of+ [] -> unsetFlag+ _ -> throwError ("Unexpected argument to 'endif': \""+ <> rest <> "\".")+ where unsetFlag :: Parser ()+ unsetFlag = do+ s <- get+ case flags s of+ _:rest -> put (s {flags = rest})+ [] -> throwError ("'endif' with no matching 'if'.")++-- | Filter a set of named objects based on a lookup list of names to+-- ignore.+filterMethods :: [Method] -> S.Set Text -> [Method]+filterMethods set ignores =+ filter ((`S.notMember` ignores) . name . methodName) set++-- | Filter one API according to the given config.+filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API)+filterOneAPI ovs (n, APIStruct s, maybeIgnores) =+ (n, APIStruct s {structMethods = maybe (structMethods s)+ (filterMethods (structMethods s))+ maybeIgnores,+ structFields = if n `S.member` sealedStructs ovs+ then []+ else structFields s})+-- The rest only apply if there are ignores.+filterOneAPI _ (n, api, Nothing) = (n, api)+filterOneAPI _ (n, APIObject o, Just ignores) =+ (n, APIObject o {objMethods = filterMethods (objMethods o) ignores,+ objSignals = filter ((`S.notMember` ignores) . sigName)+ (objSignals o)+ })+filterOneAPI _ (n, APIInterface i, Just ignores) =+ (n, APIInterface i {ifMethods = filterMethods (ifMethods i) ignores,+ ifSignals = filter ((`S.notMember` ignores) . sigName)+ (ifSignals i)+ })+filterOneAPI _ (n, APIUnion u, Just ignores) =+ (n, APIUnion u {unionMethods = filterMethods (unionMethods u) ignores})+filterOneAPI _ (n, api, _) = (n, api)++-- | Given a list of APIs modify them according to the given config.+filterAPIs :: Overrides -> [(Name, API)] -> [(Name, API)]+filterAPIs ovs apis = map (filterOneAPI ovs . fetchIgnores) filtered+ where filtered = filter ((`S.notMember` ignoredAPIs ovs) . fst) apis+ fetchIgnores (n, api) = (n, api, M.lookup n (ignoredElems ovs))++-- | Load a given API, applying filtering. Load also any necessary+-- dependencies.+filterAPIsAndDeps :: Overrides -> GIRInfo -> [GIRInfo]+ -> (M.Map Name API, M.Map Name API)+filterAPIsAndDeps ovs doc deps =+ let toMap = M.fromList . filterAPIs ovs . girAPIs+ in (toMap doc, M.unions (map toMap deps))
+ lib/Data/GI/CodeGen/PkgConfig.hs view
@@ -0,0 +1,47 @@+module Data.GI.CodeGen.PkgConfig+ ( pkgConfigGetVersion+ ) where++import Control.Monad (when)+import Data.Monoid (First(..), (<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mconcat)+#endif+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Data.Text (Text)+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)++-- | Try asking pkg-config for the version of a given module.+tryPkgConfig :: Text -> IO (Maybe (Text, Text))+tryPkgConfig pkgName = do+ (exitcode, stdout, _) <-+ readProcessWithExitCode "pkg-config" ["--modversion", T.unpack pkgName] ""+ case exitcode of+ ExitSuccess -> case lines stdout of+ [v] -> return (Just (pkgName, T.pack v))+ _ -> return Nothing+ ExitFailure _ -> return Nothing++-- | Get the pkg-config name and associated installed version of a given+-- gobject-introspection namespace. Since the mapping is not+-- one-to-one some guessing is involved, although in most cases the+-- required information is listed in the GIR file.+pkgConfigGetVersion :: Text -- name+ -> Text -- version+ -> [Text] -- known package names+ -> Bool -- verbose+ -> M.Map Text Text -- suggested overrides+ -> IO (Maybe (Text, Text))+pkgConfigGetVersion name version packages verbose overridenNames = do+ let lowerName = T.toLower name+ when verbose $+ putStrLn $ T.unpack ("Querying pkg-config for " <> name <>+ " version " <> version)+ let alternatives = case M.lookup lowerName overridenNames of+ Nothing -> packages ++ [lowerName <> "-" <> version,+ lowerName]+ Just n -> [n <> "-" <> version, n]+ firstJust = getFirst . mconcat . map First+ mapM tryPkgConfig alternatives >>= return . firstJust
+ lib/Data/GI/CodeGen/ProjectInfo.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Project information to include in generated bindings, should be+-- kept in sync with haskell-gi.cabal+module Data.GI.CodeGen.ProjectInfo+ ( homepage+ , authors+ , license+ , licenseText+ , maintainers+ ) where++import Data.FileEmbed (embedStringFile)+import Data.Text (Text)++homepage :: Text+homepage = "https://github.com/haskell-gi/haskell-gi"++authors :: Text+authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte"++maintainers :: Text+maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)"++license :: Text+license = "LGPL-2.1"++licenseText :: Text+licenseText = $(embedStringFile "LICENSE")
+ lib/Data/GI/CodeGen/Properties.hs view
@@ -0,0 +1,369 @@+module Data.GI.CodeGen.Properties+ ( genInterfaceProperties+ , genObjectProperties+ , genNamespacedPropLabels+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM_, when, unless)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Set as S++import Foreign.C.Types (CInt, CUInt)+import Foreign.Storable (sizeOf)++import Data.GI.CodeGen.API+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.Type+import Data.GI.CodeGen.Util++propTypeStr :: Type -> CodeGen Text+propTypeStr t = case t of+ TBasicType TUTF8 -> return "String"+ TBasicType TFileName -> return "String"+ TBasicType TPtr -> return "Ptr"+ TByteArray -> return "ByteArray"+ TGHash _ _ -> return "Hash"+ TVariant -> return "Variant"+ TParamSpec -> return "ParamSpec"+ TBasicType TInt -> case sizeOf (0 :: CInt) of+ 4 -> return "Int32"+ n -> error ("Unsupported `gint' type length: " +++ show n)+ TBasicType TUInt -> case sizeOf (0 :: CUInt) of+ 4 -> return "UInt32"+ n -> error ("Unsupported `guint' type length: " +++ show n)+ TBasicType TLong -> return "Long"+ TBasicType TULong -> return "ULong"+ TBasicType TInt32 -> return "Int32"+ TBasicType TUInt32 -> return "UInt32"+ TBasicType TInt64 -> return "Int64"+ TBasicType TUInt64 -> return "UInt64"+ TBasicType TBoolean -> return "Bool"+ TBasicType TFloat -> return "Float"+ TBasicType TDouble -> return "Double"+ TBasicType TGType -> return "GType"+ TCArray True _ _ (TBasicType TUTF8) -> return "StringArray"+ TCArray True _ _ (TBasicType TFileName) -> return "StringArray"+ TGList (TBasicType TPtr) -> return "PtrGList"+ t@(TInterface ns n) -> do+ api <- findAPIByName (Name ns n)+ case api of+ APIEnum _ -> return "Enum"+ APIFlags _ -> return "Flags"+ APIStruct s -> if structIsBoxed s+ then return "Boxed"+ else error $ "Unboxed struct property : " ++ show t+ APIUnion u -> if unionIsBoxed u+ then return "Boxed"+ else error $ "Unboxed union property : " ++ show t+ APIObject _ -> do+ isGO <- isGObject t+ if isGO+ then return "Object"+ else error $ "Non-GObject object property : " ++ show t+ APIInterface _ -> do+ isGO <- isGObject t+ if isGO+ then return "Object"+ else error $ "Non-GObject interface property : " ++ show t+ _ -> error $ "Unknown interface property of type : " ++ show t+ _ -> error $ "Don't know how to handle properties of type " ++ show t++-- | Given a property, return the set of constraints on the types, and+-- the type variables for the object and its value.+attrType :: Property -> CodeGen ([Text], Text)+attrType prop = do+ (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop+ return (constraints, t)++genPropertySetter :: Name -> Text -> Property -> CodeGen ()+genPropertySetter n pName prop = group $ do+ oName <- upperName n+ (constraints, t) <- attrType prop+ isNullable <- typeIsNullable (propType prop)+ let constraints' = "MonadIO m":(classConstraint oName <> " o"):constraints+ tStr <- propTypeStr $ propType prop+ line $ "set" <> pName <> " :: (" <> T.intercalate ", " constraints'+ <> ") => o -> " <> t <> " -> m ()"+ line $ "set" <> pName <> " obj val = liftIO $ setObjectProperty" <> tStr+ <> " obj \"" <> propName prop+ <> if isNullable+ then "\" (Just val)"+ else "\" val"++genPropertyGetter :: Name -> Text -> Property -> CodeGen ()+genPropertyGetter n pName prop = group $ do+ oName <- upperName n+ 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)"+ 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 <>+ " => o -> " <> tshow ("m" `con` [outType])+ line $ "get" <> pName <> " obj = liftIO $ " <> getter+ <> " obj \"" <> propName prop <> "\"" <>+ if tStr `elem` ["Object", "Boxed"]+ then " " <> tshow constructorType -- These require the constructor.+ else ""++genPropertyConstructor :: Text -> Property -> CodeGen ()+genPropertyConstructor pName 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+ <> " \"" <> propName prop+ <> if isNullable+ then "\" (Just val)"+ else "\" val"++genPropertyClear :: Name -> Text -> Property -> CodeGen ()+genPropertyClear n pName prop = group $ do+ oName <- upperName n+ nothingType <- tshow . maybeT <$> haskellType (propType prop)+ let constraints = ["MonadIO m", classConstraint oName <> " o"]+ tStr <- propTypeStr $ propType prop+ line $ "clear" <> pName <> " :: (" <> T.intercalate ", " constraints+ <> ") => o -> m ()"+ line $ "clear" <> pName <> " obj = liftIO $ setObjectProperty" <> tStr+ <> " obj \"" <> propName prop <> "\" (Nothing :: "+ <> nothingType <> ")"++-- | The property name as a lexically valid Haskell identifier. Note+-- that this is not escaped, since it is assumed that it will be used+-- with a prefix, so if a property is named "class", for example, this+-- will return "class".+hPropName :: Property -> Text+hPropName = lcFirst . hyphensToCamelCase . propName++genObjectProperties :: Name -> Object -> CodeGen ()+genObjectProperties n o = do+ isGO <- apiIsGObject n (APIObject o)+ -- We do not generate bindings for objects not descending from GObject.+ when isGO $ do+ allProps <- fullObjectPropertyList n o >>=+ mapM (\(owner, prop) -> do+ pi <- infoType owner prop+ return $ "'(\"" <> hPropName prop+ <> "\", " <> pi <> ")")+ genProperties n (objProperties o) allProps++genInterfaceProperties :: Name -> Interface -> CodeGen ()+genInterfaceProperties n iface = do+ allProps <- fullInterfacePropertyList n iface >>=+ mapM (\(owner, prop) -> do+ pi <- infoType owner prop+ return $ "'(\"" <> hPropName prop+ <> "\", " <> pi <> ")")+ genProperties n (ifProperties iface) allProps++-- If the given accesor is available (indicated by available == True),+-- 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 =+ if not available+ then return "undefined"+ else do+ prefix <- qualify ons+ return $ prefix <> accessor <> on <> cName++-- | 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"++genOneProperty :: Name -> Property -> ExcCodeGen ()+genOneProperty owner prop = do+ name <- upperName owner+ let cName = (hyphensToCamelCase . propName) prop+ pName = name <> cName+ flags = propFlags prop+ writable = PropertyWritable `elem` flags &&+ (PropertyConstructOnly `notElem` flags)+ readable = PropertyReadable `elem` flags+ constructOnly = PropertyConstructOnly `elem` flags++ -- For properties the meaning of having transfer /= TransferNothing+ -- is not clear (what are the right semantics for GValue setters?),+ -- and the other possibilities are very uncommon, so let us just+ -- assume that TransferNothing is always the case.+ when (propTransfer prop /= TransferNothing) $+ notImplementedError $ "Property " <> pName+ <> " has unsupported transfer type "+ <> tshow (propTransfer prop)++ 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++ group $ do+ line $ "-- VVV Prop \"" <> propName prop <> "\""+ line $ " -- Type: " <> tshow (propType prop)+ line $ " -- Flags: " <> tshow (propFlags prop)+ 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++ outType <- if not readable+ then return "()"+ else do+ sOutType <- if isNullable && propReadNullable prop /= Just False+ then tshow . maybeT <$> haskellType (propType prop)+ else tshow <$> haskellType (propType prop)+ return $ if T.any (== ' ') sOutType+ then parenthesize sOutType+ 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+ then ["'AttrSet", "'AttrConstruct"]+ else [])+ <> (if constructOnly+ then ["'AttrConstruct"]+ else [])+ <> (if readable+ then ["'AttrGet"]+ else [])+ <> (if isNullable && propWriteNullable prop /= Just False+ then ["'AttrClear"]+ 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+ line $ "type AttrAllowedOps " <> it+ <> " = '[ " <> T.intercalate ", " allowedOps <> "]"+ line $ "type AttrSetTypeConstraint " <> it+ <> " = " <> inConstraint+ line $ "type AttrBaseTypeConstraint " <> it+ <> " = " <> classConstraint name+ line $ "type AttrGetType " <> it <> " = " <> outType+ line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\""+ line $ "attrGet _ = " <> getter+ line $ "attrSet _ = " <> setter+ line $ "attrConstruct _ = " <> constructor+ line $ "attrClear _ = " <> clear++-- | Generate a placeholder property for those cases in which code+-- generation failed.+genPlaceholderProperty :: Name -> Property -> CodeGen ()+genPlaceholderProperty owner prop = do+ line $ "-- XXX Placeholder"+ it <- infoType owner prop+ let cName = (hyphensToCamelCase . propName) prop+ exportProperty cName it+ line $ "data " <> it+ line $ "instance AttrInfo " <> it <> " where"+ indent $ do+ line $ "type AttrAllowedOps " <> it <> " = '[]"+ line $ "type AttrSetTypeConstraint " <> it <> " = (~) ()"+ line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()"+ line $ "type AttrGetType " <> it <> " = ()"+ line $ "type AttrLabel " <> it <> " = \"\""+ line $ "attrGet = undefined"+ line $ "attrSet = undefined"+ line $ "attrConstruct = undefined"+ line $ "attrClear = undefined"++genProperties :: Name -> [Property] -> [Text] -> CodeGen ()+genProperties n ownedProps allProps = do+ name <- upperName n++ forM_ ownedProps $ \prop -> do+ handleCGExc (\err -> do+ line $ "-- XXX Generation of property \""+ <> propName prop <> "\" of object \""+ <> name <> "\" failed: " <> describeCGError err+ genPlaceholderProperty n prop)+ (genOneProperty n prop)++ group $ do+ let propListType = name <> "AttributeList"+ line $ "type instance AttributeList " <> name <> " = " <> propListType+ line $ "type " <> propListType <> " = ('[ "+ <> T.intercalate ", " allProps <> "] :: [(Symbol, *)])"++-- | Generate gtk2hs compatible attribute labels (to ease+-- porting). These are namespaced labels, for examples+-- `widgetSensitive`. We take the list of methods, since there may be+-- name clashes (an example is Auth::is_for_proxy method in libsoup,+-- and the corresponding Auth::is-for-proxy property). When there is a+-- clash we give priority to the method.+genNamespacedPropLabels :: Name -> [Property] -> [Method] -> CodeGen ()+genNamespacedPropLabels owner props methods =+ let lName = lcFirst . hyphensToCamelCase . propName+ in genNamespacedAttrLabels owner (map lName props) methods++genNamespacedAttrLabels :: Name -> [Text] -> [Method] -> CodeGen ()+genNamespacedAttrLabels owner attrNames methods = do+ name <- upperName owner++ let methodNames = S.fromList (map (lowerName . methodName) methods)+ filteredAttrs = filter (`S.notMember` methodNames) attrNames++ forM_ filteredAttrs $ \attr -> group $ do+ let cName = ucFirst attr+ labelProxy = lcFirst name <> cName++ line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst cName <> "\""+ line $ labelProxy <> " = AttrLabelProxy"++ exportProperty cName labelProxy
+ lib/Data/GI/CodeGen/Signal.hs view
@@ -0,0 +1,341 @@+module Data.GI.CodeGen.Signal+ ( genSignal+ , genCallback+ , signalHaskellName+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM, forM_, when, unless)++import Data.Typeable (typeOf)+import Data.Bool (bool)+import qualified Data.Text as T+import Data.Text (Text)++import Text.Show.Pretty (ppShow)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Callable (hOutType, arrayLengths, wrapMaybe, fixupCallerAllocates)+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.SymbolNaming+import Data.GI.CodeGen.Transfer (freeContainerType)+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst,+ prime)++-- The prototype of the callback on the Haskell side (what users of+-- the binding will see)+genHaskellCallbackPrototype :: Text -> Callable -> Text -> [Arg] -> [Arg] ->+ ExcCodeGen ()+genHaskellCallbackPrototype subsec cb name' hInArgs hOutArgs = do+ group $ do+ exportSignal subsec name'+ line $ "type " <> name' <> " ="+ indent $ do+ forM_ hInArgs $ \arg -> do+ ht <- haskellType (argType arg)+ wrapMaybe arg >>= bool+ (line $ tshow ht <> " ->")+ (line $ tshow (maybeT ht) <> " ->")+ ret <- hOutType cb hOutArgs False+ line $ tshow $ io ret++ -- For optional parameters, in case we want to pass Nothing.+ group $ do+ exportSignal subsec ("no" <> name')+ line $ "no" <> name' <> " :: Maybe " <> name'+ line $ "no" <> name' <> " = Nothing"++-- Prototype of the callback on the C side+genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen ()+genCCallbackPrototype subsec cb name' isSignal =+ group $ do+ let ctypeName = name' <> "C"+ exportSignal subsec ctypeName++ line $ "type " <> ctypeName <> " ="+ indent $ do+ when isSignal $ line $ withComment "Ptr () ->" "object"+ forM_ (args cb) $ \arg -> do+ ht <- foreignType $ argType arg+ let ht' = if direction arg /= DirectionIn+ then ptr ht+ else ht+ line $ tshow ht' <> " ->"+ when isSignal $ line $ withComment "Ptr () ->" "user_data"+ ret <- io <$> case returnType cb of+ Nothing -> return $ typeOf ()+ Just t -> foreignType t+ line $ tshow ret++-- Generator for wrappers callable from C+genCallbackWrapperFactory :: Text -> Text -> CodeGen ()+genCallbackWrapperFactory subsec name' =+ group $ do+ let factoryName = "mk" <> name'+ line "foreign import ccall \"wrapper\""+ indent $ line $ factoryName <> " :: "+ <> name' <> "C -> IO (FunPtr " <> name' <> "C)"+ exportSignal subsec factoryName++-- Generator of closures+genClosure :: Text -> Text -> Text -> Bool -> CodeGen ()+genClosure subsec callback closure isSignal = do+ exportSignal subsec closure+ group $ do+ line $ closure <> " :: " <> callback <> " -> IO Closure"+ line $ closure <> " cb = newCClosure =<< mk" <> callback <> " wrapped"+ indent $+ line $ "where wrapped = " <> lcFirst callback <> "Wrapper " <>+ if isSignal+ then "cb"+ else "Nothing cb"++-- Wrap a conversion of a nullable object into "Maybe" object, by+-- checking whether the pointer is NULL.+convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text+convertNullable aname c = do+ line $ "maybe" <> ucFirst aname <> " <-"+ indent $ do+ line $ "if " <> aname <> " == nullPtr"+ line "then return Nothing"+ line "else do"+ indent $ do+ unpacked <- c+ line $ "return $ Just " <> unpacked+ return $ "maybe" <> ucFirst aname++-- Convert a non-zero terminated out array, stored in a variable+-- named "aname", into the corresponding Haskell object.+convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text+convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname =+ if length > -1+ then wrapMaybe arg >>= bool convertAndFree+ (convertNullable aname convertAndFree)+ else+ -- Not much we can do, we just pass the pointer along, and let+ -- the callback deal with it.+ return aname+ where+ lname = escapedArgName $ args callable !! length++ convertAndFree :: ExcCodeGen Text+ convertAndFree = do+ unpacked <- convert aname $ unpackCArray lname t (transfer arg)+ -- Free the memory associated with the array+ freeContainerType (transfer arg) t aname lname+ return unpacked++-- Remove the warning, this should never be reached.+convertCallbackInCArray _ t _ _ =+ terror $ "convertOutCArray : unexpected " <> tshow t++-- Prepare an argument for passing into the Haskell side.+prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text+prepareArgForCall cb arg = case direction arg of+ DirectionIn -> prepareInArg cb arg+ DirectionInout -> prepareInoutArg arg+ DirectionOut -> terror "Unexpected DirectionOut!"++prepareInArg :: Callable -> Arg -> ExcCodeGen Text+prepareInArg cb arg = do+ let name = escapedArgName arg+ case argType arg of+ t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name+ _ -> do+ let c = convert name $ fToH (argType arg) (transfer arg)+ wrapMaybe arg >>= bool c (convertNullable name c)++prepareInoutArg :: Arg -> ExcCodeGen Text+prepareInoutArg arg = do+ let name = escapedArgName arg+ name' <- genConversion name $ apply $ M "peek"+ convert name' $ fToH (argType arg) (transfer arg)++saveOutArg :: Arg -> ExcCodeGen ()+saveOutArg arg = do+ let name = escapedArgName arg+ name' = "out" <> name+ when (transfer arg /= TransferEverything) $+ notImplementedError $ "Unexpected transfer type for \"" <> name <> "\""+ isMaybe <- wrapMaybe arg+ name'' <- if isMaybe+ then do+ let name'' = prime name'+ line $ name'' <> " <- case " <> name' <> " of"+ indent $ do+ line "Nothing -> return nullPtr"+ line $ "Just " <> name'' <> " -> do"+ indent $ do+ converted <- convert name'' $ hToF (argType arg) TransferEverything+ line $ "return " <> converted+ return name''+ else convert name' $ hToF (argType arg) TransferEverything+ line $ "poke " <> name <> " " <> name''++-- The wrapper itself, marshalling to and from Haskell. The first+-- argument is possibly a pointer to a FunPtr to free (via+-- freeHaskellFunPtr) once the callback is run once, or Nothing if the+-- FunPtr will be freed by someone else (the function registering the+-- callback for ScopeTypeCall, or a destroy notifier for+-- ScopeTypeNotified).+genCallbackWrapper :: Text -> Callable -> Text -> [Arg] -> [Arg] -> [Arg] ->+ Bool -> ExcCodeGen ()+genCallbackWrapper subsec cb name' dataptrs hInArgs hOutArgs isSignal = do+ let cName arg = if arg `elem` dataptrs+ then "_"+ else escapedArgName arg+ cArgNames = map cName (args cb)+ wrapperName = lcFirst name' <> "Wrapper"++ exportSignal subsec wrapperName++ group $ do+ line $ wrapperName <> " ::"+ indent $ do+ unless isSignal $+ line $ "Maybe (Ptr (FunPtr (" <> name' <> "C))) ->"+ line $ name' <> " ->"+ when isSignal $ line "Ptr () ->"+ forM_ (args cb) $ \arg -> do+ ht <- foreignType $ argType arg+ let ht' = if direction arg /= DirectionIn+ then ptr ht+ else ht+ line $ tshow ht' <> " ->"+ when isSignal $ line "Ptr () ->"+ ret <- io <$> case returnType cb of+ Nothing -> return $ typeOf ()+ Just t -> foreignType t+ line $ tshow ret++ let allArgs = if isSignal+ then T.unwords $ ["_cb", "_"] <> cArgNames <> ["_"]+ else T.unwords $ ["funptrptr", "_cb"] <> cArgNames+ line $ wrapperName <> " " <> allArgs <> " = do"+ indent $ do+ hInNames <- forM hInArgs (prepareArgForCall cb)++ let maybeReturn = case returnType cb of+ Nothing -> []+ _ -> ["result"]+ returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs+ returnBind = case returnVars of+ [] -> ""+ [r] -> r <> " <- "+ _ -> parenthesize (T.intercalate ", " returnVars) <> " <- "+ line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames)++ forM_ hOutArgs saveOutArg++ unless isSignal $ line "maybeReleaseFunPtr funptrptr"++ case returnType cb of+ Nothing -> return ()+ Just r -> do+ nullableReturnType <- typeIsNullable r+ if returnMayBeNull cb && nullableReturnType+ then do+ line "maybeM nullPtr result $ \\result' -> do"+ indent $ unwrapped "result'"+ else unwrapped "result"+ where+ unwrapped rname = do+ result' <- convert rname $ hToF r (returnTransfer cb)+ line $ "return " <> result'++genCallback :: Name -> Callback -> CodeGen ()+genCallback n (Callback cb) = submodule "Callbacks" $ do+ name' <- upperName n+ line $ "-- callback " <> name'++ let -- user_data pointers, which we generically omit+ dataptrs = map (args cb !!) . filter (/= -1) . map argClosure $ args cb+ hidden = dataptrs <> arrayLengths cb++ inArgs = filter ((/= DirectionOut) . direction) $ args cb+ hInArgs = filter (not . (`elem` hidden)) inArgs+ outArgs = filter ((/= DirectionIn) . direction) $ args cb+ hOutArgs = filter (not . (`elem` hidden)) outArgs++ if skipReturn cb+ then group $ do+ line $ "-- XXX Skipping callback " <> name'+ line $ "-- Callbacks skipping return unsupported :\n"+ <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb)+ else do+ let closure = lcFirst name' <> "Closure"+ cb' = fixupCallerAllocates cb++ handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "+ <> name' <>+ "\n-- Error was : " <> describeCGError e))+ (genClosure name' name' closure False >>+ genCCallbackPrototype name' cb' name' False >>+ genCallbackWrapperFactory name' name' >>+ genHaskellCallbackPrototype name' cb' name' hInArgs hOutArgs >>+ genCallbackWrapper name' cb' name' dataptrs hInArgs hOutArgs False)++-- | Return the name for the signal in Haskell CamelCase conventions.+signalHaskellName :: Text -> Text+signalHaskellName sn = let (w:ws) = T.split (== '-') sn+ in w <> T.concat (map ucFirst ws)++genSignal :: Signal -> Name -> ExcCodeGen ()+genSignal (Signal { sigName = sn, sigCallable = cb }) on = do+ on' <- upperName on++ line $ "-- signal " <> on' <> "::" <> sn++ let inArgs = filter ((/= DirectionOut) . direction) $ args cb+ hInArgs = filter (not . (`elem` arrayLengths cb)) inArgs+ outArgs = filter ((/= DirectionIn) . direction) $ args cb+ hOutArgs = filter (not . (`elem` arrayLengths cb)) outArgs+ sn' = signalHaskellName (sn)+ signalConnectorName = on' <> ucFirst sn'+ cbType = signalConnectorName <> "Callback"++ genHaskellCallbackPrototype (ucFirst sn') cb cbType hInArgs hOutArgs++ genCCallbackPrototype (ucFirst sn') cb cbType True++ genCallbackWrapperFactory (ucFirst sn') cbType++ let closure = lcFirst signalConnectorName <> "Closure"+ genClosure (ucFirst sn') cbType closure True++ genCallbackWrapper (ucFirst sn') cb cbType [] hInArgs hOutArgs True++ -- Wrapper for connecting functions to the signal+ -- We can connect to a signal either before the default handler runs+ -- ("on...") or after the default handler runs (after...). We+ -- provide convenient wrappers for both cases.+ group $ do+ let signatureConstraints = "(GObject a, MonadIO m) =>"+ signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"+ signature = " :: " <> signatureConstraints <> " " <> signatureArgs+ onName = "on" <> signalConnectorName+ afterName = "after" <> signalConnectorName+ line $ onName <> signature+ line $ onName <> " obj cb = liftIO $ connect"+ <> signalConnectorName <> " obj cb SignalConnectBefore"+ line $ afterName <> signature+ line $ afterName <> " obj cb = connect"+ <> signalConnectorName <> " obj cb SignalConnectAfter"+ exportSignal (ucFirst sn') onName+ exportSignal (ucFirst sn') afterName++ group $ do+ let fullName = "connect" <> signalConnectorName+ signatureConstraints = "(GObject a, MonadIO m) =>"+ signatureArgs = "a -> " <> cbType+ <> " -> SignalConnectMode -> m SignalHandlerId"+ line $ fullName <> " :: " <> signatureConstraints+ line $ T.replicate (4 + T.length fullName) " " <> signatureArgs+ line $ fullName <> " obj cb after = liftIO $ do"+ indent $ do+ line $ "cb' <- mk" <> cbType <> " (" <> lcFirst cbType <> "Wrapper cb)"+ line $ "connectSignalFunPtr obj \"" <> sn <> "\" cb' after"
+ lib/Data/GI/CodeGen/Struct.hs view
@@ -0,0 +1,298 @@+module Data.GI.CodeGen.Struct ( genStructOrUnionFields+ , genZeroStruct+ , genZeroUnion+ , extractCallbacksInStruct+ , fixAPIStructs+ , ignoreStruct)+ where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (forM, when)++import Data.Maybe (mapMaybe, isJust, catMaybes)+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.SymbolNaming+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util++-- | Whether (not) to generate bindings for the given struct.+ignoreStruct :: Name -> Struct -> Bool+ignoreStruct (Name _ name) s = isJust (gtypeStructFor s) ||+ "Private" `T.isSuffixOf` name++-- | Canonical name for the type of a callback type embedded in a+-- struct field.+fieldCallbackType :: Text -> Field -> Text+fieldCallbackType structName field =+ structName <> (underscoresToCamelCase . fieldName) field <> "FieldCallback"++-- | Fix the interface names of callback fields in the struct to+-- correspond to the ones that we are going to generate.+fixCallbackStructFields :: Name -> Struct -> Struct+fixCallbackStructFields (Name ns structName) s = s {structFields = fixedFields}+ where fixedFields :: [Field]+ fixedFields = map fixField (structFields s)++ fixField :: Field -> Field+ fixField field =+ case fieldCallback field of+ Nothing -> field+ Just _ -> let n' = fieldCallbackType structName field+ in field {fieldType = TInterface ns n'}++-- | Fix the interface names of callback fields in an APIStruct to+-- correspond to the ones that we are going to generate. If something+-- other than an APIStruct is passed in we don't touch it.+fixAPIStructs :: (Name, API) -> (Name, API)+fixAPIStructs (n, APIStruct s) = (n, APIStruct $ fixCallbackStructFields n s)+fixAPIStructs api = api++-- | Extract the callback types embedded in the fields of structs, and+-- at the same time fix the type of the corresponding fields. Returns+-- the list of APIs associated to this struct, not including the+-- struct itself.+extractCallbacksInStruct :: (Name, API) -> [(Name, API)]+extractCallbacksInStruct (n@(Name ns structName), APIStruct s)+ | ignoreStruct n s = []+ | otherwise =+ mapMaybe callbackInField (structFields s)+ where callbackInField :: Field -> Maybe (Name, API)+ callbackInField field = do+ callback <- fieldCallback field+ let n' = fieldCallbackType structName field+ return (Name ns n', APICallback callback)+extractCallbacksInStruct _ = []++-- | The name of the type encoding the information for a field in a+-- struct/union.+infoType :: Name -> Field -> CodeGen Text+infoType owner field = do+ 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 getter = fieldGetter n field++ isMaybe <- typeIsNullable (fieldType field)+ hType <- tshow <$> if isMaybe+ then maybeT <$> haskellType (fieldType field)+ else haskellType (fieldType field)+ fType <- tshow <$> foreignType (fieldType field)++ line $ getter <> " :: MonadIO m => " <> name' <> " -> m " <>+ if T.any (== ' ') hType+ then parenthesize hType+ else hType+ line $ getter <> " s = liftIO $ withManagedPtr s $ \\ptr -> do"+ indent $ do+ line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field)+ <> ") :: IO " <> if T.any (== ' ') fType+ then parenthesize fType+ else fType+ result <- if not isMaybe+ then convert "val" $ fToH (fieldType field) TransferNothing+ else do+ line $ "result <- convertIfNonNull val $ \\val' -> do"+ indent $ do+ val' <- convert "val'" $ fToH (fieldType field) TransferNothing+ line $ "return " <> val'+ return "result"+ line $ "return " <> result++-- | Write a field into a struct. Note that, since we cannot know for+-- sure who will be deallocating the fields in the struct, we leave+-- any conversions that involve pointers to the caller. What this+-- means in practice is that scalar fields will get marshalled to/from+-- Haskell, while anything that involves pointers will be returned in+-- the C representation.+buildFieldWriter :: Name -> Field -> ExcCodeGen ()+buildFieldWriter n field = group $ do+ name' <- upperName n+ let setter = fieldSetter n field++ isPtr <- typeIsPtr (fieldType field)++ fType <- tshow <$> foreignType (fieldType field)+ hType <- if isPtr+ then return fType+ else tshow <$> haskellType (fieldType field)++ line $ setter <> " :: MonadIO m => " <> name' <> " -> "+ <> hType <> " -> m ()"+ line $ setter <> " s val = liftIO $ withManagedPtr s $ \\ptr -> do"+ indent $ do+ converted <- if isPtr+ then return "val"+ else convert "val" $ hToF (fieldType field) TransferNothing+ line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)+ <> ") (" <> converted <> " :: " <> fType <> ")"++-- | 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 clear = fieldClear n field++ fType <- tshow <$> foreignType (fieldType field)++ line $ clear <> " :: MonadIO m => " <> name' <> " -> m ()"+ line $ clear <> " s = liftIO $ withManagedPtr s $ \\ptr -> do"+ indent $ do+ line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field)+ <> ") (nullPtr :: " <> fType <> ")"++-- | Name for the getter function+fieldGetter :: Name -> Field -> Text+fieldGetter name' field = lowerName name' <> "Read" <> fName field++-- | Name for the setter function+fieldSetter :: Name -> Field -> Text+fieldSetter name' field = lowerName name' <> "Write" <> fName field++-- | Name for the clear function+fieldClear :: Name -> Field -> Text+fieldClear name' field = lowerName name' <> "Clear" <> fName field++-- | Haskell name for the field+fName :: Field -> Text+fName = underscoresToCamelCase . fieldName++-- | Support for modifying fields as attributes. Returns a tuple with+-- the name of the overloaded label to be used for the field, and the+-- associated info type.+genAttrInfo :: Name -> Field -> CodeGen Text+genAttrInfo owner field = do+ it <- infoType owner field+ on <- upperName owner++ isPtr <- typeIsPtr (fieldType field)++ isNullable <- typeIsNullable (fieldType field)+ outType <- tshow <$> if isNullable+ then maybeT <$> haskellType (fieldType field)+ else haskellType (fieldType field)+ inType <- if isPtr+ then tshow <$> foreignType (fieldType field)+ else tshow <$> haskellType (fieldType field)++ line $ "data " <> it+ line $ "instance AttrInfo " <> it <> " where"+ indent $ do+ line $ "type AttrAllowedOps " <> it <>+ if isPtr+ then " = '[ 'AttrSet, 'AttrGet, 'AttrClear]"+ else " = '[ 'AttrSet, 'AttrGet]"+ line $ "type AttrSetTypeConstraint " <> it <> " = (~) "+ <> if T.any (== ' ') inType+ then parenthesize inType+ else inType+ line $ "type AttrBaseTypeConstraint " <> it <> " = (~) " <> on+ line $ "type AttrGetType " <> it <> " = " <> outType+ line $ "type AttrLabel " <> it <> " = \"" <> fieldName field <> "\""+ line $ "attrGet _ = " <> fieldGetter owner field+ line $ "attrSet _ = " <> fieldSetter owner field+ line $ "attrConstruct = undefined"+ line $ "attrClear _ = " <> if isPtr+ then fieldClear owner field+ else "undefined"++ blank++ group $ do+ let labelProxy = lcFirst on <> fName field+ line $ labelProxy <> " :: AttrLabelProxy \"" <> lcFirst (fName field) <> "\""+ line $ labelProxy <> " = AttrLabelProxy"++ exportProperty (fName field) labelProxy++ return $ "'(\"" <> (lcFirst . fName) field <> "\", " <> it <> ")"++buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text)+buildFieldAttributes n field+ | not (fieldVisible 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+ buildFieldWriter n field+ when isPtr $+ buildFieldClear n field++ exportProperty (fName field) (fieldGetter n field)+ exportProperty (fName field) (fieldSetter n field)+ when isPtr $+ exportProperty (fName field) (fieldClear n field)++ Just <$> genAttrInfo n field++genStructOrUnionFields :: Name -> [Field] -> CodeGen ()+genStructOrUnionFields n fields = do+ name' <- upperName n++ attrs <- forM fields $ \field ->+ handleCGExc (\e -> line ("-- XXX Skipped attribute for \"" <> name' <>+ ":" <> fieldName field <> "\" :: " <>+ describeCGError e) >>+ return Nothing)+ (buildFieldAttributes n field)++ blank++ group $ do+ let attrListName = name' <> "AttributeList"+ line $ "type instance AttributeList " <> name' <> " = " <> attrListName+ line $ "type " <> attrListName <> " = ('[ " <>+ T.intercalate ", " (catMaybes attrs) <> "] :: [(Symbol, *)])"++-- | Generate a constructor for a zero-filled struct/union of the given+-- type, using the boxed (or GLib, for unboxed types) allocator.+genZeroSU :: Name -> Int -> Bool -> CodeGen ()+genZeroSU n size isBoxed =+ when (size /= 0) $ group $ do+ name <- upperName n+ let builder = "newZero" <> name+ tsize = tshow size+ line $ "-- | Construct a `" <> name <> "` struct initialized to zero."+ line $ builder <> " :: MonadIO m => m " <> name+ line $ builder <> " = liftIO $ " <>+ if isBoxed+ then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name+ else "callocBytes " <> tsize <> " >>= wrapPtr " <> name+ exportDecl builder++ blank++ -- Overloaded "new"+ group $ do+ line $ "instance tag ~ 'AttrSet => Constructible " <> name <> " tag where"+ indent $ do+ line $ "new _ attrs = do"+ indent $ do+ line $ "o <- " <> builder+ line $ "GI.Attributes.set o attrs"+ line $ "return o"++-- | Specialization for structs of `genZeroSU`.+genZeroStruct :: Name -> Struct -> CodeGen ()+genZeroStruct n s = genZeroSU n (structSize s) (structIsBoxed s)++-- | Specialization for unions of `genZeroSU`.+genZeroUnion :: Name -> Union -> CodeGen ()+genZeroUnion n u = genZeroSU n (unionSize u) (unionIsBoxed u)
+ lib/Data/GI/CodeGen/SymbolNaming.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE ViewPatterns #-}+module Data.GI.CodeGen.SymbolNaming+ ( qualify+ , lowerName+ , upperName+ , noName+ , escapedArgName+ , classConstraint+ , hyphensToCamelCase+ , underscoresToCamelCase+ ) where++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.Util (lcFirst, ucFirst)++classConstraint :: Text -> Text+classConstraint n = n <> "K"++-- | Move leading underscores to the end (for example in+-- GObject::_Value_Data_Union -> GObject::Value_Data_Union_)+sanitize :: Text -> Text+sanitize (T.uncons -> Just ('_', xs)) = sanitize xs <> "_"+sanitize xs = xs++lowerName :: Name -> Text+lowerName (Name _ s) =+ case underscoresToCamelCase (sanitize s) of+ "" -> 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 -> CodeGen Text+upperName = upperNameWithSuffix "."++-- | 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++-- | Return the qualified namespace (ns ++ "." or "", depending on+-- whether ns is the current namespace).+qualify :: Text -> CodeGen Text+qualify = qualifyWithSuffix "."++-- | Save a bit of typing for optional arguments in the case that we+-- want to pass Nothing.+noName :: Text -> CodeGen ()+noName name' = group $ do+ line $ "no" <> name' <> " :: Maybe " <> name'+ line $ "no" <> name' <> " = Nothing"+ exportDecl ("no" <> name')++-- | For a string of the form "one-sample-string" return "OneSampleString"+hyphensToCamelCase :: Text -> Text+hyphensToCamelCase = T.concat . map ucFirst . T.split (== '-')++-- | Similarly, turn a name separated_by_underscores into+-- CamelCase. We preserve final and initial underscores, and n>1+-- consecutive underscores are transformed into n-1 underscores.+underscoresToCamelCase :: Text -> Text+underscoresToCamelCase =+ T.concat . map normalize . map ucFirst . T.split (== '_')+ where normalize :: Text -> Text+ normalize "" = "_"+ normalize s = s++-- | Name for the given argument, making sure it is a valid Haskell+-- argument name (and escaping it if not).+escapedArgName :: Arg -> Text+escapedArgName arg+ | "_" `T.isPrefixOf` argCName arg = argCName arg+ | otherwise =+ escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg++-- | Reserved symbols, either because they are Haskell syntax or+-- because the clash with symbols in scope for the generated bindings.+escapeReserved :: Text -> Text+escapeReserved "type" = "type_"+escapeReserved "in" = "in_"+escapeReserved "data" = "data_"+escapeReserved "instance" = "instance_"+escapeReserved "where" = "where_"+escapeReserved "module" = "module_"+-- Reserved because we generate code that uses these names.+escapeReserved "result" = "result_"+escapeReserved "return" = "return_"+escapeReserved "show" = "show_"+escapeReserved "fromEnum" = "fromEnum_"+escapeReserved "toEnum" = "toEnum_"+escapeReserved "undefined" = "undefined_"+escapeReserved "error" = "error_"+escapeReserved "map" = "map_"+escapeReserved "length" = "length_"+escapeReserved "mapM" = "mapM__"+escapeReserved "mapM_" = "mapM___"+escapeReserved "fromIntegral" = "fromIntegral_"+escapeReserved "realToFrac" = "realToFrac_"+escapeReserved "peek" = "peek_"+escapeReserved "poke" = "poke_"+escapeReserved "sizeOf" = "sizeOf_"+escapeReserved "when" = "when_"+escapeReserved "default" = "default_"+escapeReserved s+ | "set_" `T.isPrefixOf` s = s <> "_"+ | "get_" `T.isPrefixOf` s = s <> "_"+ | otherwise = s
+ lib/Data/GI/CodeGen/Transfer.hs view
@@ -0,0 +1,257 @@+-- Routines dealing with memory management in marshalling functions.++module Data.GI.CodeGen.Transfer+ ( freeInArg+ , freeInArgOnError+ , freeContainerType+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif++import Control.Monad (when)+import Data.Maybe (isJust)+import Data.Text (Text)++import Data.GI.CodeGen.API+import Data.GI.CodeGen.Code+import Data.GI.CodeGen.Conversions+import Data.GI.CodeGen.GObject+import Data.GI.CodeGen.Type+import Data.GI.CodeGen.Util++-- Basic primitives for freeing the given types. Types that point to+-- Haskell objects with memory managed by the GC should not be freed+-- here. For containers this is only for freeing the container itself,+-- freeing the elements is done separately.+basicFreeFn :: Type -> Maybe Text+basicFreeFn (TBasicType TUTF8) = Just "freeMem"+basicFreeFn (TBasicType TFileName) = Just "freeMem"+basicFreeFn (TBasicType _) = Nothing+basicFreeFn (TInterface _ _) = Nothing+basicFreeFn (TCArray False (-1) (-1) _) = Nothing -- Just passing it along+basicFreeFn (TCArray{}) = Just "freeMem"+basicFreeFn (TGArray _) = Just "unrefGArray"+basicFreeFn (TPtrArray _) = Just "unrefPtrArray"+basicFreeFn (TByteArray) = Just "unrefGByteArray"+basicFreeFn (TGList _) = Just "g_list_free"+basicFreeFn (TGSList _) = Just "g_slist_free"+basicFreeFn (TGHash _ _) = Just "unrefGHashTable"+basicFreeFn (TError) = Nothing+basicFreeFn (TVariant) = Nothing+basicFreeFn (TParamSpec) = Nothing++-- Basic free primitives in the case that an error occured. This is+-- run in the exception handler, so any type which we ref/allocate+-- with the expectation that the called function will consume it (on+-- TransferEverything) should be freed here.+basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text)+basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem"+basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem"+basicFreeFnOnError (TBasicType _) _ = return Nothing+basicFreeFnOnError TVariant transfer =+ return $ if transfer == TransferEverything+ then Just "unrefGVariant"+ else Nothing+basicFreeFnOnError TParamSpec transfer =+ return $ if transfer == TransferEverything+ then Just "unrefGParamSpec"+ else Nothing+basicFreeFnOnError t@(TInterface _ _) transfer = do+ api <- findAPI t+ case api of+ Just (APIObject _) -> if transfer == TransferEverything+ then do+ isGO <- isGObject t+ if isGO+ then return $ Just "unrefObject"+ else do+ line "-- XXX Transfer a non-GObject object"+ return Nothing+ else return Nothing+ Just (APIInterface _) -> if transfer == TransferEverything+ then do+ isGO <- isGObject t+ if isGO+ then return $ Just "unrefObject"+ else do+ line "-- XXX Transfer a non-GObject object"+ return Nothing+ else return Nothing+ Just (APIUnion u) -> if transfer == TransferEverything+ then if unionIsBoxed u+ then return $ Just "freeBoxed"+ else do+ line "-- XXX Transfer a non-boxed union"+ return Nothing+ else return Nothing+ Just (APIStruct s) -> if transfer == TransferEverything+ then if structIsBoxed s+ then return $ Just "freeBoxed"+ else do+ line "-- XXX Transfer a non-boxed struct"+ return Nothing+ else return Nothing+ _ -> return Nothing+-- Arrays without length info are just passed along, we do not need to+-- free them.+basicFreeFnOnError (TCArray False (-1) (-1) _) _ = return Nothing+basicFreeFnOnError (TCArray{}) _ = return $ Just "freeMem"+basicFreeFnOnError (TGArray _) _ = return $ Just "unrefGArray"+basicFreeFnOnError (TPtrArray _) _ = return $ Just "unrefPtrArray"+basicFreeFnOnError (TByteArray) _ = return $ Just "unrefGByteArray"+basicFreeFnOnError (TGList _) _ = return $ Just "g_list_free"+basicFreeFnOnError (TGSList _) _ = return $ Just "g_slist_free"+basicFreeFnOnError (TGHash _ _) _ = return $ Just "unrefGHashTable"+basicFreeFnOnError (TError) _ = return Nothing++-- Free just the container, but not the elements.+freeContainer :: Type -> Text -> CodeGen [Text]+freeContainer t label =+ case basicFreeFn t of+ Nothing -> return []+ Just fn -> return [fn <> " " <> label]++-- Free one element using the given free function.+freeElem :: Type -> Text -> Text -> ExcCodeGen Text+freeElem t label free =+ case elementTypeAndMap t undefined of+ Nothing -> return free+ Just (TCArray False _ _ _, _) ->+ badIntroError $ "Element type in container \"" <> label <>+ "\" is an array of unknown length."+ Just (innerType, mapFn) -> do+ let elemFree = "freeElemOf" <> ucFirst label+ fullyFree innerType (prime label) >>= \case+ Nothing -> return $ free <> " e"+ Just elemInnerFree -> do+ line $ "let " <> elemFree <> " e = " <> mapFn <> " "+ <> elemInnerFree <> " e >> " <> free <> " e"+ return elemFree++-- Construct a function to free the memory associated with a type, and+-- recursively free any elements of this type in case that it is a+-- container.+fullyFree :: Type -> Text -> ExcCodeGen (Maybe Text)+fullyFree t label = case basicFreeFn t of+ Nothing -> return Nothing+ Just free -> Just <$> freeElem t label free++-- Like fullyFree, but free the toplevel element using basicFreeFnOnError.+fullyFreeOnError :: Type -> Text -> Transfer -> ExcCodeGen (Maybe Text)+fullyFreeOnError t label transfer =+ basicFreeFnOnError t transfer >>= \case+ Nothing -> return Nothing+ Just free -> Just <$> freeElem t label free++-- Free the elements in a container type.+freeElements :: Type -> Text -> Text -> ExcCodeGen [Text]+freeElements t label len =+ case elementTypeAndMap t len of+ Nothing -> return []+ Just (inner, mapFn) ->+ fullyFree inner label >>= \case+ Nothing -> return []+ Just innerFree ->+ return [mapFn <> " " <> innerFree <> " " <> label]++-- | Free a container and/or the contained elements, depending on the+-- transfer mode.+freeContainerType :: Transfer -> Type -> Text -> Text -> ExcCodeGen ()+freeContainerType transfer (TGHash _ _) label _ = freeGHashTable transfer label+freeContainerType transfer t label len = do+ when (transfer == TransferEverything) $+ mapM_ line =<< freeElements t label len+ when (transfer /= TransferNothing) $+ mapM_ line =<< freeContainer t label++freeGHashTable :: Transfer -> Text -> ExcCodeGen ()+freeGHashTable TransferNothing _ = return ()+freeGHashTable TransferContainer label =+ notImplementedError $ "Hash table argument with transfer = Container? "+ <> label+-- Hash tables support setting a free function for keys and elements,+-- we assume that these are always properly set. The worst that can+-- happen this way is a memory leak, as opposed to a double free if we+-- try do free anything here.+freeGHashTable TransferEverything label =+ line $ "unrefGHashTable " <> label++-- Free the elements of a container type in the case an error ocurred,+-- in particular args that should have been transferred did not get+-- transfered.+freeElementsOnError :: Transfer -> Type -> Text -> Text ->+ ExcCodeGen [Text]+freeElementsOnError transfer t label len =+ case elementTypeAndMap t len of+ Nothing -> return []+ Just (inner, mapFn) ->+ fullyFreeOnError inner label transfer >>= \case+ Nothing -> return []+ Just innerFree ->+ return [mapFn <> " " <> innerFree <> " " <> label]++freeIn :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]+freeIn transfer (TGHash _ _) label _ =+ freeInGHashTable transfer label+freeIn transfer t label len =+ case transfer of+ TransferNothing -> (<>) <$> freeElements t label len <*> freeContainer t label+ TransferContainer -> freeElements t label len+ TransferEverything -> return []++freeInOnError :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]+freeInOnError transfer (TGHash _ _) label _ =+ freeInGHashTable transfer label+freeInOnError transfer t label len =+ (<>) <$> freeElementsOnError transfer t label len+ <*> freeContainer t label++-- See freeGHashTable above.+freeInGHashTable :: Transfer -> Text -> ExcCodeGen [Text]+freeInGHashTable TransferEverything _ = return []+freeInGHashTable TransferContainer label =+ notImplementedError $ "Hash table argument with TransferContainer? "+ <> label+freeInGHashTable TransferNothing label = return ["unrefGHashTable " <> label]++freeOut :: Text -> CodeGen [Text]+freeOut label = return ["freeMem " <> label]++-- | Given an input argument to a C callable, and its label in the code,+-- return the list of actions relevant to freeing the memory allocated+-- for the argument (if appropriate, depending on the ownership+-- transfer semantics of the callable).+freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text]+freeInArg arg label len = do+ weAlloc <- isJust <$> requiresAlloc (argType arg)+ -- Arguments that we alloc ourselves do not need to be freed, they+ -- will always be soaked up by the wrapPtr constructor, or they will+ -- be DirectionIn.+ if not weAlloc+ then case direction arg of+ DirectionIn -> freeIn (transfer arg) (argType arg) label len+ DirectionOut -> freeOut label+ DirectionInout ->+ -- Caller-allocates arguments are like "in" arguments for+ -- memory management purposes.+ if argCallerAllocates arg+ then freeIn (transfer arg) (argType arg) label len+ else freeOut label+ else return []++-- | Same thing as freeInArg, but called in case the call to C didn't+-- succeed. We thus free everything we allocated in preparation for+-- the call, including args that would have been transferred to C.+freeInArgOnError :: Arg -> Text -> Text -> ExcCodeGen [Text]+freeInArgOnError arg label len =+ case direction arg of+ DirectionIn -> freeInOnError (transfer arg) (argType arg) label len+ DirectionOut -> freeOut label+ DirectionInout ->+ -- Caller-allocates arguments are like "in" arguments for+ -- memory management purposes.+ if argCallerAllocates arg+ then freeInOnError (transfer arg) (argType arg) label len+ else freeOut label
+ lib/Data/GI/CodeGen/Type.hs view
@@ -0,0 +1,41 @@+-- | Type constructors.+module Data.GI.CodeGen.Type+ ( Type(..) -- Reexported for convenience.+ , BasicType(..)++ , io+ , ptr+ , funptr+ , con+ , maybeT+ ) where++import Data.Typeable (TypeRep, mkTyConApp, typeOf, typeRepTyCon, mkTyCon3)+import qualified Data.Text as T+import Data.Text (Text)++import Data.GI.GIR.BasicTypes (Type(..), BasicType(..))++-- | Type constructor applied to the given types.+con :: Text -> [TypeRep] -> TypeRep+con "[]" xs = mkTyConApp listCon xs+ where listCon = typeRepTyCon (typeOf [True])+con "(,)" xs = mkTyConApp tupleCon xs+ where tupleCon = typeRepTyCon (typeOf (True, True))+con s xs = mkTyConApp (mkTyCon3 "GI" "GI" (T.unpack s)) xs++-- | Embed in the `IO` monad.+io :: TypeRep -> TypeRep+io t = "IO" `con` [t]++-- | A `Ptr` to the type.+ptr :: TypeRep -> TypeRep+ptr t = "Ptr" `con` [t]++-- | A `FunPtr` to the type.+funptr :: TypeRep -> TypeRep+funptr t = "FunPtr" `con` [t]++-- | Embed in the `Maybe` monad.+maybeT :: TypeRep -> TypeRep+maybeT t = "Maybe" `con` [t]
+ lib/Data/GI/CodeGen/Util.hs view
@@ -0,0 +1,48 @@+module Data.GI.CodeGen.Util+ ( prime+ , parenthesize++ , padTo+ , withComment++ , ucFirst+ , lcFirst++ , tshow+ , terror+ ) where++import Data.Monoid ((<>))+import Data.Char (toLower, toUpper)+import Data.Text (Text)+import qualified Data.Text as T++padTo :: Int -> Text -> Text+padTo n s = s <> T.replicate (n - T.length s) " "++withComment :: Text -> Text -> Text+withComment a b = padTo 40 a <> "-- " <> b++prime :: Text -> Text+prime = (<> "'")++parenthesize :: Text -> Text+parenthesize s = "(" <> s <> ")"++-- | Construct the `Text` representation of a showable.+tshow :: Show a => a -> Text+tshow = T.pack . show++-- | Throw an error with the given `Text`.+terror :: Text -> a+terror = error . T.unpack++-- | Capitalize the first character of the given string.+ucFirst :: Text -> Text+ucFirst "" = ""+ucFirst t = T.cons (toUpper $ T.head t) (T.tail t)++-- | Make the first character of the given string lowercase.+lcFirst :: Text -> Text+lcFirst "" = ""+lcFirst t = T.cons (toLower $ T.head t) (T.tail t)
+ lib/Data/GI/GIR/Alias.hs view
@@ -0,0 +1,39 @@+module Data.GI.GIR.Alias+ ( documentListAliases+ ) where++import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T+import Text.XML (Element(elementAttributes), Document(documentRoot))++import Data.GI.GIR.BasicTypes (Alias(..), Type)+import Data.GI.GIR.Type (parseType)+import Data.GI.GIR.Parser+import Data.GI.GIR.XMLUtils (childElemsWithLocalName)++-- | Find all aliases in a given namespace.+namespaceListAliases :: Element -> M.Map Alias Type+namespaceListAliases ns =+ case M.lookup "name" (elementAttributes ns) of+ Nothing -> error $ "Namespace with no name!"+ Just nsName -> case runParser nsName M.empty ns parseAliases of+ Left err -> (error . T.unpack) err+ Right aliases -> M.fromList (map addNS aliases)+ where addNS (n, t) = (Alias (nsName, n), t)++-- | Parse all the aliases in the current namespace+parseAliases :: Parser [(Text, Type)]+parseAliases = parseChildrenWithLocalName "alias" parseAlias++-- | Parse a single alias+parseAlias :: Parser (Text, Type)+parseAlias = do+ name <- getAttr "name"+ t <- parseType+ return (name, t)++-- | Find all aliases in a given document.+documentListAliases :: Document -> M.Map Alias Type+documentListAliases doc = M.unions (map namespaceListAliases namespaces)+ where namespaces = childElemsWithLocalName "namespace" (documentRoot doc)
+ lib/Data/GI/GIR/Arg.hs view
@@ -0,0 +1,80 @@+module Data.GI.GIR.Arg+ ( Arg(..)+ , Direction(..)+ , Scope(..)+ , parseArg+ , parseTransfer+ ) where++import Data.Monoid ((<>))+import Data.Text (Text)++import Data.GI.GIR.BasicTypes (Transfer(..), Type)+import Data.GI.GIR.Parser+import Data.GI.GIR.Type (parseType)++data Direction = DirectionIn+ | DirectionOut+ | DirectionInout+ deriving (Show, Eq, Ord)++data Scope = ScopeTypeInvalid+ | ScopeTypeCall+ | ScopeTypeAsync+ | ScopeTypeNotified+ deriving (Show, Eq, Ord)++data Arg = Arg {+ argCName :: Text, -- ^ "C" name for the argument. For a+ -- escaped name valid in Haskell code, use+ -- `GI.SymbolNaming.escapedArgName`.+ argType :: Type,+ direction :: Direction,+ mayBeNull :: Bool,+ argScope :: Scope,+ argClosure :: Int,+ argDestroy :: Int,+ argCallerAllocates :: Bool,+ transfer :: Transfer+ } deriving (Show, Eq, Ord)++parseTransfer :: Parser Transfer+parseTransfer = getAttr "transfer-ownership" >>= \case+ "none" -> return TransferNothing+ "container" -> return TransferContainer+ "full" -> return TransferEverything+ t -> parseError $ "Unknown transfer type \"" <> t <> "\""++parseScope :: Text -> Parser Scope+parseScope "call" = return ScopeTypeCall+parseScope "async" = return ScopeTypeAsync+parseScope "notified" = return ScopeTypeNotified+parseScope s = parseError $ "Unknown scope type \"" <> s <> "\""++parseDirection :: Text -> Parser Direction+parseDirection "in" = return DirectionIn+parseDirection "out" = return DirectionOut+parseDirection "inout" = return DirectionInout+parseDirection d = parseError $ "Unknown direction \"" <> d <> "\""++parseArg :: Parser Arg+parseArg = do+ name <- getAttr "name"+ ownership <- parseTransfer+ scope <- optionalAttr "scope" ScopeTypeInvalid parseScope+ d <- optionalAttr "direction" DirectionIn parseDirection+ closure <- optionalAttr "closure" (-1) parseIntegral+ destroy <- optionalAttr "destroy" (-1) parseIntegral+ nullable <- optionalAttr "nullable" False parseBool+ callerAllocates <- optionalAttr "caller-allocates" False parseBool+ t <- parseType+ return $ Arg { argCName = name+ , argType = t+ , direction = d+ , mayBeNull = nullable+ , argScope = scope+ , argClosure = closure+ , argDestroy = destroy+ , argCallerAllocates = callerAllocates+ , transfer = ownership+ }
+ lib/Data/GI/GIR/BasicTypes.hs view
@@ -0,0 +1,67 @@+-- | Basic types used in GIR parsing.+module Data.GI.GIR.BasicTypes+ ( Name(..)+ , Transfer(..)+ , Alias(..)+ , Type(..)+ , BasicType(..)+ ) where++import Data.Text (Text)++-- | Name for a symbol in the GIR file.+data Name = Name { namespace :: Text, name :: Text }+ deriving (Eq, Ord, Show)++-- | Transfer mode for an argument or property.+data Transfer = TransferNothing+ | TransferContainer+ | TransferEverything+ deriving (Show, Eq, Ord)++-- | An alias, which is simply (Namespace, name).+newtype Alias = Alias (Text, Text) deriving (Ord, Eq, Show)++-- | Basic types. These are generally trivial to marshal, and the GIR+-- assumes that they are defined.+data BasicType = TBoolean -- ^ gboolean+ | TInt -- ^ gint+ | TUInt -- ^ guint+ | TLong -- ^ glong+ | TULong -- ^ gulong+ | TInt8 -- ^ gint8+ | TUInt8 -- ^ guint8+ | TInt16 -- ^ gint16+ | TUInt16 -- ^ guint16+ | TInt32 -- ^ gint32+ | TUInt32 -- ^ guint32+ | TInt64 -- ^ gint64+ | TUInt64 -- ^ guint64+ | TFloat -- ^ gfloat+ | TDouble -- ^ gdouble+ | TUniChar -- ^ gunichar+ | TGType -- ^ GType+ | TUTF8 -- ^ gchar*, encoded as UTF-8+ | TFileName -- ^ gchar*, encoding a filename+ | TPtr -- ^ gpointer+ | TIntPtr -- ^ gintptr+ | TUIntPtr -- ^ guintptr+ deriving (Eq, Show, Ord)++-- | This type represents the types found in GObject Introspection+-- interfaces: the types of constants, arguments, etc.+data Type+ = TBasicType BasicType+ | TError -- ^ GError+ | TVariant -- ^ GVariant+ | TParamSpec -- ^ GParamSpec+ | TCArray Bool Int Int Type -- ^ Zero terminated, Array Fixed+ -- Size, Array Length, Element Type+ | TGArray Type -- ^ GArray+ | TPtrArray Type -- ^ GPtrArray+ | TByteArray -- ^ GByteArray+ | TGList Type -- ^ GList+ | TGSList Type -- ^ GSList+ | TGHash Type Type -- ^ GHashTable+ | TInterface Text Text -- ^ A reference to some API in the GIR+ deriving (Eq, Show, Ord)
+ lib/Data/GI/GIR/Callable.hs view
@@ -0,0 +1,58 @@+module Data.GI.GIR.Callable+ ( Callable(..)+ , parseCallable+ ) where++import Data.GI.GIR.Arg (Arg(..), parseArg, parseTransfer)+import Data.GI.GIR.BasicTypes (Transfer(..), Type)+import Data.GI.GIR.Parser+import Data.GI.GIR.Type (parseOptionalType)++data Callable = Callable {+ returnType :: Maybe Type,+ returnMayBeNull :: Bool,+ returnTransfer :: Transfer,+ args :: [Arg],+ skipReturn :: Bool,+ callableDeprecated :: Maybe DeprecationInfo+ } deriving (Show, Eq)++parseArgs :: Parser [Arg]+parseArgs = do+ paramSets <- parseChildrenWithLocalName "parameters" parseArgSet+ case paramSets of+ [] -> return []+ (ps:[]) -> return ps+ _ -> parseError $ "Unexpected multiple \"parameters\" tag"+ where parseArgSet = parseChildrenWithLocalName "parameter" parseArg++parseOneReturn :: Parser (Maybe Type, Bool, Transfer, Bool)+parseOneReturn = do+ returnType <- parseOptionalType+ allowNone <- optionalAttr "allow-none" False parseBool+ nullable <- optionalAttr "nullable" False parseBool+ transfer <- parseTransfer+ skip <- optionalAttr "skip" False parseBool+ return (returnType, allowNone || nullable, transfer, skip)++parseReturn :: Parser (Maybe Type, Bool, Transfer, Bool)+parseReturn = do+ returnSets <- parseChildrenWithLocalName "return-value" parseOneReturn+ case returnSets of+ (r:[]) -> return r+ [] -> parseError $ "No return information found"+ _ -> parseError $ "Multiple return values found"++parseCallable :: Parser Callable+parseCallable = do+ args <- parseArgs+ (returnType, mayBeNull, transfer, skip) <- parseReturn+ deprecated <- parseDeprecation+ return $ Callable {+ returnType = returnType+ , returnMayBeNull = mayBeNull+ , returnTransfer = transfer+ , args = args+ , skipReturn = skip+ , callableDeprecated = deprecated+ }
+ lib/Data/GI/GIR/Callback.hs view
@@ -0,0 +1,17 @@+-- | Parsing of callbacks.+module Data.GI.GIR.Callback+ ( Callback(..)+ , parseCallback+ ) where++import Data.GI.GIR.Parser+import Data.GI.GIR.Callable (Callable, parseCallable)++data Callback = Callback Callable+ deriving Show++parseCallback :: Parser (Name, Callback)+parseCallback = do+ name <- parseName+ callable <- parseCallable+ return (name, Callback callable)
+ lib/Data/GI/GIR/Constant.hs view
@@ -0,0 +1,27 @@+-- | Parsing of constants in GIR files.+module Data.GI.GIR.Constant+ ( Constant(..)+ , parseConstant+ ) where++import Data.Text (Text)++import Data.GI.GIR.BasicTypes (Type)+import Data.GI.GIR.Type (parseType)+import Data.GI.GIR.Parser++-- | Info about a constant.+data Constant = Constant {+ constantType :: Type,+ constantValue :: Text,+ constantDeprecated :: Maybe DeprecationInfo+ } deriving (Show)++-- | Parse a "constant" element from the GIR file.+parseConstant :: Parser (Name, Constant)+parseConstant = do+ name <- parseName+ deprecated <- parseDeprecation+ value <- getAttr "value"+ t <- parseType+ return (name, Constant t value deprecated)
+ lib/Data/GI/GIR/Deprecation.hs view
@@ -0,0 +1,43 @@+module Data.GI.GIR.Deprecation+ ( DeprecationInfo+ , deprecatedPragma+ , queryDeprecated+ ) where++import Data.Monoid ((<>))+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)+import Text.XML (Element(elementAttributes))++import Data.GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)++-- | Deprecation information on a symbol.+data DeprecationInfo = DeprecationInfo {+ deprecatedSinceVersion :: Maybe Text,+ deprecationMessage :: Maybe Text+ } deriving (Show, Eq)++-- | Encode the given `DeprecationInfo` for the given symbol as a+-- deprecation pragma.+deprecatedPragma :: Text -> Maybe DeprecationInfo -> Text+deprecatedPragma _ Nothing = ""+deprecatedPragma name (Just info) = "{-# DEPRECATED " <> name <> " " <>+ (T.pack . show) (note <> reason) <> "#-}"+ where reason = case deprecationMessage info of+ Nothing -> []+ Just msg -> T.lines msg+ note = case deprecatedSinceVersion info of+ Nothing -> []+ Just v -> ["(Since version " <> v <> ")"]++-- | Parse the deprecation information for the given element of the GIR file.+queryDeprecated :: Element -> Maybe DeprecationInfo+queryDeprecated element =+ case M.lookup "deprecated" attrs of+ Just _ -> let version = M.lookup "deprecated-version" attrs+ msg = firstChildWithLocalName "doc-deprecated" element >>=+ getElementContent+ in Just (DeprecationInfo version msg)+ Nothing -> Nothing+ where attrs = elementAttributes element
+ lib/Data/GI/GIR/Documentation.hs view
@@ -0,0 +1,20 @@+-- | Parsing of documentation nodes.+module Data.GI.GIR.Documentation+ ( Documentation(..)+ , queryDocumentation+ ) where++import Data.Text (Text)+import Text.XML (Element)++import Data.GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)++-- | Documentation for a given element.+data Documentation = Documentation {+ docText :: Text+ } deriving (Show, Eq)++-- | Parse the documentation node for the given element of the GIR file.+queryDocumentation :: Element -> Maybe Documentation+queryDocumentation element = fmap Documentation+ (firstChildWithLocalName "doc" element >>= getElementContent)
+ lib/Data/GI/GIR/Enum.hs view
@@ -0,0 +1,52 @@+-- | Parsing of Enums.+module Data.GI.GIR.Enum+ ( Enumeration(..)+ , parseEnum+ ) where++import Data.Int (Int64)+import Data.Text (Text)+import Foreign.C (CInt(..))++import Data.GI.GIR.Parser++data Enumeration = Enumeration {+ enumValues :: [(Text, Int64)],+ errorDomain :: Maybe Text,+ enumTypeInit :: Maybe Text,+ enumStorageBytes :: Int, -- ^ Bytes used for storage of this struct.+ enumDeprecated :: Maybe DeprecationInfo }+ deriving Show++-- | Parse a struct member.+parseEnumMember :: Parser (Text, Int64)+parseEnumMember = do+ name <- getAttr "name"+ value <- getAttr "value" >>= parseIntegral+ return (name, value)++foreign import ccall "_gi_get_enum_storage_bytes" get_storage_bytes ::+ Int64 -> Int64 -> CInt++-- | Return the number of bytes that should be allocated for storage+-- of the given values in an enum.+extractEnumStorageBytes :: [Int64] -> Int+extractEnumStorageBytes values =+ fromIntegral $ get_storage_bytes (minimum values) (maximum values)++-- | Parse an "enumeration" element from the GIR file.+parseEnum :: Parser (Name, Enumeration)+parseEnum = do+ name <- parseName+ deprecated <- parseDeprecation+ errorDomain <- queryAttrWithNamespace GLibGIRNS "error-domain"+ typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+ values <- parseChildrenWithLocalName "member" parseEnumMember+ return (name,+ Enumeration {+ enumValues = values+ , errorDomain = errorDomain+ , enumTypeInit = typeInit+ , enumStorageBytes = extractEnumStorageBytes (map snd values)+ , enumDeprecated = deprecated+ })
+ lib/Data/GI/GIR/Field.hs view
@@ -0,0 +1,74 @@+-- | Parsing of object/struct/union fields.+module Data.GI.GIR.Field+ ( Field(..)+ , FieldInfoFlag+ , parseFields+ ) where++import Data.Monoid ((<>))+import Data.Text (Text)++import Data.GI.GIR.BasicTypes (Type(..))+import Data.GI.GIR.Callback (Callback, parseCallback)+import Data.GI.GIR.Type (parseType)+import Data.GI.GIR.Parser++data Field = Field {+ fieldName :: Text,+ fieldVisible :: Bool,+ fieldType :: Type,+ fieldCallback :: Maybe Callback,+ fieldOffset :: Int,+ fieldFlags :: [FieldInfoFlag],+ fieldDeprecated :: Maybe DeprecationInfo }+ deriving Show++data FieldInfoFlag = FieldIsReadable | FieldIsWritable+ deriving Show++-- | Parse a single field in a struct or union. We parse+-- non-introspectable fields too (but set fieldVisible = False for+-- them), this is necessary since they affect the computation of+-- offsets of fields and sizes of containing structs.+parseField :: Parser Field+parseField = do+ name <- getAttr "name"+ deprecated <- parseDeprecation+ readable <- optionalAttr "readable" True parseBool+ writable <- optionalAttr "writable" False parseBool+ let flags = if readable then [FieldIsReadable] else []+ <> if writable then [FieldIsWritable] else []+ introspectable <- optionalAttr "introspectable" True parseBool+ private <- optionalAttr "private" False parseBool+ (t, callback) <-+ if introspectable+ then do+ callbacks <- parseChildrenWithLocalName "callback" parseCallback+ (cbn, callback) <- case callbacks of+ [] -> return (Nothing, Nothing)+ [(n, cb)] -> return (Just n, Just cb)+ _ -> parseError "Multiple callbacks in field"+ t <- case cbn of+ Nothing -> parseType+ Just (Name ns n) -> return (TInterface ns n)+ return (t, callback)+ else do+ callbacks <- parseAllChildrenWithLocalName "callback" parseName+ case callbacks of+ [] -> do+ t <- parseType+ return (t, Nothing)+ [Name ns n] -> return (TInterface ns n, Nothing)+ _ -> parseError "Multiple callbacks in field"+ return $ Field {+ fieldName = name+ , fieldVisible = introspectable && not private+ , fieldType = t+ , fieldCallback = callback+ , fieldOffset = error ("unfixed field offset " ++ show name)+ , fieldFlags = flags+ , fieldDeprecated = deprecated+ }++parseFields :: Parser [Field]+parseFields = parseAllChildrenWithLocalName "field" parseField
+ lib/Data/GI/GIR/Flags.hs view
@@ -0,0 +1,17 @@+-- | Parsing of bitfields, a.k.a. flags. They are represented in the+-- same way as enums, so this is a thin wrapper over that code.+module Data.GI.GIR.Flags+ ( Flags(..)+ , parseFlags+ ) where++import Data.GI.GIR.Enum (Enumeration, parseEnum)+import Data.GI.GIR.Parser++data Flags = Flags Enumeration+ deriving Show++parseFlags :: Parser (Name, Flags)+parseFlags = do+ (n, enum) <- parseEnum+ return (n, Flags enum)
+ lib/Data/GI/GIR/Function.hs view
@@ -0,0 +1,35 @@+module Data.GI.GIR.Function+ ( Function(..)+ , parseFunction+ ) where++import Data.Text (Text)++import Data.GI.GIR.Callable (Callable(..), parseCallable)+import Data.GI.GIR.Parser++data Function = Function {+ fnSymbol :: Text+ , fnThrows :: Bool+ , fnMovedTo :: Maybe Text+ , fnCallable :: Callable+ } deriving Show++parseFunction :: Parser (Name, Function)+parseFunction = do+ name <- parseName+ shadows <- queryAttr "shadows"+ let exposedName = case shadows of+ Just n -> name {name = n}+ Nothing -> name+ callable <- parseCallable+ symbol <- getAttrWithNamespace CGIRNS "identifier"+ throws <- optionalAttr "throws" False parseBool+ movedTo <- queryAttr "moved-to"+ return $ (exposedName,+ Function {+ fnSymbol = symbol+ , fnCallable = callable+ , fnThrows = throws+ , fnMovedTo = movedTo+ })
+ lib/Data/GI/GIR/Interface.hs view
@@ -0,0 +1,40 @@+module Data.GI.GIR.Interface+ ( Interface(..)+ , parseInterface+ ) where++import Data.Text (Text)++import Data.GI.GIR.Method (Method, MethodType(..), parseMethod)+import Data.GI.GIR.Property (Property, parseProperty)+import Data.GI.GIR.Signal (Signal, parseSignal)+import Data.GI.GIR.Parser++data Interface = Interface {+ ifTypeInit :: Maybe Text,+ ifPrerequisites :: [Name],+ ifProperties :: [Property],+ ifSignals :: [Signal],+ ifMethods :: [Method],+ ifDeprecated :: Maybe DeprecationInfo+ } deriving Show++parseInterface :: Parser (Name, Interface)+parseInterface = do+ name <- parseName+ props <- parseChildrenWithLocalName "property" parseProperty+ signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal+ typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+ methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+ functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+ constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+ deprecated <- parseDeprecation+ return (name,+ Interface {+ ifProperties = props+ , ifPrerequisites = error ("unfixed interface " ++ show name)+ , ifSignals = signals+ , ifTypeInit = typeInit+ , ifMethods = constructors ++ methods ++ functions+ , ifDeprecated = deprecated+ })
+ lib/Data/GI/GIR/Method.hs view
@@ -0,0 +1,45 @@+module Data.GI.GIR.Method+ ( Method(..)+ , MethodType(..)+ , parseMethod+ ) where++import Data.Text (Text)++import Data.GI.GIR.Callable (Callable(..), parseCallable)+import Data.GI.GIR.Parser++data MethodType = Constructor -- ^ Constructs an instance of the parent type+ | MemberFunction -- ^ A function in the namespace+ | OrdinaryMethod -- ^ A function taking the parent+ -- instance as first argument.+ deriving (Eq, Show)++data Method = Method {+ methodName :: Name,+ methodSymbol :: Text,+ methodThrows :: Bool,+ methodType :: MethodType,+ methodMovedTo :: Maybe Text,+ methodCallable :: Callable+ } deriving (Eq, Show)++parseMethod :: MethodType -> Parser Method+parseMethod mType = do+ name <- parseName+ shadows <- queryAttr "shadows"+ let exposedName = case shadows of+ Just n -> name {name = n}+ Nothing -> name+ callable <- parseCallable+ symbol <- getAttrWithNamespace CGIRNS "identifier"+ throws <- optionalAttr "throws" False parseBool+ movedTo <- queryAttr "moved-to"+ return $ Method {+ methodName = exposedName+ , methodSymbol = symbol+ , methodThrows = throws+ , methodType = mType+ , methodMovedTo = movedTo+ , methodCallable = callable+ }
+ lib/Data/GI/GIR/Object.hs view
@@ -0,0 +1,52 @@+-- | Parsing of objects.+module Data.GI.GIR.Object+ ( Object(..)+ , parseObject+ ) where++import Data.Text (Text)++import Data.GI.GIR.Method (Method, parseMethod, MethodType(..))+import Data.GI.GIR.Property (Property, parseProperty)+import Data.GI.GIR.Signal (Signal, parseSignal)+import Data.GI.GIR.Parser++data Object = Object {+ objParent :: Maybe Name,+ objTypeInit :: Text,+ objTypeName :: Text,+ objInterfaces :: [Name],+ objDeprecated :: Maybe DeprecationInfo,+ objDocumentation :: Maybe Documentation,+ objMethods :: [Method],+ objProperties :: [Property],+ objSignals :: [Signal]+ } deriving Show++parseObject :: Parser (Name, Object)+parseObject = do+ name <- parseName+ deprecated <- parseDeprecation+ doc <- parseDocumentation+ methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+ constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+ functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+ parent <- optionalAttr "parent" Nothing (fmap Just . qualifyName)+ interfaces <- parseChildrenWithLocalName "implements" parseName+ props <- parseChildrenWithLocalName "property" parseProperty+ typeInit <- getAttrWithNamespace GLibGIRNS "get-type"+ typeName <- getAttrWithNamespace GLibGIRNS "type-name"+ signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal+ return (name,+ Object {+ objParent = parent+ , objTypeInit = typeInit+ , objTypeName = typeName+ , objInterfaces = interfaces+ , objDeprecated = deprecated+ , objDocumentation = doc+ , objMethods = constructors ++ methods ++ functions+ , objProperties = props+ , objSignals = signals+ })+
+ lib/Data/GI/GIR/Parser.hs view
@@ -0,0 +1,237 @@+-- | The Parser monad.+module Data.GI.GIR.Parser+ ( Parser+ , ParseError+ , parseError++ , runParser++ , parseName+ , parseDeprecation+ , parseDocumentation+ , parseIntegral+ , parseBool+ , parseChildrenWithLocalName+ , parseAllChildrenWithLocalName+ , parseChildrenWithNSName++ , getAttr+ , getAttrWithNamespace+ , queryAttr+ , queryAttrWithNamespace+ , optionalAttr++ , currentNamespace+ , qualifyName+ , resolveQualifiedTypeName++ -- Reexported for convenience+ , Name(..)+ , Element+ , GIRXMLNamespace(..)+ , DeprecationInfo+ , Documentation+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad.Except+import Control.Monad.Reader++import Data.Monoid ((<>))+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import Data.Text (Text)+import qualified Text.XML as XML+import Text.XML (Element(elementAttributes))+import Text.Show.Pretty (ppShow)++import Data.GI.GIR.BasicTypes (Name(..), Alias(..), Type(TInterface))+import Data.GI.GIR.Deprecation (DeprecationInfo, queryDeprecated)+import Data.GI.GIR.Documentation (Documentation, queryDocumentation)+import Data.GI.GIR.XMLUtils (localName, GIRXMLNamespace(..),+ childElemsWithLocalName, childElemsWithNSName,+ lookupAttr, lookupAttrWithNamespace)++-- | Info to carry around when parsing.+data ParseContext = ParseContext {+ ctxNamespace :: Text,+ -- Location in the XML tree of the node being parsed (for+ -- debugging purposes).+ treePosition :: [Text],+ -- Current element being parsed (to be set by withElement)+ currentElement :: Element,+ knownAliases :: M.Map Alias Type+ } deriving Show++-- | A message describing a parsing error in human readable form.+type ParseError = Text++-- | Monad where parsers live: we carry a context around, and can+-- throw errors that abort the parsing.+type Parser a = ReaderT ParseContext (Except ParseError) a++-- | Throw a parse error.+parseError :: ParseError -> Parser a+parseError msg = do+ ctx <- ask+ let position = (T.intercalate " / " . reverse . treePosition) ctx+ throwError $ "Error when parsing \"" <> position <> "\": " <> msg <> "\n"+ <> (T.pack . ppShow . currentElement) ctx++-- | Build a textual description (for debug purposes) of a given element.+elementDescription :: Element -> Text+elementDescription element =+ case M.lookup "name" (elementAttributes element) of+ Nothing -> localName element+ Just n -> localName element <> " [" <> n <> "]"++-- | Build a name in the current namespace.+nameInCurrentNS :: Text -> Parser Name+nameInCurrentNS n = do+ ctx <- ask+ return $ Name (ctxNamespace ctx) n++-- | Return the current namespace.+currentNamespace :: Parser Text+currentNamespace = ctxNamespace <$> ask++-- | Check whether there is an alias for the given name, and return+-- the corresponding type in case it exists, and otherwise a TInterface.+resolveQualifiedTypeName :: Text -> Text -> Parser Type+resolveQualifiedTypeName ns n = do+ ctx <- ask+ case M.lookup (Alias (ns, n)) (knownAliases ctx) of+ -- The resolved type may be an alias itself, like for+ -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt+ Just (TInterface ns n) -> resolveQualifiedTypeName ns n+ Just t -> return t+ Nothing -> return $ TInterface ns n++-- | Return the value of an attribute for the given element. If the+-- attribute is not present this throws an error.+getAttr :: XML.Name -> Parser Text+getAttr attr = do+ ctx <- ask+ case lookupAttr attr (currentElement ctx) of+ Just val -> return val+ Nothing -> parseError $ "Expected attribute \"" <>+ (T.pack . show) attr <> "\" not present."++-- | Like 'getAttr', but allow for specifying the namespace.+getAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser Text+getAttrWithNamespace ns attr = do+ ctx <- ask+ case lookupAttrWithNamespace ns attr (currentElement ctx) of+ Just val -> return val+ Nothing -> parseError $ "Expected attribute \"" <>+ (T.pack . show) attr <> "\" in namespace \"" <>+ (T.pack . show) ns <> "\" not present."++-- | Return the value of an attribute if it is present, and Nothing otherwise.+queryAttr :: XML.Name -> Parser (Maybe Text)+queryAttr attr = do+ ctx <- ask+ return $ lookupAttr attr (currentElement ctx)++-- | Like `queryAttr`, but allow for specifying the namespace.+queryAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser (Maybe Text)+queryAttrWithNamespace ns attr = do+ ctx <- ask+ return $ lookupAttrWithNamespace ns attr (currentElement ctx)++-- | Ask for an optional attribute, applying the given parser to+-- it. If the argument does not exist return the default value provided.+optionalAttr :: XML.Name -> a -> (Text -> Parser a) -> Parser a+optionalAttr attr def parser =+ queryAttr attr >>= \case+ Just a -> parser a+ Nothing -> return def++-- | Build a 'Name' out of the (possibly qualified) supplied name. If+-- the supplied name is unqualified we qualify with the current+-- namespace, and otherwise we simply parse it.+qualifyName :: Text -> Parser Name+qualifyName n = case T.split (== '.') n of+ [ns, name] -> return $ Name ns name+ [name] -> nameInCurrentNS name+ _ -> parseError "Could not understand name"++-- | Get the qualified name for the current element.+parseName :: Parser Name+parseName = getAttr "name" >>= qualifyName++-- | Parse the deprecation text, if present.+parseDeprecation :: Parser (Maybe DeprecationInfo)+parseDeprecation = do+ ctx <- ask+ return $ queryDeprecated (currentElement ctx)++-- | Parse the documentation text, if present.+parseDocumentation :: Parser (Maybe Documentation)+parseDocumentation = do+ ctx <- ask+ return $ queryDocumentation (currentElement ctx)++-- | Parse a signed integral number.+parseIntegral :: Integral a => Text -> Parser a+parseIntegral str =+ case TR.signed TR.decimal str of+ Right (n, r) | T.null r -> return n+ _ -> parseError $ "Could not parse integral value: \"" <> str <> "\"."++-- | A boolean value given by a numerical constant.+parseBool :: Text -> Parser Bool+parseBool "0" = return False+parseBool "1" = return True+parseBool other = parseError $ "Unsupported boolean value: " <> T.pack (show other)++-- | Parse all the introspectable subelements with the given local name.+parseChildrenWithLocalName :: Text -> Parser a -> Parser [a]+parseChildrenWithLocalName n parser = do+ ctx <- ask+ let introspectableChildren = filter introspectable+ (childElemsWithLocalName n (currentElement ctx))+ mapM (withElement parser) introspectableChildren+ where introspectable :: Element -> Bool+ introspectable e = lookupAttr "introspectable" e /= Just "0" &&+ lookupAttr "shadowed-by" e == Nothing++-- | Parse all subelements with the given local name.+parseAllChildrenWithLocalName :: Text -> Parser a -> Parser [a]+parseAllChildrenWithLocalName n parser = do+ ctx <- ask+ mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx))++-- | Parse all introspectable children with the given namespace and+-- local name.+parseChildrenWithNSName :: GIRXMLNamespace -> Text -> Parser a -> Parser [a]+parseChildrenWithNSName ns n parser = do+ ctx <- ask+ let introspectableChildren = filter introspectable+ (childElemsWithNSName ns n (currentElement ctx))+ mapM (withElement parser) introspectableChildren+ where introspectable :: Element -> Bool+ introspectable e = lookupAttr "introspectable" e /= Just "0"++-- | Run the given parser for a given subelement in the XML tree.+withElement :: Parser a -> Element -> Parser a+withElement parser element = local modifyParsePosition parser+ where modifyParsePosition ctx =+ ctx { treePosition = elementDescription element : treePosition ctx+ , currentElement = element}++-- | Run the given parser, returning either success or an error.+runParser :: Text -> M.Map Alias Type -> Element -> Parser a ->+ Either ParseError a+runParser ns aliases element parser =+ runExcept (runReaderT parser ctx)+ where ctx = ParseContext {+ ctxNamespace = ns+ , treePosition = [elementDescription element]+ , currentElement = element+ , knownAliases = aliases+ }
+ lib/Data/GI/GIR/Property.hs view
@@ -0,0 +1,54 @@+module Data.GI.GIR.Property+ ( Property(..)+ , PropertyFlag(..)+ , parseProperty+ ) where++import Data.Text (Text)+import Data.Monoid ((<>))++import Data.GI.GIR.Arg (parseTransfer)+import Data.GI.GIR.BasicTypes (Transfer, Type)+import Data.GI.GIR.Parser+import Data.GI.GIR.Type (parseType)++data PropertyFlag = PropertyReadable+ | PropertyWritable+ | PropertyConstruct+ | PropertyConstructOnly+ deriving (Show,Eq)++data Property = Property {+ propName :: Text,+ propType :: Type,+ propFlags :: [PropertyFlag],+ propReadNullable :: Maybe Bool,+ propWriteNullable :: Maybe Bool,+ propTransfer :: Transfer,+ propDeprecated :: Maybe DeprecationInfo+ } deriving (Show, Eq)++parseProperty :: Parser Property+parseProperty = do+ name <- getAttr "name"+ t <- parseType+ transfer <- parseTransfer+ deprecated <- parseDeprecation+ readable <- optionalAttr "readable" True parseBool+ writable <- optionalAttr "writable" False parseBool+ construct <- optionalAttr "construct" False parseBool+ constructOnly <- optionalAttr "construct-only" False parseBool+ let flags = (if readable then [PropertyReadable] else [])+ <> (if writable then [PropertyWritable] else [])+ <> (if construct then [PropertyConstruct] else [])+ <> (if constructOnly then [PropertyConstructOnly] else [])+ return $ Property {+ propName = name+ , propType = t+ , propFlags = flags+ , propTransfer = transfer+ , propDeprecated = deprecated+ -- No support in the GIR for nullability info+ , propReadNullable = Nothing+ , propWriteNullable = Nothing+ }
+ lib/Data/GI/GIR/Repository.hs view
@@ -0,0 +1,87 @@+module Data.GI.GIR.Repository (readGiRepository) where++import Prelude hiding (readFile)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Monad (when)+import Data.Maybe+import qualified Data.List as List+import qualified Data.Text as T+import Data.Text (Text)+import Safe (maximumMay)+import qualified Text.XML as XML++import System.Directory+import System.Environment (lookupEnv)+import System.Environment.XDG.BaseDir (getSystemDataDirs)+import System.FilePath++girDataDirs :: IO [FilePath]+girDataDirs = getSystemDataDirs "gir-1.0"++girFilePath :: String -> String -> FilePath -> FilePath+girFilePath name version path = path </> name ++ "-" ++ version <.> "gir"++girFile' :: Text -> Maybe Text -> FilePath -> IO (Maybe FilePath)+girFile' name (Just version) path =+ let filePath = girFilePath (T.unpack name) (T.unpack version) path+ in doesFileExist filePath >>= \case+ True -> return $ Just filePath+ False -> return Nothing+girFile' name Nothing path =+ doesDirectoryExist path >>= \case+ True -> do+ repositories <- map takeBaseName <$> getDirectoryContents path+ let version = maximumMay . catMaybes $+ List.stripPrefix (T.unpack name ++ "-") <$> repositories++ return $ case version of+ Just v -> Just $ girFilePath (T.unpack name) v path+ Nothing -> Nothing++ False -> return Nothing++-- | Split a list into sublists delimited by the given element.+splitOn :: Eq a => a -> [a] -> [[a]]+splitOn x xs = go xs []+ where go [] acc = [reverse acc]+ go (y : ys) acc = if x == y+ then reverse acc : go ys []+ else go ys (y : acc)++-- | Search for an appropriate @.gir@ file in the search path. This is+-- either passed in explicitly, or if that is absent, loaded from the+-- environment variable @HASKELL_GI_GIR_SEARCH_PATH@. In either case+-- the system data dirs are also searched if nothing can be found in+-- the explicitly passed paths, or in the contents of+-- @HASKELL_GI_GIR_SEARCH_PATH@.+girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath)+girFile name version extraPaths = do+ paths <- case extraPaths of+ [] -> lookupEnv "HASKELL_GI_GIR_SEARCH_PATH" >>= \case+ Nothing -> return []+ Just s -> return (splitOn ':' s)+ ps -> return ps+ dataDirs <- girDataDirs+ firstJust <$> (mapM (girFile' name version) (paths ++ dataDirs))+ where firstJust = listToMaybe . catMaybes++-- | Try to load the `.gir` file corresponding to the given repository+readGiRepository :: Bool -- ^ verbose+ -> Text -- ^ name+ -> Maybe Text -- ^ version+ -> [FilePath] -- ^ searchPath+ -> IO XML.Document+readGiRepository verbose name version extraPaths =+ girFile name version extraPaths >>= \case+ Just path -> do+ when verbose $ putStrLn $ "Loading GI repository: " ++ path+ XML.readFile XML.def path+ Nothing -> do+ dataDirs <- girDataDirs+ error $ "Did not find a GI repository for " ++ (T.unpack name)+ ++ maybe "" ("-" ++) (T.unpack <$> version)+ ++ " in " ++ show dataDirs
+ lib/Data/GI/GIR/Signal.hs view
@@ -0,0 +1,26 @@+module Data.GI.GIR.Signal+ ( Signal(..)+ , parseSignal+ ) where++import Data.Text (Text)++import Data.GI.GIR.Callable (Callable(..), parseCallable)+import Data.GI.GIR.Parser++data Signal = Signal {+ sigName :: Text,+ sigCallable :: Callable,+ sigDeprecated :: Maybe DeprecationInfo+ } deriving (Show, Eq)++parseSignal :: Parser Signal+parseSignal = do+ n <- getAttr "name"+ deprecated <- parseDeprecation+ callable <- parseCallable+ return $ Signal {+ sigName = n+ , sigCallable = callable+ , sigDeprecated = deprecated+ }
+ lib/Data/GI/GIR/Struct.hs view
@@ -0,0 +1,51 @@+-- | Parsing of structs.+module Data.GI.GIR.Struct+ ( Struct(..)+ , parseStruct+ ) where++import Data.Text (Text)++import Data.GI.GIR.Field (Field, parseFields)+import Data.GI.GIR.Method (Method, MethodType(..), parseMethod)+import Data.GI.GIR.Parser++data Struct = Struct {+ structIsBoxed :: Bool,+ structTypeInit :: Maybe Text,+ structSize :: Int,+ gtypeStructFor :: Maybe Name,+ -- https://bugzilla.gnome.org/show_bug.cgi?id=560248+ structIsDisguised :: Bool,+ structFields :: [Field],+ structMethods :: [Method],+ structDeprecated :: Maybe DeprecationInfo,+ structDocumentation :: Maybe Documentation }+ deriving Show++parseStruct :: Parser (Name, Struct)+parseStruct = do+ name <- parseName+ deprecated <- parseDeprecation+ doc <- parseDocumentation+ structFor <- queryAttrWithNamespace GLibGIRNS "is-gtype-struct-for" >>= \case+ Just t -> (fmap Just . qualifyName) t+ Nothing -> return Nothing+ typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+ disguised <- optionalAttr "disguised" False parseBool+ fields <- parseFields+ constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+ methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+ functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+ return (name,+ Struct {+ structIsBoxed = error ("[boxed] unfixed struct " ++ show name)+ , structTypeInit = typeInit+ , structSize = error ("[size] unfixed struct " ++ show name)+ , gtypeStructFor = structFor+ , structIsDisguised = disguised+ , structFields = fields+ , structMethods = constructors ++ methods ++ functions+ , structDeprecated = deprecated+ , structDocumentation = doc+ })
+ lib/Data/GI/GIR/Type.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}+-- | Parsing type information from GIR files.+module Data.GI.GIR.Type+ ( parseType+ , parseOptionalType+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Foreign.Storable (sizeOf)+import Foreign.C (CShort, CUShort, CSize)+import System.Posix.Types (CSsize)++import Data.GI.GIR.BasicTypes (Type(..), BasicType(..))+import Data.GI.GIR.Parser++-- | Map the given type name to a `BasicType` (defined in+-- Data.GI.GIR.BasicTypes), if possible.+nameToBasicType :: Text -> Maybe BasicType+nameToBasicType "gpointer" = Just TPtr+nameToBasicType "gboolean" = Just TBoolean+nameToBasicType "gchar" = Just TInt8+nameToBasicType "gint" = Just TInt+nameToBasicType "guint" = Just TUInt+nameToBasicType "glong" = Just TLong+nameToBasicType "gulong" = Just TULong+nameToBasicType "gint8" = Just TInt8+nameToBasicType "guint8" = Just TUInt8+nameToBasicType "gint16" = Just TInt16+nameToBasicType "guint16" = Just TUInt16+nameToBasicType "gint32" = Just TInt32+nameToBasicType "guint32" = Just TUInt32+nameToBasicType "gint64" = Just TInt64+nameToBasicType "guint64" = Just TUInt64+nameToBasicType "gfloat" = Just TFloat+nameToBasicType "gdouble" = Just TDouble+nameToBasicType "gunichar" = Just TUniChar+nameToBasicType "GType" = Just TGType+nameToBasicType "utf8" = Just TUTF8+nameToBasicType "filename" = Just TFileName+nameToBasicType "gintptr" = Just TIntPtr+nameToBasicType "guintptr" = Just TUIntPtr+nameToBasicType "gshort" = case sizeOf (0 :: CShort) of+ 2 -> Just TInt16+ 4 -> Just TInt32+ 8 -> Just TInt64+ n -> error $ "Unexpected short size: " ++ show n+nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of+ 2 -> Just TUInt16+ 4 -> Just TUInt32+ 8 -> Just TUInt64+ n -> error $ "Unexpected ushort size: " ++ show n+nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of+ 4 -> Just TInt32+ 8 -> Just TInt64+ n -> error $ "Unexpected ssize length: " ++ show n+nameToBasicType "gsize" = case sizeOf (0 :: CSize) of+ 4 -> Just TUInt32+ 8 -> Just TUInt64+ n -> error $ "Unexpected size length: " ++ show n+nameToBasicType _ = Nothing++-- | The different array types.+parseArrayInfo :: Parser Type+parseArrayInfo = queryAttr "name" >>= \case+ Just "GLib.Array" -> TGArray <$> parseType+ Just "GLib.PtrArray" -> TPtrArray <$> parseType+ Just "GLib.ByteArray" -> return TByteArray+ Just other -> parseError $ "Unsupported array type: \"" <> other <> "\""+ Nothing -> parseCArrayType++-- | A C array+parseCArrayType :: Parser Type+parseCArrayType = do+ zeroTerminated <- queryAttr "zero-terminated" >>= \case+ Just b -> parseBool b+ Nothing -> return True+ length <- queryAttr "length" >>= \case+ Just l -> parseIntegral l+ Nothing -> return (-1)+ fixedSize <- queryAttr "fixed-size" >>= \case+ Just s -> parseIntegral s+ Nothing -> return (-1)+ elementType <- parseType+ return $ TCArray zeroTerminated fixedSize length elementType++-- | A hash table.+parseHashTable :: Parser Type+parseHashTable = parseTypeElements >>= \case+ [Just key, Just value] -> return $ TGHash key value+ other -> parseError $ "Unsupported hash type: "+ <> T.pack (show other)++-- | For GLists and GSLists there is sometimes no information about+-- the type of the elements. In these cases we report them as+-- pointers.+parseListType :: Parser Type+parseListType = queryType >>= \case+ Just t -> return t+ Nothing -> return (TBasicType TPtr)++-- | A type which is not a BasicType or array.+parseFundamentalType :: Text -> Text -> Parser Type+parseFundamentalType "GLib" "List" = TGList <$> parseListType+parseFundamentalType "GLib" "SList" = TGSList <$> parseListType+parseFundamentalType "GLib" "HashTable" = parseHashTable+parseFundamentalType "GLib" "Error" = return TError+parseFundamentalType "GLib" "Variant" = return TVariant+parseFundamentalType "GObject" "ParamSpec" = return TParamSpec+-- A TInterface type (basically, everything that is not of a known type).+parseFundamentalType ns n = resolveQualifiedTypeName ns n++-- | Parse information on a "type" element. Returns either a `Type`,+-- or `Nothing` indicating that the name of the type in the+-- introspection data was "none" (associated with @void@ in C).+parseTypeInfo :: Parser (Maybe Type)+parseTypeInfo = do+ typeName <- getAttr "name"+ if typeName == "none"+ then return Nothing+ else Just <$> case nameToBasicType typeName of+ Just b -> return (TBasicType b)+ Nothing -> case T.split ('.' ==) typeName of+ [ns, n] -> parseFundamentalType ns n+ [n] -> do+ ns <- currentNamespace+ parseFundamentalType ns n+ _ -> parseError $ "Unsupported type form: \""+ <> typeName <> "\""++-- | Find the children giving the type of the given element.+parseTypeElements :: Parser [Maybe Type]+parseTypeElements = do+ types <- parseChildrenWithLocalName "type" parseTypeInfo+ arrays <- parseChildrenWithLocalName "array" parseArrayInfo+ return (types ++ map Just arrays)++-- | Try to find a type node, but do not error out if it is not+-- found. This _does_ give an error if more than one type node is+-- found, or if the type name is "none".+queryType :: Parser (Maybe Type)+queryType = parseTypeElements >>= \case+ [Just e] -> return (Just e)+ [] -> return Nothing+ [Nothing] -> parseError $ "Unexpected \"none\" type."+ _ -> parseError $ "Found more than one type for the element."++-- | Parse the type of a node (which will be described by a child node+-- named "type" or "array").+parseType :: Parser Type+parseType = parseTypeElements >>= \case+ [Just e] -> return e+ [] -> parseError $ "Did not find a type for the element."+ [Nothing] -> parseError $ "Unexpected \"none\" type."+ _ -> parseError $ "Found more than one type for the element."++-- | Like `parseType`, but allow for @none@, returned as `Nothing`.+parseOptionalType :: Parser (Maybe Type)+parseOptionalType =+ parseTypeElements >>= \case+ [e] -> return e+ [] -> parseError $ "Did not find a type for the element."+ _ -> parseError $ "Found more than one type for the element."
+ lib/Data/GI/GIR/Union.hs view
@@ -0,0 +1,41 @@+-- | Parsing of unions.+module Data.GI.GIR.Union+ ( Union(..)+ , parseUnion+ ) where++import Data.Maybe (isJust)+import Data.Text (Text)++import Data.GI.GIR.Field (Field, parseFields)+import Data.GI.GIR.Method (Method, MethodType(..), parseMethod)+import Data.GI.GIR.Parser++data Union = Union {+ unionIsBoxed :: Bool,+ unionSize :: Int,+ unionTypeInit :: Maybe Text,+ unionFields :: [Field],+ unionMethods :: [Method],+ unionDeprecated :: Maybe DeprecationInfo }+ deriving Show++parseUnion :: Parser (Name, Union)+parseUnion = do+ name <- parseName+ deprecated <- parseDeprecation+ typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"+ fields <- parseFields+ constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)+ methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)+ functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)+ return (name,+ Union {+ unionIsBoxed = isJust typeInit+ , unionTypeInit = typeInit+ , unionSize = error ("unfixed union size " ++ show name)+ , unionFields = fields+ , unionMethods = constructors ++ methods ++ functions+ , unionDeprecated = deprecated+ })+
+ lib/Data/GI/GIR/XMLUtils.hs view
@@ -0,0 +1,94 @@+-- | Some helpers for making traversals of GIR documents easier.+module Data.GI.GIR.XMLUtils+ ( nodeToElement+ , subelements+ , localName+ , lookupAttr+ , GIRXMLNamespace(..)+ , lookupAttrWithNamespace+ , childElemsWithLocalName+ , childElemsWithNSName+ , firstChildWithLocalName+ , getElementContent+ , xmlLocalName+ , xmlNSName+ ) where++import Text.XML (Element(elementNodes, elementName, elementAttributes),+ Node(NodeContent, NodeElement), nameLocalName, Name(..))+import Data.Maybe (mapMaybe, listToMaybe)+import qualified Data.Map as M+import Data.Text (Text)++-- | Turn a node into an element (if it is indeed an element node).+nodeToElement :: Node -> Maybe Element+nodeToElement (NodeElement e) = Just e+nodeToElement _ = Nothing++-- | Find all children of the given element which are XML Elements+-- themselves.+subelements :: Element -> [Element]+subelements = mapMaybe nodeToElement . elementNodes++-- | The local name of an element.+localName :: Element -> Text+localName = nameLocalName . elementName++-- | Restrict to those with the given local name.+childElemsWithLocalName :: Text -> Element -> [Element]+childElemsWithLocalName n =+ filter localNameMatch . subelements+ where localNameMatch = (== n) . localName++-- | Restrict to those with given name.+childElemsWithNSName :: GIRXMLNamespace -> Text -> Element -> [Element]+childElemsWithNSName ns n = filter nameMatch . subelements+ where nameMatch = (== name) . elementName+ name = Name {+ nameLocalName = n+ , nameNamespace = Just (girNamespace ns)+ , namePrefix = Nothing+ }++-- | Find the first child element with the given name.+firstChildWithLocalName :: Text -> Element -> Maybe Element+firstChildWithLocalName n = listToMaybe . childElemsWithLocalName n++-- | Get the content of a given element, if it exists.+getElementContent :: Element -> Maybe Text+getElementContent = listToMaybe . mapMaybe getContent . elementNodes+ where getContent :: Node -> Maybe Text+ getContent (NodeContent t) = Just t+ getContent _ = Nothing++-- | Lookup an attribute for an element (with no prefix).+lookupAttr :: Name -> Element -> Maybe Text+lookupAttr attr element = M.lookup attr (elementAttributes element)++-- | GIR namespaces we know about.+data GIRXMLNamespace = GLibGIRNS | CGIRNS+ deriving Show++-- | Return the text representation of the known GIR namespaces.+girNamespace :: GIRXMLNamespace -> Text+girNamespace GLibGIRNS = "http://www.gtk.org/introspection/glib/1.0"+girNamespace CGIRNS = "http://www.gtk.org/introspection/c/1.0"++-- | Lookup an attribute for an element, given the namespace where it lives.+lookupAttrWithNamespace :: GIRXMLNamespace -> Name -> Element -> Maybe Text+lookupAttrWithNamespace ns attr element =+ let attr' = attr {nameNamespace = Just (girNamespace ns)}+ in M.lookup attr' (elementAttributes element)+++-- | Construct a `Text.XML.Name` by only giving the local name.+xmlLocalName :: Text -> Name+xmlLocalName n = Name { nameLocalName = n+ , nameNamespace = Nothing+ , namePrefix = Nothing }++-- | Construct a `Text.XML.Name` specifying a namespace too.+xmlNSName :: GIRXMLNamespace -> Text -> Name+xmlNSName ns n = Name { nameLocalName = n+ , nameNamespace = Just (girNamespace ns)+ , namePrefix = Nothing }
+ lib/c/enumStorage.c view
@@ -0,0 +1,122 @@+/*+ Compute the number of bytes required for storage of a given enum,+ assuming that the current compiler gives the same result as the+ compiler used for compiling the library being introspected.++ Adapted from girepository/giroffsets.c, in the gobject-introspection+ distribution. Original copyright below.+*/++/* -*- mode: C; c-file-style: "gnu"; indent-tabs-mode: nil; -*-+ * GObject introspection: Compute structure offsets+ *+ * Copyright (C) 2008 Red Hat, Inc.+ *+ * This library is free software; you can redistribute it and/or+ * modify it under the terms of the GNU Lesser General Public+ * License as published by the Free Software Foundation; either+ * version 2 of the License, or (at your option) any later version.+ *+ * This library is distributed in the hope that it will be useful,+ * but WITHOUT ANY WARRANTY; without even the implied warranty of+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ * Lesser General Public License for more details.+ *+ * You should have received a copy of the GNU Lesser General Public+ * License along with this library; if not, write to the+ * Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ * Boston, MA 02111-1307, USA.+ */++/* The C standard specifies that an enumeration can be any char or any signed+ * or unsigned integer type capable of representing all the values of the+ * enumeration. We use test enumerations to figure out what choices the+ * compiler makes. (Ignoring > 32 bit enumerations)+ */++#include <glib.h>++typedef enum {+ ENUM_1 = 1 /* compiler could use int8, uint8, int16, uint16, int32, uint32 */+} Enum1;++typedef enum {+ ENUM_2 = 128 /* compiler could use uint8, int16, uint16, int32, uint32 */+} Enum2;++typedef enum {+ ENUM_3 = 257 /* compiler could use int16, uint16, int32, uint32 */+} Enum3;++typedef enum {+ ENUM_4 = G_MAXSHORT + 1 /* compiler could use uint16, int32, uint32 */+} Enum4;++typedef enum {+ ENUM_5 = G_MAXUSHORT + 1 /* compiler could use int32, uint32 */+} Enum5;++typedef enum {+ ENUM_6 = ((guint)G_MAXINT) + 1 /* compiler could use uint32 */+} Enum6;++typedef enum {+ ENUM_7 = -1 /* compiler could use int8, int16, int32 */+} Enum7;++typedef enum {+ ENUM_8 = -129 /* compiler could use int16, int32 */+} Enum8;++typedef enum {+ ENUM_9 = G_MINSHORT - 1 /* compiler could use int32 */+} Enum9;++int+_gi_get_enum_storage_bytes (gint64 min_value, gint64 max_value)+{+ int width;++ if (min_value < 0)+ {+ if (min_value > -128 && max_value <= 127)+ width = sizeof(Enum7);+ else if (min_value >= G_MINSHORT && max_value <= G_MAXSHORT)+ width = sizeof(Enum8);+ else+ width = sizeof(Enum9);+ }+ else+ {+ if (max_value <= 127)+ {+ width = sizeof (Enum1);+ }+ else if (max_value <= 255)+ {+ width = sizeof (Enum2);+ }+ else if (max_value <= G_MAXSHORT)+ {+ width = sizeof (Enum3);+ }+ else if (max_value <= G_MAXUSHORT)+ {+ width = sizeof (Enum4);+ }+ else if (max_value <= G_MAXINT)+ {+ width = sizeof (Enum5);+ }+ else+ {+ width = sizeof (Enum6);+ }+ }++ if (width == 1 || width == 2 || width == 4 || width == 8) {+ return width;+ } else {+ g_error("Unexpected enum width %d", width);+ }+}
− src/GI/API.hs
@@ -1,398 +0,0 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}--module GI.API- ( API(..)- , GIRInfo(..)- , loadGIRInfo- , loadRawGIRInfo-- -- Reexported from GI.GIR.BasicTypes- , Name(..)- , Transfer(..)-- -- Reexported from GI.GIR.Arg- , Direction(..)- , Scope(..)-- -- Reexported from GI.GIR.Deprecation- , deprecatedPragma- , DeprecationInfo-- -- Reexported from GI.GIR.Property- , PropertyFlag(..)-- -- Reexported from GI.GIR.Method- , MethodType(..)-- -- Reexported from the corresponding GI.GIR modules- , Constant(..)- , Arg(..)- , Callable(..)- , Function(..)- , Signal(..)- , Property(..)- , Field(..)- , Struct(..)- , Callback(..)- , Interface(..)- , Method(..)- , Object(..)- , Enumeration(..)- , Flags (..)- , Union (..)- ) where--import Control.Monad ((>=>), forM, forM_)-import qualified Data.List as L-import qualified Data.Map as M-import Data.Maybe (mapMaybe, catMaybes)-import Data.Monoid ((<>))-import qualified Data.Set as S-import qualified Data.Text as T-import Data.Text (Text)--import Foreign.Ptr (Ptr)-import Foreign (peek)-import Foreign.C.Types (CUInt)--import Text.XML hiding (Name)--import GI.GIR.Alias (documentListAliases)-import GI.GIR.Arg (Arg(..), Direction(..), Scope(..))-import GI.GIR.BasicTypes (Alias, Name(..), Transfer(..))-import GI.GIR.Callable (Callable(..))-import GI.GIR.Callback (Callback(..), parseCallback)-import GI.GIR.Constant (Constant(..), parseConstant)-import GI.GIR.Deprecation (DeprecationInfo, deprecatedPragma)-import GI.GIR.Enum (Enumeration(..), parseEnum)-import GI.GIR.Field (Field(..))-import GI.GIR.Flags (Flags(..), parseFlags)-import GI.GIR.Function (Function(..), parseFunction)-import GI.GIR.Interface (Interface(..), parseInterface)-import GI.GIR.Method (Method(..), MethodType(..))-import GI.GIR.Object (Object(..), parseObject)-import GI.GIR.Parser (Parser, runParser)-import GI.GIR.Property (Property(..), PropertyFlag(..))-import GI.GIR.Repository (readGiRepository)-import GI.GIR.Signal (Signal(..))-import GI.GIR.Struct (Struct(..), parseStruct)-import GI.GIR.Union (Union(..), parseUnion)-import GI.GIR.XMLUtils (subelements, childElemsWithLocalName, lookupAttr,- lookupAttrWithNamespace, GIRXMLNamespace(..))--import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength)-import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName)-import Data.GI.Base.Utils (allocMem, freeMem)-import GI.LibGIRepository (girRequire, girStructSizeAndOffsets,- girUnionSizeAndOffsets, girLoadGType)-import GI.GType (gtypeIsBoxed)-import GI.Type (Type)--data GIRInfo = GIRInfo {- girPCPackages :: [Text],- girNSName :: Text,- girNSVersion :: Text,- girAPIs :: [(Name, API)],- girCTypes :: M.Map Text Name- } deriving Show--data GIRNamespace = GIRNamespace {- nsName :: Text,- nsVersion :: Text,- nsAPIs :: [(Name, API)],- nsCTypes :: [(Text, Name)]- } deriving (Show)--data GIRInfoParse = GIRInfoParse {- girIPPackage :: [Maybe Text],- girIPIncludes :: [Maybe (Text, Text)],- girIPNamespaces :: [Maybe GIRNamespace]-} deriving (Show)--data API- = APIConst Constant- | APIFunction Function- | APICallback Callback- | APIEnum Enumeration- | APIFlags Flags- | APIInterface Interface- | APIObject Object- | APIStruct Struct- | APIUnion Union- deriving Show--parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API)- -> Parser (Name, a) -> (Name, API)-parseAPI ns aliases element wrapper parser =- case runParser ns aliases element parser of- Left err -> error $ "Parse error: " ++ T.unpack err- Right (n, a) -> (n, wrapper a)--parseNSElement :: M.Map Alias Type -> GIRNamespace -> Element -> GIRNamespace-parseNSElement aliases ns@GIRNamespace{..} element- | lookupAttr "introspectable" element == Just "0" = ns- | otherwise =- case nameLocalName (elementName element) of- "alias" -> ns -- Processed separately- "constant" -> parse APIConst parseConstant- "enumeration" -> parse APIEnum parseEnum- "bitfield" -> parse APIFlags parseFlags- "function" -> parse APIFunction parseFunction- "callback" -> parse APICallback parseCallback- "record" -> parse APIStruct parseStruct- "union" -> parse APIUnion parseUnion- "class" -> parse APIObject parseObject- "interface" -> parse APIInterface parseInterface- "boxed" -> ns -- Unsupported- n -> error . T.unpack $ "Unknown GIR element \"" <> n <> "\" when processing namespace \"" <> nsName <> "\", aborting."- where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace- parse wrapper parser =- let (n, api) = parseAPI nsName aliases element wrapper parser- maybeCType = lookupAttrWithNamespace CGIRNS "type" element- in ns { nsAPIs = (n, api) : nsAPIs,- nsCTypes = case maybeCType of- Just ctype -> (ctype, n) : nsCTypes- Nothing -> nsCTypes- }--parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace-parseNamespace element aliases = do- let attrs = elementAttributes element- name <- M.lookup "name" attrs- version <- M.lookup "version" attrs- let ns = GIRNamespace {- nsName = name,- nsVersion = version,- nsAPIs = [],- nsCTypes = []- }- return (L.foldl' (parseNSElement aliases) ns (subelements element))--parseInclude :: Element -> Maybe (Text, Text)-parseInclude element = do- name <- M.lookup "name" attrs- version <- M.lookup "version" attrs- return (name, version)- where attrs = elementAttributes element--parsePackage :: Element -> Maybe Text-parsePackage element = M.lookup "name" (elementAttributes element)--parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse-parseRootElement aliases info@GIRInfoParse{..} element =- case nameLocalName (elementName element) of- "include" -> info {girIPIncludes = parseInclude element : girIPIncludes}- "package" -> info {girIPPackage = parsePackage element : girIPPackage}- "namespace" -> info {girIPNamespaces = parseNamespace element aliases : girIPNamespaces}- _ -> info--emptyGIRInfoParse :: GIRInfoParse-emptyGIRInfoParse = GIRInfoParse {- girIPPackage = [],- girIPIncludes = [],- girIPNamespaces = []- }--parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse-parseGIRDocument aliases doc = L.foldl' (parseRootElement aliases) emptyGIRInfoParse (subelements (documentRoot doc))---- | Parse the list of includes in a given document.-documentListIncludes :: Document -> S.Set (Text, Text)-documentListIncludes doc = S.fromList (mapMaybe parseInclude includes)- where includes = childElemsWithLocalName "include" (documentRoot doc)---- | Load a set of dependencies, recursively.-loadDependencies :: Bool -- Verbose- -> S.Set (Text, Text) -- Requested- -> M.Map (Text, Text) Document -- Loaded so far- -> [FilePath] -- extra path to search- -> IO (M.Map (Text, Text) Document) -- New loaded set-loadDependencies verbose requested loaded extraPaths- | S.null requested = return loaded- | otherwise = do- let (name, version) = S.elemAt 0 requested- doc <- readGiRepository verbose name (Just version) extraPaths- let newLoaded = M.insert (name, version) doc loaded- loadedSet = S.fromList (M.keys newLoaded)- newRequested = S.union requested (documentListIncludes doc)- notYetLoaded = S.difference newRequested loadedSet- loadDependencies verbose notYetLoaded newLoaded extraPaths---- | Load a given GIR file and recursively its dependencies-loadGIRFile :: Bool -- ^ verbose- -> Text -- ^ name- -> Maybe Text -- ^ version- -> [FilePath] -- ^ extra paths to search- -> IO (Document, -- ^ loaded document- M.Map (Text, Text) Document) -- ^ dependencies-loadGIRFile verbose name version extraPaths = do- doc <- readGiRepository verbose name version extraPaths- deps <- loadDependencies verbose (documentListIncludes doc) M.empty extraPaths- return (doc, deps)---- | Turn a GIRInfoParse into a proper GIRInfo, doing some sanity--- checking along the way.-toGIRInfo :: GIRInfoParse -> Either Text GIRInfo-toGIRInfo info =- case catMaybes (girIPNamespaces info) of- [ns] -> Right GIRInfo {- girPCPackages = (reverse . catMaybes . girIPPackage) info- , girNSName = nsName ns- , girNSVersion = nsVersion ns- , girAPIs = reverse (nsAPIs ns)- , girCTypes = M.fromList (nsCTypes ns)- }- [] -> Left "Found no valid namespace."- _ -> Left "Found multiple namespaces."---- | Bare minimum loading and parsing of a single repository, without--- loading or parsing its dependencies, resolving aliases, or fixing--- up structs or interfaces.-loadRawGIRInfo :: Bool -- ^ verbose- -> Text -- ^ name- -> Maybe Text -- ^ version- -> [FilePath] -- ^ extra paths to search- -> IO GIRInfo -- ^ bare parsed document-loadRawGIRInfo verbose name version extraPaths = do- doc <- readGiRepository verbose name version extraPaths- case toGIRInfo (parseGIRDocument M.empty doc) of- Left err -> error . T.unpack $ "Error when raw parsing \"" <> name <> "\": " <> err- Right docGIR -> return docGIR---- | Load and parse a GIR file, including its dependencies.-loadGIRInfo :: Bool -- ^ verbose- -> Text -- ^ name- -> Maybe Text -- ^ version- -> [FilePath] -- ^ extra paths to search- -> IO (GIRInfo, -- ^ parsed document- [GIRInfo]) -- ^ parsed deps-loadGIRInfo verbose name version extraPaths = do- (doc, deps) <- loadGIRFile verbose name version extraPaths- let aliases = M.unions (map documentListAliases (doc : M.elems deps))- parsedDoc = toGIRInfo (parseGIRDocument aliases doc)- parsedDeps = map (toGIRInfo . parseGIRDocument aliases) (M.elems deps)- case combineErrors parsedDoc parsedDeps of- Left err -> error . T.unpack $ "Error when parsing \"" <> name <> "\": " <> err- Right (docGIR, depsGIR) -> do- if girNSName docGIR == name- then do- forM_ (docGIR : depsGIR) $ \info ->- girRequire (girNSName info) (girNSVersion info)- (fixedDoc, fixedDeps) <- fixupGIRInfos docGIR depsGIR- return (fixedDoc, fixedDeps)- else error . T.unpack $ "Got unexpected namespace \""- <> girNSName docGIR <> "\" when parsing \"" <> name <> "\"."- where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]- -> Either Text (GIRInfo, [GIRInfo])- combineErrors parsedDoc parsedDeps = do- doc <- parsedDoc- deps <- sequence parsedDeps- return (doc, deps)--foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType)---- | List the prerequisites for a 'GType' corresponding to an interface.-gtypeInterfaceListPrereqs :: GType -> IO [Text]-gtypeInterfaceListPrereqs (GType cgtype) = do- nprereqsPtr <- allocMem :: IO (Ptr CUInt)- ps <- g_type_interface_prerequisites cgtype nprereqsPtr- nprereqs <- peek nprereqsPtr- psCGTypes <- unpackStorableArrayWithLength nprereqs ps- freeMem ps- freeMem nprereqsPtr- mapM (fmap T.pack . gtypeName . GType) psCGTypes---- | The list of prerequisites in GIR files is not always--- accurate. Instead of relying on this, we instantiate the 'GType'--- associated to the interface, and listing the interfaces from there.-fixupInterface :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupInterface csymbolMap (n@(Name ns _), APIInterface iface) = do- prereqs <- case ifTypeInit iface of- Nothing -> return []- Just ti -> do- gtype <- girLoadGType ns ti- prereqGTypes <- gtypeInterfaceListPrereqs gtype- forM prereqGTypes $ \p -> do- case M.lookup p csymbolMap of- Just pn -> return pn- Nothing -> error $ "Could not find prerequisite type " ++ show p ++ " for interface " ++ show n- return (n, APIInterface (iface {ifPrerequisites = prereqs}))-fixupInterface _ (n, api) = return (n, api)---- | There is not enough info in the GIR files to determine whether a--- struct is boxed. We find out by instantiating the 'GType'--- corresponding to the struct (if known) and checking whether it--- descends from the boxed GType. Similarly, the size of the struct--- and offset of the fields is hard to compute from the GIR data, we--- simply reuse the machinery in libgirepository.-fixupStruct :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupStruct _ (n, APIStruct s) = do- fixed <- (fixupStructIsBoxed n >=> fixupStructSizeAndOffsets n) s- return (n, APIStruct fixed)-fixupStruct _ api = return api---- | Find out whether the struct is boxed.-fixupStructIsBoxed :: Name -> Struct -> IO Struct--- The type for "GVariant" is marked as "intern", we wrap--- this one natively.-fixupStructIsBoxed (Name "GLib" "Variant") s =- return (s {structIsBoxed = False})-fixupStructIsBoxed (Name ns _) s = do- isBoxed <- case structTypeInit s of- Nothing -> return False- Just ti -> do- gtype <- girLoadGType ns ti- return (gtypeIsBoxed gtype)- return (s {structIsBoxed = isBoxed})---- | Fix the size and alignment of fields. This is much easier to do--- by using libgirepository than reading the GIR file directly.-fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct-fixupStructSizeAndOffsets (Name ns n) s = do- (size, offsetMap) <- girStructSizeAndOffsets ns n- return (s { structSize = size- , structFields = map (fixupField offsetMap) (structFields s)})---- | Same thing for unions.-fixupUnion :: M.Map Text Name -> (Name, API) -> IO (Name, API)-fixupUnion _ (n, APIUnion u) = do- fixed <- (fixupUnionSizeAndOffsets n) u- return (n, APIUnion fixed)-fixupUnion _ api = return api---- | Like 'fixupStructSizeAndOffset' above.-fixupUnionSizeAndOffsets :: Name -> Union -> IO Union-fixupUnionSizeAndOffsets (Name ns n) u = do- (size, offsetMap) <- girUnionSizeAndOffsets ns n- return (u { unionSize = size- , unionFields = map (fixupField offsetMap) (unionFields u)})---- | Fixup the offsets of fields using the given offset map.-fixupField :: M.Map Text Int -> Field -> Field-fixupField offsetMap f =- f {fieldOffset = case M.lookup (fieldName f) offsetMap of- Nothing -> error $ "Could not find field "- ++ show (fieldName f)- Just o -> o }---- | Fixup parsed GIRInfos: some of the required information is not--- found in the GIR files themselves, but can be obtained by--- instantiating the required GTypes from the installed libraries.-fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])-fixupGIRInfos doc deps = (fixup fixupInterface >=>- fixup fixupStruct >=>- fixup fixupUnion) (doc, deps)- where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API))- -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])- fixup fixer (doc, deps) = do- fixedDoc <- fixAPIs fixer doc- fixedDeps <- mapM (fixAPIs fixer) deps- return (fixedDoc, fixedDeps)-- fixAPIs :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo- fixAPIs fixer info = do- fixedAPIs <- mapM (fixer ctypes) (girAPIs info)- return $ info {girAPIs = fixedAPIs}-- ctypes :: M.Map Text Name- ctypes = M.unions (map girCTypes (doc:deps))
− src/GI/Cabal.hs
@@ -1,184 +0,0 @@-module GI.Cabal- ( genCabalProject- , cabalConfig- , setupHs- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Monad (forM_)-import Control.Monad.IO.Class (liftIO)-import Data.Maybe (fromMaybe)-import Data.Version (Version(..))-import qualified Data.Map as M-import qualified Data.Text as T-import Data.Text (Text)-import Text.Read--import GI.API (GIRInfo(..))-import GI.Code-import GI.Config (Config(..))-import GI.Overrides (pkgConfigMap, cabalPkgVersion)-import GI.PkgConfig (pkgConfigGetVersion)-import GI.ProjectInfo (homepage, license, authors, maintainers)-import GI.Util (padTo, tshow)--import Paths_haskell_gi (version)--cabalConfig :: Text-cabalConfig = T.unlines ["optimization: False"]--setupHs :: Text-setupHs = T.unlines ["#!/usr/bin/env runhaskell",- "import Distribution.Simple",- "main = defaultMain"]--haskellGIAPIVersion :: Int-haskellGIAPIVersion = (head . versionBranch) version---- | Obtain the minor version. That is, if the given version numbers--- are x.y.z, so branch is [x,y,z], we return y.-minorVersion :: [Int] -> Int-minorVersion (_:y:_) = y-minorVersion v = error $ "Programming error: the haskell-gi version does not have at least two components: " ++ show v ++ "."---- | Obtain the haskell-gi minor version. Notice that we only append--- the minor version here, ignoring revisions. (So if the version is--- x.y.z, we drop the "z" part.) This gives us a mechanism for--- releasing bug-fix releases of haskell-gi without increasing the--- necessary dependency on haskell-gi-base, which only depends on x.y.-haskellGIMinor :: Int-haskellGIMinor = minorVersion (versionBranch version)--{- |--If the haskell-gi version is of the form x.y[.z] and the pkgconfig-version of the package being wrapped is a.b.c, this gives something of-the form x.a.b.y.--This strange seeming-rule is so that the packages that we produce-follow the PVP, assuming that the package being wrapped follows the-usual semantic versioning convention (http://semver.org) that-increases in "a" indicate non-backwards compatible changes, increases-in "b" backwards compatible additions to the API, and increases in "c"-denote API compatible changes (so we do not need to regenerate-bindings for these, at least in principle, so we do not encode them in-the cabal version).--In order to follow the PVP, then everything we need to do in the-haskell-gi side is to increase x everytime the generated API changes-(for a fixed a.b.c version).--In any case, if such "strange" package numbers are undesired, or the-wrapped package does not follow semver, it is possible to add an-explicit cabal-pkg-version override. This needs to be maintained by-hand (including in the list of dependencies of packages depending on-this one), so think carefully before using this override!---}-giModuleVersion :: Int -> Int -> Text-giModuleVersion major minor =- (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor,- haskellGIMinor]---- | Determine the next version for which the minor of the package has--- been bumped.-giNextMinor :: Int -> Int -> Text-giNextMinor major minor = (T.intercalate "." . map tshow)- [haskellGIAPIVersion, major, minor+1]---- | Determine the pkg-config name and installed version (major.minor--- only) for a given module, or throw an exception if that fails.-tryPkgConfig :: Text -> Text -> [Text] -> Bool- -> M.Map Text Text- -> ExcCodeGen (Text, Int, Int)-tryPkgConfig name version packages verbose overridenNames =- liftIO (pkgConfigGetVersion name version packages verbose overridenNames) >>= \case- Just (n,v) ->- case readMajorMinor v of- Just (major, minor) -> return (n, major, minor)- Nothing -> notImplementedError $- "Cannot parse version \""- <> v <> "\" for module " <> name- Nothing -> missingInfoError $- "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <>- "Try adding an override with the proper package name:\n"- <> "pkg-config-name " <> name <> " [matching pkg-config name here]"---- | Given a string a.b.c..., representing a version number, determine--- the major and minor versions, i.e. "a" and "b". If successful,--- return (a,b).-readMajorMinor :: Text -> Maybe (Int, Int)-readMajorMinor version =- case T.splitOn "." version of- (a:b:_) -> (,) <$> readMaybe (T.unpack a) <*> readMaybe (T.unpack b)- _ -> Nothing---- | Try to generate the cabal project. In case of error return the--- corresponding error string.-genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> BaseVersion ->- CodeGen (Maybe Text)-genCabalProject gir deps exposedModules minBaseVersion =- handleCGExc (return . Just . describeCGError) $ do- cfg <- config- let pkMap = pkgConfigMap (overrides cfg)- name = girNSName gir- pkgVersion = girNSVersion gir- packages = girPCPackages gir-- line $ "-- Autogenerated, do not edit."- line $ padTo 20 "name:" <> "gi-" <> T.toLower name- (pcName, major, minor) <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap- let cabalVersion = fromMaybe (giModuleVersion major minor)- (cabalPkgVersion $ overrides cfg)- line $ padTo 20 "version:" <> cabalVersion- line $ padTo 20 "synopsis:" <> name- <> " bindings"- line $ padTo 20 "description:" <> "Bindings for " <> name- <> ", autogenerated by haskell-gi."- line $ padTo 20 "homepage:" <> homepage- line $ padTo 20 "license:" <> license- line $ padTo 20 "license-file:" <> "LICENSE"- line $ padTo 20 "author:" <> authors- line $ padTo 20 "maintainer:" <> maintainers- line $ padTo 20 "category:" <> "Bindings"- line $ padTo 20 "build-type:" <> "Simple"- line $ padTo 20 "cabal-version:" <> ">=1.10"- blank- line $ "library"- indent $ do- line $ padTo 20 "default-language:" <> "Haskell2010"- line $ padTo 20 "default-extensions:" <> "ScopedTypeVariables, CPP, OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts"- line $ padTo 20 "other-extensions:" <> "PatternSynonyms ViewPatterns"- line $ padTo 20 "ghc-options:" <> "-fno-warn-unused-imports -fno-warn-warnings-deprecations"- line $ padTo 20 "exposed-modules:" <> head exposedModules- forM_ (tail exposedModules) $ \mod ->- line $ padTo 20 "" <> mod- line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= "- <> tshow major <> "." <> tshow minor- line $ padTo 20 "build-depends: base >= "- <> showBaseVersion minBaseVersion <> " && <5,"- indent $ do- line $ "haskell-gi-base >= "- <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor- <> " && < " <> tshow (haskellGIAPIVersion + 1) <> ","- forM_ deps $ \dep -> do- let depName = girNSName dep- depVersion = girNSVersion dep- depPackages = girPCPackages dep- (_, depMajor, depMinor) <- tryPkgConfig depName depVersion- depPackages (verbose cfg) pkMap- line $ "gi-" <> T.toLower depName <> " >= "- <> giModuleVersion depMajor depMinor- <> " && < "- <> giNextMinor depMajor depMinor- <> ","- -- Our usage of these is very basic, no reason to put any- -- strong upper bounds.- line "bytestring >= 0.10,"- line "containers >= 0.5,"- line "text >= 1.0,"- line "transformers >= 0.3"-- return Nothing -- successful generation, no error
− src/GI/Callable.hs
@@ -1,811 +0,0 @@-{-# LANGUAGE LambdaCase #-}-module GI.Callable- ( genCallable-- , hOutType- , arrayLengths- , arrayLengthsMap- , callableSignature- , fixupCallerAllocates-- , wrapMaybe- , inArgInterfaces- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (forM, forM_, when)-import Data.Bool (bool)-import Data.List (nub, (\\))-import Data.Maybe (isJust)-import Data.Tuple (swap)-import Data.Typeable (TypeRep, typeOf)-import qualified Data.Map as Map-import qualified Data.Text as T-import Data.Text (Text)--import GI.API-import GI.Code-import GI.Conversions-import GI.SymbolNaming-import GI.Transfer-import GI.Type-import GI.Util--import Text.Show.Pretty (ppShow)--hOutType :: Callable -> [Arg] -> Bool -> ExcCodeGen TypeRep-hOutType callable outArgs ignoreReturn = do- hReturnType <- case returnType callable of- TBasicType TVoid -> return $ typeOf ()- _ -> if ignoreReturn- then return $ typeOf ()- else haskellType $ returnType callable- hOutArgTypes <- forM outArgs $ \outarg ->- wrapMaybe outarg >>= bool- (haskellType (argType outarg))- (maybeT <$> haskellType (argType outarg))- let maybeHReturnType = if returnMayBeNull callable && not ignoreReturn- then maybeT hReturnType- else hReturnType- return $ case (outArgs, tshow maybeHReturnType) of- ([], _) -> maybeHReturnType- (_, "()") -> "(,)" `con` hOutArgTypes- _ -> "(,)" `con` (maybeHReturnType : hOutArgTypes)--mkForeignImport :: Text -> Callable -> Bool -> CodeGen ()-mkForeignImport symbol callable throwsGError = do- line first- indent $ do- mapM_ (\a -> line =<< fArgStr a) (args callable)- when throwsGError $- line $ padTo 40 "Ptr (Ptr GError) -> " <> "-- error"- line =<< last- where- first = "foreign import ccall \"" <> symbol <> "\" " <>- symbol <> " :: "- fArgStr arg = do- ft <- foreignType $ argType arg- weAlloc <- isJust <$> requiresAlloc (argType arg)- let ft' = if direction arg == DirectionIn || weAlloc- || argCallerAllocates arg- then- ft- else- ptr ft- let start = tshow ft' <> " -> "- return $ padTo 40 start <> "-- " <> (argCName arg)- <> " : " <> tshow (argType arg)- last = tshow <$> io <$> case returnType callable of- TBasicType TVoid -> return $ typeOf ()- _ -> foreignType (returnType callable)---- Given an argument to a function, return whether it should be--- wrapped in a maybe type (useful for nullable types). We do some--- sanity checking to make sure that the argument is actually nullable--- (a relatively common annotation mistake is to mix up (optional)--- with (nullable)).-wrapMaybe :: Arg -> ExcCodeGen Bool-wrapMaybe arg =- if mayBeNull arg- then case argType arg of- -- NULL GLists and GSLists are semantically the same as an- -- empty list, so they don't need a Maybe wrapper on their- -- type.- TGList _ -> return False- TGSList _ -> return False- _ -> do- nullable <- isNullable (argType arg)- if nullable- then return True- else badIntroError $ "argument \"" <> (argCName arg)- <> "\" is not of nullable type (" <> tshow (argType arg)- <> "), but it is marked as such."- else return False---- Given the list of arguments returns the list of constraints and the--- list of types in the signature.-inArgInterfaces :: [Arg] -> ExcCodeGen ([Text], [Text])-inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs- where- consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([Text], [Text])- consAndTypes _ [] = return ([], [])- consAndTypes letters (arg:args) = do- (ls, t, cons) <- argumentType letters $ argType arg- t' <- wrapMaybe arg >>= bool (return t)- (return $ "Maybe (" <> t <> ")")- (restCons, restTypes) <- consAndTypes ls args- return (cons <> restCons, t' : restTypes)---- Given a callable, return a list of (array, length) pairs, where in--- each pair "length" is the argument holding the length of the--- (non-zero-terminated, non-fixed size) C array.-arrayLengthsMap :: Callable -> [(Arg, Arg)] -- List of (array, length)-arrayLengthsMap callable = go (args callable) []- where- go :: [Arg] -> [(Arg, Arg)] -> [(Arg, Arg)]- go [] acc = acc- go (a:as) acc = case argType a of- TCArray False fixedSize length _ ->- if fixedSize > -1 || length == -1- then go as acc- else go as $ (a, (args callable)!!length) : acc- _ -> go as acc---- Return the list of arguments of the callable that contain length--- arguments, including a possible length for the result of calling--- the function.-arrayLengths :: Callable -> [Arg]-arrayLengths callable = map snd (arrayLengthsMap callable) <>- -- Often one of the arguments is just the length of- -- the result.- case returnType callable of- TCArray False (-1) length _ ->- if length > -1- then [(args callable)!!length]- else []- _ -> []---- This goes through a list of [(a,b)], and tags every entry where the--- "b" field has occurred before with the value of "a" for which it--- occurred. (The first appearance is not tagged.)-classifyDuplicates :: Ord b => [(a, b)] -> [(a, b, Maybe a)]-classifyDuplicates args = doClassify Map.empty args- where doClassify :: Ord b => Map.Map b a -> [(a, b)] -> [(a, b, Maybe a)]- doClassify _ [] = []- doClassify found ((value, key):args) =- (value, key, Map.lookup key found) :- doClassify (Map.insert key value found) args---- Read the length of in array arguments from the corresponding--- Haskell objects. A subtlety is that sometimes a single length--- argument is expected from the C side to encode the length of--- various lists. Ideally we would encode this in the types, but the--- resulting API would be rather cumbersome. We insted perform runtime--- checks to make sure that the given lists have the same length.-readInArrayLengths :: Name -> Callable -> [Arg] -> ExcCodeGen ()-readInArrayLengths name callable hInArgs = do- let lengthMaps = classifyDuplicates $ arrayLengthsMap callable- forM_ lengthMaps $ \(array, length, duplicate) ->- when (array `elem` hInArgs) $- case duplicate of- Nothing -> readInArrayLength array length- Just previous -> checkInArrayLength name array length previous---- Read the length of an array into the corresponding variable.-readInArrayLength :: Arg -> Arg -> ExcCodeGen ()-readInArrayLength array length = do- let lvar = escapedArgName length- avar = escapedArgName array- wrapMaybe array >>= bool- (do- al <- computeArrayLength avar (argType array)- line $ "let " <> lvar <> " = " <> al)- (do- line $ "let " <> lvar <> " = case " <> avar <> " of"- indent $ indent $ do- line $ "Nothing -> 0"- let jarray = "j" <> ucFirst avar- al <- computeArrayLength jarray (argType array)- line $ "Just " <> jarray <> " -> " <> al)---- Check that the given array has a length equal to the given length--- variable.-checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen ()-checkInArrayLength n array length previous = do- let name = lowerName n- funcName = namespace n <> "." <> name- lvar = escapedArgName length- avar = escapedArgName array- expectedLength = avar <> "_expected_length_"- pvar = escapedArgName previous- wrapMaybe array >>= bool- (do- al <- computeArrayLength avar (argType array)- line $ "let " <> expectedLength <> " = " <> al)- (do- line $ "let " <> expectedLength <> " = case " <> avar <> " of"- indent $ indent $ do- line $ "Nothing -> 0"- let jarray = "j" <> ucFirst avar- al <- computeArrayLength jarray (argType array)- line $ "Just " <> jarray <> " -> " <> al)- line $ "when (" <> expectedLength <> " /= " <> lvar <> ") $"- indent $ line $ "error \"" <> funcName <> " : length of '" <> avar <>- "' does not agree with that of '" <> pvar <> "'.\""---- Whether to skip the return value in the generated bindings. The--- C convention is that functions throwing an error and returning--- a gboolean set the boolean to TRUE iff there is no error, so--- the information is always implicit in whether we emit an--- exception or not, so the return value can be omitted from the--- generated bindings without loss of information (and omitting it--- gives rise to a nicer API). See--- https://bugzilla.gnome.org/show_bug.cgi?id=649657-skipRetVal :: Callable -> Bool -> Bool-skipRetVal callable throwsGError =- (skipReturn callable) ||- (throwsGError && returnType callable == TBasicType TBoolean)--freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text]) ->- Callable -> Map.Map Text Text -> ExcCodeGen [Text]-freeInArgs' freeFn callable nameMap = concat <$> actions- where- actions :: ExcCodeGen [[Text]]- actions = forM (args callable) $ \arg ->- case Map.lookup (escapedArgName arg) nameMap of- Just name -> freeFn arg name $- -- Pass in the length argument in case it's needed.- case argType arg of- TCArray False (-1) (-1) _ -> undefined- TCArray False (-1) length _ ->- escapedArgName $ (args callable)!!length- _ -> undefined- Nothing -> badIntroError $ "freeInArgs: do not understand " <> tshow arg---- Return the list of actions freeing the memory associated with the--- callable variables. This is run if the call to the C function--- succeeds, if there is an error freeInArgsOnError below is called--- instead.-freeInArgs = freeInArgs' freeInArg---- Return the list of actions freeing the memory associated with the--- callable variables. This is run in case there is an error during--- the call.-freeInArgsOnError = freeInArgs' freeInArgOnError---- Marshall the haskell arguments into their corresponding C--- equivalents. omitted gives a list of DirectionIn arguments that--- should be ignored, as they will be dealt with separately.-prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen Text-prepareArgForCall omitted arg = do- isCallback <- findAPI (argType arg) >>=- \case Just (APICallback _) -> return True- _ -> return False- when (isCallback && direction arg /= DirectionIn) $- notImplementedError "Only callbacks with DirectionIn are supported"-- case direction arg of- DirectionIn -> if arg `elem` omitted- then return . escapedArgName $ arg- else if isCallback- then prepareInCallback arg- else prepareInArg arg- DirectionInout -> prepareInoutArg arg- DirectionOut -> prepareOutArg arg--prepareInArg :: Arg -> ExcCodeGen Text-prepareInArg arg = do- let name = escapedArgName arg- wrapMaybe arg >>= bool- (convert name $ hToF (argType arg) (transfer arg))- (do- let maybeName = "maybe" <> ucFirst name- line $ maybeName <> " <- case " <> name <> " of"- indent $ do- line $ "Nothing -> return nullPtr"- let jName = "j" <> ucFirst name- line $ "Just " <> jName <> " -> do"- indent $ do- converted <- convert jName $ hToF (argType arg)- (transfer arg)- line $ "return " <> converted- return maybeName)---- Callbacks are a fairly special case, we treat them separately.-prepareInCallback :: Arg -> ExcCodeGen Text-prepareInCallback arg = do- let name = escapedArgName arg- ptrName = "ptr" <> name- scope = argScope arg-- (maker, wrapper) <- case argType arg of- (TInterface ns n) ->- do- prefix <- qualify ns- return $ (prefix <> "mk" <> n,- prefix <> lcFirst n <> "Wrapper")- _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg)-- when (scope == ScopeTypeAsync) $ do- ft <- tshow <$> foreignType (argType arg)- line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))"-- wrapMaybe arg >>= bool- (do- let name' = prime name- p = if (scope == ScopeTypeAsync)- then parenthesize $ "Just " <> ptrName- else "Nothing"- line $ name' <> " <- " <> maker <> " "- <> parenthesize (wrapper <> " " <> p <> " " <> name)- when (scope == ScopeTypeAsync) $- line $ "poke " <> ptrName <> " " <> name'- return name')- (do- let maybeName = "maybe" <> ucFirst name- line $ maybeName <> " <- case " <> name <> " of"- indent $ do- line $ "Nothing -> return (castPtrToFunPtr nullPtr)"- let jName = "j" <> ucFirst name- jName' = prime jName- line $ "Just " <> jName <> " -> do"- indent $ do- let p = if (scope == ScopeTypeAsync)- then parenthesize $ "Just " <> ptrName- else "Nothing"- line $ jName' <> " <- " <> maker <> " "- <> parenthesize (wrapper <> " "- <> p <> " " <> jName)- when (scope == ScopeTypeAsync) $- line $ "poke " <> ptrName <> " " <> jName'- line $ "return " <> jName'- return maybeName)--prepareInoutArg :: Arg -> ExcCodeGen Text-prepareInoutArg arg = do- name' <- prepareInArg arg- ft <- foreignType $ argType arg- allocInfo <- requiresAlloc (argType arg)- case allocInfo of- Just (isBoxed, n) -> do- let allocator = if isBoxed- then "callocBoxedBytes"- else "callocBytes"- wrapMaybe arg >>= bool- (do- name'' <- genConversion (prime name') $- literal $ M $ allocator <> " " <> tshow n <>- " :: " <> tshow (io ft)- line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n- return name'')- -- The semantics of this case are somewhat undefined.- (notImplementedError "Nullable inout structs not supported")- Nothing -> do- if argCallerAllocates arg- then return name'- else do- name'' <- genConversion (prime name') $- literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)- line $ "poke " <> name'' <> " " <> name'- return name''--prepareOutArg :: Arg -> CodeGen Text-prepareOutArg arg = do- let name = escapedArgName arg- ft <- foreignType $ argType arg- allocInfo <- requiresAlloc (argType arg)- case allocInfo of- Just (isBoxed, n) -> do- let allocator = if isBoxed- then "callocBoxedBytes"- else "callocBytes"- genConversion name $ literal $ M $ allocator <> " " <> tshow n <>- " :: " <> tshow (io ft)- Nothing ->- genConversion name $- literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)---- Convert a non-zero terminated out array, stored in a variable--- named "aname", into the corresponding Haskell object.-convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text ->- Transfer -> (Text -> Text) -> ExcCodeGen Text-convertOutCArray callable t@(TCArray False fixed length _) aname- nameMap transfer primeLength = do- if fixed > -1- then do- unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer- -- Free the memory associated with the array- freeContainerType transfer t aname undefined- return unpacked- else do- when (length == -1) $- badIntroError $ "Unknown length for \"" <> aname <> "\""- let lname = escapedArgName $ (args callable)!!length- lname' <- case Map.lookup lname nameMap of- Just n -> return n- Nothing ->- badIntroError $ "Couldn't find out array length " <>- lname- let lname'' = primeLength lname'- unpacked <- convert aname $ unpackCArray lname'' t transfer- -- Free the memory associated with the array- freeContainerType transfer t aname lname''- return unpacked---- Remove the warning, this should never be reached.-convertOutCArray _ t _ _ _ _ =- terror $ "convertOutCArray : unexpected " <> tshow t---- Read the array lengths for out arguments.-readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen ()-readOutArrayLengths callable nameMap = do- let lNames = nub $ map escapedArgName $- filter ((/= DirectionIn) . direction) $- arrayLengths callable- forM_ lNames $ \lname -> do- lname' <- case Map.lookup lname nameMap of- Just n -> return n- Nothing ->- badIntroError $ "Couldn't find out array length " <>- lname- genConversion lname' $ apply $ M "peek"---- Touch DirectionIn arguments so we are sure that they exist when the--- C function was called.-touchInArg :: Arg -> ExcCodeGen ()-touchInArg arg = when (direction arg /= DirectionOut) $ do- let name = escapedArgName arg- case elementType (argType arg) of- Just a -> do- managed <- isManaged a- when managed $ wrapMaybe arg >>= bool- (line $ "mapM_ touchManagedPtr " <> name)- (line $ "whenJust " <> name <> " (mapM_ touchManagedPtr)")- Nothing -> do- managed <- isManaged (argType arg)- when managed $ wrapMaybe arg >>= bool- (line $ "touchManagedPtr " <> name)- (line $ "whenJust " <> name <> " touchManagedPtr")---- Find the association between closure arguments and their--- corresponding callback.-closureToCallbackMap :: Callable -> ExcCodeGen (Map.Map Int Arg)-closureToCallbackMap callable =- -- The introspection info does not specify the closure for destroy- -- notify's associated with a callback, since it is implicitly the- -- same one as the ScopeTypeNotify callback associated with the- -- DestroyNotify.- go (filter (not . (`elem` destroyers)) $ args callable) Map.empty-- where destroyers = map (args callable!!) . filter (/= -1) . map argDestroy- $ args callable-- go :: [Arg] -> Map.Map Int Arg -> ExcCodeGen (Map.Map Int Arg)- go [] m = return m- go (arg:as) m =- if argScope arg == ScopeTypeInvalid- then go as m- else case argClosure arg of- (-1) -> go as m- c -> case Map.lookup c m of- Just _ -> notImplementedError $- "Closure for multiple callbacks unsupported"- <> T.pack (ppShow arg) <> "\n"- <> T.pack (ppShow callable)- Nothing -> go as $ Map.insert c arg m---- user_data style arguments.-prepareClosures :: Callable -> Map.Map Text Text -> ExcCodeGen ()-prepareClosures callable nameMap = do- m <- closureToCallbackMap callable- let closures = filter (/= -1) . map argClosure $ args callable- forM_ closures $ \closure ->- case Map.lookup closure m of- Nothing -> badIntroError $ "Closure not found! "- <> T.pack (ppShow callable)- <> "\n" <> T.pack (ppShow m)- <> "\n" <> tshow closure- Just cb -> do- let closureName = escapedArgName $ (args callable)!!closure- n = escapedArgName cb- n' <- case Map.lookup n nameMap of- Just n -> return n- Nothing -> badIntroError $ "Cannot find closure name!! "- <> T.pack (ppShow callable) <> "\n"- <> T.pack (ppShow nameMap)- case argScope cb of- ScopeTypeInvalid -> badIntroError $ "Invalid scope! "- <> T.pack (ppShow callable)- ScopeTypeNotified -> do- line $ "let " <> closureName <> " = castFunPtrToPtr " <> n'- case argDestroy cb of- (-1) -> badIntroError $- "ScopeTypeNotified without destructor! "- <> T.pack (ppShow callable)- k -> let destroyName =- escapedArgName $ (args callable)!!k in- line $ "let " <> destroyName <> " = safeFreeFunPtrPtr"- ScopeTypeAsync ->- line $ "let " <> closureName <> " = nullPtr"- ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr"--freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen ()-freeCallCallbacks callable nameMap =- forM_ (args callable) $ \arg -> do- let name = escapedArgName arg- name' <- case Map.lookup name nameMap of- Just n -> return n- Nothing -> badIntroError $ "Could not find " <> name- <> " in " <> T.pack (ppShow callable) <> "\n"- <> T.pack (ppShow nameMap)- when (argScope arg == ScopeTypeCall) $- line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name'--formatHSignature :: Callable -> Bool -> ExcCodeGen ()-formatHSignature callable throwsGError = do- (constraints, vars) <- callableSignature callable throwsGError- indent $ do- line $ "(" <> T.intercalate ", " constraints <> ") =>"- forM_ (zip ("" : repeat "-> ") vars) $ \(prefix, (t, name)) ->- line $ withComment (prefix <> t) name---- | The Haskell signature for the given callable. It returns a tuple--- ([constraints], [(type, argname)]).-callableSignature :: Callable -> Bool -> ExcCodeGen ([Text], [(Text, Text)])-callableSignature callable throwsGError = do- let (hInArgs, _) = callableHInArgs callable- (argConstraints, types) <- inArgInterfaces hInArgs- let constraints = ("MonadIO m" : argConstraints)- ignoreReturn = skipRetVal callable throwsGError- outType <- hOutType callable (callableHOutArgs callable) ignoreReturn- let allNames = map escapedArgName hInArgs ++ ["result"]- allTypes = types ++ [tshow ("m" `con` [outType])]- return (constraints, zip allTypes allNames)---- | "In" arguments for the given callable on the Haskell side,--- together with the omitted arguments.-callableHInArgs :: Callable -> ([Arg], [Arg])-callableHInArgs callable =- let inArgs = filter ((/= DirectionOut) . direction) $ args callable- -- We do not expose user_data arguments,- -- destroynotify arguments, and C array length- -- arguments to Haskell code.- closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs- destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs- omitted = arrayLengths callable <> closures <> destroyers- in (filter (`notElem` omitted) inArgs, omitted)---- | "Out" arguments for the given callable on the Haskell side.-callableHOutArgs :: Callable -> [Arg]-callableHOutArgs callable =- let outArgs = filter ((/= DirectionIn) . direction) $ args callable- in filter (`notElem` (arrayLengths callable)) outArgs---- | Convert the result of the foreign call to Haskell.-convertResult :: Callable -> Text -> Bool -> Map.Map Text Text ->- ExcCodeGen Text-convertResult callable symbol ignoreReturn nameMap =- if ignoreReturn || returnType callable == TBasicType TVoid- then return (error "convertResult: unreachable code reached, bug!")- else do- if returnMayBeNull callable- then do- line $ "maybeResult <- convertIfNonNull result $ \\result' -> do"- indent $ do- converted <- unwrappedConvertResult "result'"- line $ "return " <> converted- return "maybeResult"- else do- nullable <- isNullable (returnType callable)- when nullable $- line $ "checkUnexpectedReturnNULL \"" <> symbol- <> "\" result"- unwrappedConvertResult "result"-- where- unwrappedConvertResult rname =- case returnType callable of- -- Arrays without length information are just passed- -- along.- TCArray False (-1) (-1) _ -> return rname- -- Not zero-terminated C arrays require knowledge of the- -- length, so we deal with them directly.- t@(TCArray False _ _ _) ->- convertOutCArray callable t rname nameMap- (returnTransfer callable) prime- t -> do- result <- convert rname $ fToH (returnType callable)- (returnTransfer callable)- freeContainerType (returnTransfer callable) t rname undefined- return result---- | Marshal a foreign out argument to Haskell, returning the name of--- the variable containing the converted Haskell value.-convertOutArg :: Callable -> Map.Map Text Text -> Arg -> ExcCodeGen Text-convertOutArg callable nameMap arg = do- let name = escapedArgName arg- inName <- case Map.lookup name nameMap of- Just name' -> return name'- Nothing -> badIntroError $ "Parameter " <> name <> " not found!"- case argType arg of- -- Passed along as a raw pointer- TCArray False (-1) (-1) _ ->- if argCallerAllocates arg- then return inName- else genConversion inName $ apply $ M "peek"- t@(TCArray False _ _ _) -> do- aname' <- if argCallerAllocates arg- then return inName- else genConversion inName $ apply $ M "peek"- let arrayLength = if argCallerAllocates arg- then id- else prime- wrapArray a = convertOutCArray callable t a- nameMap (transfer arg) arrayLength- wrapMaybe arg >>= bool- (wrapArray aname')- (do line $ "maybe" <> ucFirst aname'- <> " <- convertIfNonNull " <> aname'- <> " $ \\" <> prime aname' <> " -> do"- indent $ do- wrapped <- wrapArray (prime aname')- line $ "return " <> wrapped- return $ "maybe" <> ucFirst aname')- t -> do- weAlloc <- isJust <$> requiresAlloc t- peeked <- if weAlloc || argCallerAllocates arg- then return inName- else genConversion inName $ apply $ M "peek"- -- If we alloc we always take control of the resulting- -- memory, otherwise we may leak.- let transfer' = if weAlloc || argCallerAllocates arg- then TransferEverything- else transfer arg- result <- do- let wrap ptr = convert ptr $ fToH (argType arg) transfer'- wrapMaybe arg >>= bool- (wrap peeked)- (do line $ "maybe" <> ucFirst peeked- <> " <- convertIfNonNull " <> peeked- <> " $ \\" <> prime peeked <> " -> do"- indent $ do- wrapped <- wrap (prime peeked)- line $ "return " <> wrapped- return $ "maybe" <> ucFirst peeked)- -- Free the memory associated with the out argument- freeContainerType transfer' t peeked undefined- return result---- | Convert the list of out arguments to Haskell, returning the--- names of the corresponding variables containing the marshaled values.-convertOutArgs :: Callable -> Map.Map Text Text -> [Arg] -> ExcCodeGen [Text]-convertOutArgs callable nameMap hOutArgs =- forM hOutArgs (convertOutArg callable nameMap)---- | Invoke the given C function, taking care of errors.-invokeCFunction :: Callable -> Text -> Bool -> Bool -> [Text] -> CodeGen ()-invokeCFunction callable symbol throwsGError ignoreReturn argNames = do- let returnBind = case returnType callable of- TBasicType TVoid -> ""- _ -> if ignoreReturn- then "_ <- "- else "result <- "- maybeCatchGErrors = if throwsGError- then "propagateGError $ "- else ""- line $ returnBind <> maybeCatchGErrors- <> symbol <> (T.concat . map (" " <>)) argNames---- | Return the result of the call, possibly including out arguments.-returnResult :: Callable -> Bool -> Text -> [Text] -> CodeGen ()-returnResult callable ignoreReturn result pps =- if ignoreReturn || returnType callable == TBasicType TVoid- then case pps of- [] -> line "return ()"- (pp:[]) -> line $ "return " <> pp- _ -> line $ "return (" <> T.intercalate ", " pps <> ")"- else case pps of- [] -> line $ "return " <> result- _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")"---- | Generate a Haskell wrapper for the given foreign function.-genHaskellWrapper :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()-genHaskellWrapper n symbol callable throwsGError = group $ do- let name = lowerName n- (hInArgs, omitted) = callableHInArgs callable- hOutArgs = callableHOutArgs callable- ignoreReturn = skipRetVal callable throwsGError-- line $ name <> " ::"- formatHSignature callable ignoreReturn- line $ name <> " " <> T.intercalate " " (map escapedArgName hInArgs) <> " = liftIO $ do"- indent (genWrapperBody n symbol callable throwsGError- ignoreReturn hInArgs hOutArgs omitted)---- | Generate the body of the Haskell wrapper for the given foreign symbol.-genWrapperBody :: Name -> Text -> Callable -> Bool ->- Bool -> [Arg] -> [Arg] -> [Arg] ->- ExcCodeGen ()-genWrapperBody n symbol callable throwsGError- ignoreReturn hInArgs hOutArgs omitted = do- readInArrayLengths n callable hInArgs- inArgNames <- forM (args callable) $ \arg ->- prepareArgForCall omitted arg- -- Map from argument names to names passed to the C function- let nameMap = Map.fromList $ flip zip inArgNames- $ map escapedArgName $ args callable- prepareClosures callable nameMap- if throwsGError- then do- line "onException (do"- indent $ do- invokeCFunction callable symbol throwsGError- ignoreReturn inArgNames- readOutArrayLengths callable nameMap- result <- convertResult callable symbol ignoreReturn nameMap- pps <- convertOutArgs callable nameMap hOutArgs- freeCallCallbacks callable nameMap- forM_ (args callable) touchInArg- mapM_ line =<< freeInArgs callable nameMap- returnResult callable ignoreReturn result pps- line " ) (do"- indent $ do- freeCallCallbacks callable nameMap- actions <- freeInArgsOnError callable nameMap- case actions of- [] -> line $ "return ()"- _ -> mapM_ line actions- line " )"- else do- invokeCFunction callable symbol throwsGError- ignoreReturn inArgNames- readOutArrayLengths callable nameMap- result <- convertResult callable symbol ignoreReturn nameMap- pps <- convertOutArgs callable nameMap hOutArgs- freeCallCallbacks callable nameMap- forM_ (args callable) touchInArg- mapM_ line =<< freeInArgs callable nameMap- returnResult callable ignoreReturn result pps---- | caller-allocates arguments are arguments that the caller--- allocates, and the called function modifies. They are marked as--- 'out' argumens in the introspection data, we treat them as 'inout'--- arguments instead. The semantics are somewhat tricky: for memory--- management purposes they should be treated as "in" arguments, but--- from the point of view of the exposed API they should be treated as--- "inout". Unfortunately we cannot always just assume that they are--- purely "out", so in many cases the generated API is somewhat--- suboptimal (since the initial values are not important): for--- example for g_io_channel_read_chars the size of the buffer to read--- is determined by the caller-allocates argument. As a compromise, we--- assume that we can allocate anything that is not a TCArray.-fixupCallerAllocates :: Callable -> Callable-fixupCallerAllocates c =- c{args = map (fixupLength . fixupArg . normalize) (args c)}- where fixupArg :: Arg -> Arg- fixupArg a = if argCallerAllocates a- then a {direction = DirectionInout}- else a-- lengthsMap :: Map.Map Arg Arg- lengthsMap = Map.fromList (map swap (arrayLengthsMap c))-- -- Length arguments of caller-allocates arguments should be- -- treated as "in".- fixupLength :: Arg -> Arg- fixupLength a = case Map.lookup a lengthsMap of- Nothing -> a- Just array ->- if argCallerAllocates array- then a {direction = DirectionIn}- else a-- -- We impose that out or inout arguments of non-array type- -- are never caller-allocates.- normalize :: Arg -> Arg- normalize (a@Arg{argType = TCArray _ _ _ _}) = a- normalize a = a {argCallerAllocates = False}--genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen ()-genCallable n symbol callable throwsGError = do- group $ do- line $ "-- Args : " <> (tshow $ args callable)- line $ "-- Lengths : " <> (tshow $ arrayLengths callable)- line $ "-- returnType : " <> (tshow $ returnType callable)- line $ "-- throws : " <> (tshow throwsGError)- line $ "-- Skip return : " <> (tshow $ skipReturn callable)- when (skipReturn callable && returnType callable /= TBasicType TBoolean) $- do line "-- XXX return value ignored, but it is not a boolean."- line "-- This may be a memory leak?"-- let callable' = fixupCallerAllocates callable-- mkForeignImport symbol callable' throwsGError-- blank-- line $ deprecatedPragma (lowerName n) (callableDeprecated callable)- exportMethod (lowerName n) (lowerName n)- genHaskellWrapper n symbol callable' throwsGError
− src/GI/Code.hs
@@ -1,789 +0,0 @@-module GI.Code- ( Code(..)- , ModuleInfo(..)- , ModuleFlag(..)- , BaseCodeGen- , CodeGen- , ExcCodeGen- , CGError(..)- , genCode- , evalCodeGen-- , writeModuleTree- , writeModuleCode- , codeToText- , transitiveModuleDeps- , minBaseVersion- , BaseVersion(..)- , showBaseVersion-- , loadDependency- , getDeps- , recurseWithAPIs-- , handleCGExc- , describeCGError- , notImplementedError- , badIntroError- , missingInfoError-- , indent- , bline- , line- , blank- , group- , hsBoot- , submodule- , setLanguagePragmas- , setGHCOptions- , setModuleFlags- , setModuleMinBase- , addModuleDocumentation-- , exportToplevel- , exportModule- , exportDecl- , exportMethod- , exportProperty- , exportSignal-- , findAPI- , findAPIByName- , getAPIs-- , config- , currentModule-- -- From Data.Monoid, for convenience- , (<>)- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-import Data.Monoid (Monoid(..))-#endif-import Control.Monad.Reader-import Control.Monad.State.Strict-import Control.Monad.Except-import qualified Data.Foldable as F-import Data.Maybe (fromMaybe, catMaybes)-import Data.Monoid ((<>))-import Data.Sequence (Seq, ViewL ((:<)), (><), (|>), (<|))-import qualified Data.Map.Strict as M-import qualified Data.Sequence as S-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as TIO--import System.Directory (createDirectoryIfMissing)-import System.FilePath (joinPath, takeDirectory)--import GI.API (API, Name(..))-import GI.Config (Config(..))-import GI.Type (Type(..))-import GI.Util (tshow, terror, ucFirst, padTo)-import GI.ProjectInfo (authors, license, maintainers)-import GI.GIR.Documentation (Documentation(..))--data Code- = NoCode -- ^ No code- | Line Text -- ^ A single line, indented to current indentation- | Indent Code -- ^ Indented region- | Sequence (Seq Code) -- ^ The basic sequence of code- | Group Code -- ^ A grouped set of lines- deriving (Eq, Show)--instance Monoid Code where- mempty = NoCode-- NoCode `mappend` NoCode = NoCode- x `mappend` NoCode = x- NoCode `mappend` x = x- (Sequence a) `mappend` (Sequence b) = Sequence (a >< b)- (Sequence a) `mappend` b = Sequence (a |> b)- a `mappend` (Sequence b) = Sequence (a <| b)- a `mappend` b = Sequence (a <| b <| S.empty)--type Deps = Set.Set Text-type ModuleName = [Text]---- | Subsection of the haddock documentation where the export should--- be located.-type HaddockSection = Text---- | Symbol to export.-type SymbolName = Text---- | Possible exports for a given module. Every export type--- constructor has two parameters: the section of the haddocks where--- it should appear, and the symbol name to export in the export list--- of the module.-data Export = Export {- exportType :: ExportType -- ^ Which kind of export.- , exportSymbol :: SymbolName -- ^ Actual symbol to export.- } deriving (Show, Eq, Ord)---- | Possible types of exports.-data ExportType = ExportTypeDecl -- ^ A type declaration.- | ExportToplevel -- ^ An export in no specific section.- | ExportMethod HaddockSection -- ^ A method for a struct/union, etc.- | ExportProperty HaddockSection -- ^ A property for an object/interface.- | ExportSignal HaddockSection -- ^ A signal for an object/interface.- | ExportModule -- ^ Reexport of a whole module.- deriving (Show, Eq, Ord)---- | Information on a generated module.-data ModuleInfo = ModuleInfo {- moduleName :: ModuleName -- ^ Full module name: ["GI", "Gtk", "Label"].- , moduleCode :: Code -- ^ Generated code for the module.- , bootCode :: Code -- ^ Interface going into the .hs-boot file.- , submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative- -- module name.- , moduleDeps :: Deps -- ^ Set of dependencies for this module.- , moduleExports :: Seq Export -- ^ Exports for the module.- , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.- , moduleGHCOpts :: Set.Set Text -- ^ GHC options for compiling the module.- , moduleFlags :: Set.Set ModuleFlag -- ^ Flags for the module.- , moduleDoc :: Maybe Text -- ^ Documentation for the module.- , moduleMinBase :: BaseVersion -- ^ Minimal version of base the- -- module will work on.- }---- | Flags for module code generation.-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.-data BaseVersion = Base47 -- ^ 4.7.0- | Base48 -- ^ 4.8.0- deriving (Show, Eq, Ord)---- | A `Text` representation of the given base version bound.-showBaseVersion :: BaseVersion -> Text-showBaseVersion Base47 = "4.7"-showBaseVersion Base48 = "4.8"---- | Generate the empty module.-emptyModule :: ModuleName -> ModuleInfo-emptyModule m = ModuleInfo { moduleName = m- , moduleCode = NoCode- , bootCode = NoCode- , submodules = M.empty- , moduleDeps = Set.empty- , moduleExports = S.empty- , modulePragmas = Set.empty- , moduleGHCOpts = Set.empty- , moduleFlags = Set.empty- , moduleDoc = Nothing- , moduleMinBase = Base47- }---- | Information for the code generator.-data CodeGenConfig = CodeGenConfig {- hConfig :: Config -- ^ Ambient config.- , loadedAPIs :: M.Map Name API -- ^ APIs available to the generator.- }--data CGError = CGErrorNotImplemented Text- | CGErrorBadIntrospectionInfo Text- | CGErrorMissingInfo Text- deriving (Show)--type BaseCodeGen excType a =- ReaderT CodeGenConfig (StateT ModuleInfo (ExceptT excType IO)) a---- | The code generator monad, for generators that cannot throw--- errors. The fact that they cannot throw errors is encoded in the--- forall, which disallows any operation on the error, except--- discarding it or passing it along without inspecting. This last--- operation is useful in order to allow embedding `CodeGen`--- computations inside `ExcCodeGen` computations, while disallowing--- the opposite embedding without explicit error handling.-type CodeGen a = forall e. BaseCodeGen e a---- | Code generators that can throw errors.-type ExcCodeGen a = BaseCodeGen CGError a---- | Run a `CodeGen` with given `Config` and initial `ModuleInfo`,--- returning either the resulting exception, or the result and final--- state of the codegen.-runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> ModuleInfo ->- IO (Either e (a, ModuleInfo))-runCodeGen cg cfg state = runExceptT (runStateT (runReaderT cg cfg) state)---- | This is useful when we plan run a subgenerator, and `mconcat` the--- result to the original structure later.-cleanInfo :: ModuleInfo -> ModuleInfo-cleanInfo info = info { moduleCode = NoCode, submodules = M.empty,- bootCode = NoCode, moduleExports = S.empty,- moduleDoc = Nothing, moduleMinBase = Base47 }---- | Run the given code generator using the state and config of an--- ambient CodeGen, but without adding the generated code to--- `moduleCode`, instead returning it explicitly.-recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code)-recurseCG cg = do- cfg <- ask- oldInfo <- get- -- Start the subgenerator with no code and no submodules.- let info = cleanInfo oldInfo- liftIO (runCodeGen cg cfg info) >>= \case- Left e -> throwError e- Right (r, new) -> put (mergeInfoState oldInfo new) >>- return (r, moduleCode new)---- | Like `recurse`, giving explicitly the set of loaded APIs for the--- subgenerator.-recurseWithAPIs :: M.Map Name API -> CodeGen () -> CodeGen ()-recurseWithAPIs apis cg = do- cfg <- ask- oldInfo <- get- -- Start the subgenerator with no code and no submodules.- let info = cleanInfo oldInfo- cfg' = cfg {loadedAPIs = apis}- liftIO (runCodeGen cg cfg' info) >>= \case- Left e -> throwError e- Right (_, new) -> put (mergeInfo oldInfo new)---- | Merge everything but the generated code for the two given `ModuleInfo`.-mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo-mergeInfoState oldState newState =- let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState)- newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState)- newExports = moduleExports oldState <> moduleExports newState- newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState)- newGHCOpts = Set.union (moduleGHCOpts oldState) (moduleGHCOpts newState)- newFlags = Set.union (moduleFlags oldState) (moduleFlags newState)- newBoot = bootCode oldState <> bootCode newState- newDoc = moduleDoc oldState <> moduleDoc newState- newMinBase = max (moduleMinBase oldState) (moduleMinBase newState)- in oldState {moduleDeps = newDeps, submodules = newSubmodules,- moduleExports = newExports, modulePragmas = newPragmas,- moduleGHCOpts = newGHCOpts, moduleFlags = newFlags,- bootCode = newBoot, moduleDoc = newDoc,- moduleMinBase = newMinBase }---- | Merge the infos, including code too.-mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo-mergeInfo oldInfo newInfo =- let info = mergeInfoState oldInfo newInfo- in info { moduleCode = moduleCode oldInfo <> moduleCode newInfo }---- | Add the given submodule to the list of submodules of the current--- module.-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- 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)---- | Try running the given `action`, and if it fails run `fallback`--- instead.-handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a-handleCGExc fallback- action = do- cfg <- ask- oldInfo <- get- let info = cleanInfo oldInfo- liftIO (runCodeGen action cfg info) >>= \case- Left e -> fallback e- Right (r, newInfo) -> do- put (mergeInfo oldInfo newInfo)- return r---- | Return the currently loaded set of dependencies.-getDeps :: CodeGen Deps-getDeps = moduleDeps <$> get---- | Return the ambient configuration for the code generator.-config :: CodeGen Config-config = hConfig <$> ask---- | Return the name of the current module.-currentModule :: CodeGen Text-currentModule = do- s <- get- return (T.intercalate "." (moduleName s))---- | Return the list of APIs available to the generator.-getAPIs :: CodeGen (M.Map Name API)-getAPIs = loadedAPIs <$> ask---- | Due to the `forall` in the definition of `CodeGen`, if we want to--- run the monad transformer stack until we get an `IO` action, our--- only option is ignoring the possible error code from--- `runExceptT`. This is perfectly safe, since there is no way to--- construct a computation in the `CodeGen` monad that throws an--- exception, due to the higher rank type.-unwrapCodeGen :: CodeGen a -> CodeGenConfig -> ModuleInfo ->- IO (a, ModuleInfo)-unwrapCodeGen cg cfg info =- runCodeGen cg cfg info >>= \case- Left _ -> error "unwrapCodeGen:: The impossible happened!"- Right (r, newInfo) -> return (r, newInfo)---- | Like `evalCodeGen`, but discard the resulting output value.-genCode :: Config -> M.Map Name API -> ModuleName -> CodeGen () ->- IO ModuleInfo-genCode cfg apis mName cg = snd <$> evalCodeGen cfg apis mName cg---- | Run a code generator, and return the information for the--- generated module together with the return value of the generator.-evalCodeGen :: Config -> M.Map Name API -> ModuleName -> CodeGen a ->- IO (a, ModuleInfo)-evalCodeGen cfg apis mName cg = do- let initialInfo = emptyModule mName- cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis}- unwrapCodeGen cg cfg' initialInfo---- | Mark the given dependency as used by the module.-loadDependency :: Text -> CodeGen ()-loadDependency name = do- deps <- getDeps- unless (Set.member name deps) $ do- let newDeps = Set.insert name deps- modify' $ \s -> s {moduleDeps = newDeps}---- | Return the transitive set of dependencies, i.e. the union of--- those of the module and (transitively) its submodules.-transitiveModuleDeps :: ModuleInfo -> Deps-transitiveModuleDeps minfo =- Set.unions (moduleDeps minfo- : map transitiveModuleDeps (M.elems $ submodules minfo))---- | Return the minimal base version supported by the module and all--- its submodules.-minBaseVersion :: ModuleInfo -> BaseVersion-minBaseVersion minfo =- maximum (moduleMinBase minfo- : map minBaseVersion (M.elems $ submodules minfo))---- | Give a friendly textual description of the error for presenting--- to the user.-describeCGError :: CGError -> Text-describeCGError (CGErrorNotImplemented e) = "Not implemented: " <> tshow e-describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " <> tshow e-describeCGError (CGErrorMissingInfo e) = "Missing info: " <> tshow e--notImplementedError :: Text -> ExcCodeGen a-notImplementedError s = throwError $ CGErrorNotImplemented s--badIntroError :: Text -> ExcCodeGen a-badIntroError s = throwError $ CGErrorBadIntrospectionInfo s--missingInfoError :: Text -> ExcCodeGen a-missingInfoError s = throwError $ CGErrorMissingInfo s--findAPI :: Type -> CodeGen (Maybe API)-findAPI TError = Just <$> findAPIByName (Name "GLib" "Error")-findAPI (TInterface ns n) = Just <$> findAPIByName (Name ns n)-findAPI _ = return Nothing--findAPIByName :: Name -> CodeGen API-findAPIByName n@(Name ns _) = do- apis <- getAPIs- case M.lookup n apis of- Just api -> return api- Nothing ->- terror $ "couldn't find API description for " <> ns <> "." <> name n---- | Add some code to the current generator.-tellCode :: Code -> CodeGen ()-tellCode c = modify' (\s -> s {moduleCode = moduleCode s <> c})---- | Print out a (newline-terminated) line.-line :: Text -> CodeGen ()-line = tellCode . Line---- | Print out the given line both to the normal module, and to the--- HsBoot file.-bline :: Text -> CodeGen ()-bline l = hsBoot (line l) >> line l---- | A blank line-blank :: CodeGen ()-blank = line ""---- | Increase the indent level for code generation.-indent :: BaseCodeGen e a -> BaseCodeGen e a-indent cg = do- (x, code) <- recurseCG cg- tellCode (Indent code)- return x---- | Group a set of related code.-group :: BaseCodeGen e a -> BaseCodeGen e a-group cg = do- (x, code) <- recurseCG cg- tellCode (Group code)- blank- return x---- | Write the given code into the .hs-boot file for the current module.-hsBoot :: BaseCodeGen e a -> BaseCodeGen e a-hsBoot cg = do- (x, code) <- recurseCG cg- modify' (\s -> s{bootCode = bootCode s <> code})- return x---- | Add a export to the current module.-export :: Export -> CodeGen ()-export e =- modify' $ \s -> s{moduleExports = moduleExports s |> e}---- | Reexport a whole module.-exportModule :: SymbolName -> CodeGen ()-exportModule m = export (Export ExportModule m)---- | Export a toplevel (i.e. belonging to no section) symbol.-exportToplevel :: SymbolName -> CodeGen ()-exportToplevel t = export (Export ExportToplevel t)---- | Add a type declaration-related export.-exportDecl :: SymbolName -> CodeGen ()-exportDecl d = export (Export ExportTypeDecl d)---- | Add a method export under the given section.-exportMethod :: HaddockSection -> SymbolName -> CodeGen ()-exportMethod s n = export (Export (ExportMethod s) n)---- | Add a property-related export under the given section.-exportProperty :: HaddockSection -> SymbolName -> CodeGen ()-exportProperty s n = export (Export (ExportProperty s) n)---- | Add a signal-related export under the given section.-exportSignal :: HaddockSection -> SymbolName -> CodeGen ()-exportSignal s n = export (Export (ExportSignal s) n)---- | Set the language pragmas for the current module.-setLanguagePragmas :: [Text] -> CodeGen ()-setLanguagePragmas ps =- modify' $ \s -> s{modulePragmas = Set.fromList ps}---- | Set the GHC options for compiling this module (in a OPTIONS_GHC pragma).-setGHCOptions :: [Text] -> CodeGen ()-setGHCOptions opts =- modify' $ \s -> s{moduleGHCOpts = Set.fromList opts}---- | Set the given flags for the module.-setModuleFlags :: [ModuleFlag] -> CodeGen ()-setModuleFlags flags =- modify' $ \s -> s{moduleFlags = Set.fromList flags}---- | Set the minimum base version supported by the current module.-setModuleMinBase :: BaseVersion -> CodeGen ()-setModuleMinBase v =- modify' $ \s -> s{moduleMinBase = max v (moduleMinBase s)}---- | Add the given text to the module-level documentation for the--- module being generated.-addModuleDocumentation :: Maybe Documentation -> CodeGen ()-addModuleDocumentation Nothing = return ()-addModuleDocumentation (Just doc) =- modify' $ \s -> s{moduleDoc = moduleDoc s <> Just (docText doc)}---- | Return a text representation of the `Code`.-codeToText :: Code -> Text-codeToText c = T.concat $ str 0 c []- where- str :: Int -> Code -> [Text] -> [Text]- str _ NoCode cont = cont- str n (Line s) cont = paddedLine n s : cont- str n (Indent c) cont = str (n + 1) c cont- str n (Sequence s) cont = deseq n (S.viewl s) cont- str n (Group c) cont = str n c cont-- deseq _ S.EmptyL cont = cont- deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont)---- | Pad a line to the given number of leading spaces, and add a--- newline at the end.-paddedLine :: Int -> Text -> Text-paddedLine n s = T.replicate (n * 4) " " <> s <> "\n"---- | Put a (padded) comma at the end of the text.-comma :: Text -> Text-comma s = padTo 40 s <> ","---- | Format the list of exported modules.-formatExportedModules :: [Export] -> Maybe Text-formatExportedModules [] = Nothing-formatExportedModules exports =- Just . T.concat . map ( paddedLine 1- . comma- . ("module " <>)- . exportSymbol)- . filter ((== ExportModule) . exportType) $ exports---- | Format the toplevel exported symbols.-formatToplevel :: [Export] -> Maybe Text-formatToplevel [] = Nothing-formatToplevel exports =- Just . T.concat . map (paddedLine 1 . comma . exportSymbol)- . filter ((== ExportToplevel) . exportType) $ exports---- | Format the type declarations section.-formatTypeDecls :: [Export] -> Maybe Text-formatTypeDecls exports =- let exportedTypes = filter ((== ExportTypeDecl) . exportType) exports- in if exportedTypes == []- then Nothing- else Just . T.unlines $ [ "-- * Exported types"- , T.concat . map ( paddedLine 1- . comma- . exportSymbol )- $ exportedTypes ]---- | Format a given section made of subsections.-formatSection :: Text -> (Export -> Maybe (HaddockSection, SymbolName)) ->- [Export] -> Maybe Text-formatSection section filter exports =- if M.null exportedSubsections- then Nothing- else Just . T.unlines $ [" -- * " <> section- , ( T.unlines- . map formatSubsection- . M.toList ) exportedSubsections]-- where- filteredExports :: [(HaddockSection, SymbolName)]- filteredExports = catMaybes (map filter exports)-- exportedSubsections :: M.Map HaddockSection (Set.Set SymbolName)- exportedSubsections = foldr extract M.empty filteredExports-- extract :: (HaddockSection, SymbolName) ->- M.Map Text (Set.Set Text) -> M.Map Text (Set.Set Text)- extract (subsec, m) secs =- M.insertWith Set.union subsec (Set.singleton m) secs-- formatSubsection :: (HaddockSection, Set.Set SymbolName) -> Text- formatSubsection (subsec, symbols) =- T.unlines [ "-- ** " <> subsec- , ( T.concat- . map (paddedLine 1 . comma)- . Set.toList ) symbols]---- | Format the list of methods.-formatMethods :: [Export] -> Maybe Text-formatMethods = formatSection "Methods" toMethod- where toMethod :: Export -> Maybe (HaddockSection, SymbolName)- toMethod (Export (ExportMethod s) m) = Just (s, m)- toMethod _ = Nothing---- | Format the list of properties.-formatProperties :: [Export] -> Maybe Text-formatProperties = formatSection "Properties" toProperty- where toProperty :: Export -> Maybe (HaddockSection, SymbolName)- toProperty (Export (ExportProperty s) m) = Just (s, m)- toProperty _ = Nothing---- | Format the list of signals.-formatSignals :: [Export] -> Maybe Text-formatSignals = formatSection "Signals" toSignal- where toSignal :: Export -> Maybe (HaddockSection, SymbolName)- toSignal (Export (ExportSignal s) m) = Just (s, m)- toSignal _ = Nothing---- | Format the given export list. This is just the inside of the--- parenthesis.-formatExportList :: [Export] -> Text-formatExportList exports =- T.unlines . catMaybes $ [ formatExportedModules exports- , formatToplevel exports- , formatTypeDecls exports- , formatMethods exports- , formatProperties exports- , formatSignals exports ]---- | Write down the list of language pragmas.-languagePragmas :: [Text] -> Text-languagePragmas [] = ""-languagePragmas ps = "{-# LANGUAGE " <> T.intercalate ", " ps <> " #-}\n"---- | Write down the list of GHC options.-ghcOptions :: [Text] -> Text-ghcOptions [] = ""-ghcOptions opts = "{-# OPTIONS_GHC " <> T.intercalate ", " opts <> " #-}\n"---- | Standard fields for every module.-standardFields :: Text-standardFields = T.unlines [ "Copyright : " <> authors- , "License : " <> license- , "Maintainer : " <> maintainers ]---- | The haddock header for the module, including optionally a description.-moduleHaddock :: Maybe Text -> Text-moduleHaddock Nothing = T.unlines ["{- |", standardFields <> "-}"]-moduleHaddock (Just description) = T.unlines ["{- |", standardFields,- description, "-}"]---- | Generic module prelude. We reexport all of the submodules.-modulePrelude :: Text -> [Export] -> [Text] -> Text-modulePrelude name [] [] = "module " <> name <> " () where\n"-modulePrelude name exports [] =- "module " <> name <> "\n ( "- <> formatExportList exports- <> " ) where\n"-modulePrelude name [] reexportedModules =- "module " <> name <> "\n ( "- <> formatExportList (map (Export ExportModule) reexportedModules)- <> " ) where\n\n"- <> T.unlines (map ("import " <>) reexportedModules)-modulePrelude name exports reexportedModules =- "module " <> name <> "\n ( "- <> formatExportList (map (Export ExportModule) reexportedModules)- <> "\n"- <> formatExportList exports- <> " ) 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---- | Standard imports.-moduleImports :: Text-moduleImports = T.unlines [ "import Prelude ()"- , "import Data.GI.Base.ShortPrelude"- , ""- , "import qualified Data.Text as T"- , "import qualified Data.ByteString.Char8 as B"- , "import qualified Data.Map as Map" ]---- | Write to disk the code for a module, under the given base--- directory. Does not write submodules recursively, for that use--- `writeModuleTree`.-writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO ()-writeModuleInfo verbose dirPrefix minfo = do- let submoduleNames = map (moduleName) (M.elems (submodules minfo))- -- We reexport any submodules.- submoduleExports = map dotModuleName submoduleNames- fname = moduleNameToPath dirPrefix (moduleName minfo) ".hs"- dirname = takeDirectory fname- code = codeToText (moduleCode minfo)- pragmas = languagePragmas (Set.toList $ modulePragmas minfo)- optionsGHC = ghcOptions (Set.toList $ moduleGHCOpts minfo)- prelude = modulePrelude (dotModuleName $ moduleName minfo)- (F.toList (moduleExports minfo))- submoduleExports- 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- 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])- when (bootCode minfo /= NoCode) $ do- let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot"- TIO.writeFile bootFName (genHsBoot minfo)---- | Generate the .hs-boot file for the given module.-genHsBoot :: ModuleInfo -> Text-genHsBoot minfo =- "module " <> (dotModuleName . moduleName) minfo <> " where\n\n" <>- moduleImports <> "\n" <>- codeToText (bootCode minfo)---- | Construct the filename corresponding to the given module.-moduleNameToPath :: Maybe FilePath -> ModuleName -> FilePath -> FilePath-moduleNameToPath dirPrefix mn ext =- joinPath (fromMaybe "" dirPrefix : map T.unpack mn) ++ ext---- | Turn an abstract module name into its dotted representation. For--- instance, ["GI", "Gtk", "Types"] -> GI.Gtk.Types.-dotModuleName :: ModuleName -> Text-dotModuleName mn = T.intercalate "." mn---- | 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- submoduleNames <- concat <$> forM (M.elems (submodules minfo))- (writeModuleCode verbose dirPrefix)- writeModuleInfo verbose dirPrefix minfo- return $ (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
− src/GI/CodeGen.hs
@@ -1,543 +0,0 @@-module GI.CodeGen- ( genConstant- , genFunction- , genModule- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Traversable (traverse)-#endif-import Control.Monad (forM, forM_, when, unless, filterM)-import Data.List (nub)-import Data.Tuple (swap)-import Data.Maybe (fromJust, fromMaybe, catMaybes, mapMaybe, isNothing)-import qualified Data.Map as M-import qualified Data.Text as T-import Data.Text (Text)--import Foreign.Storable (sizeOf)-import Foreign.C (CUInt)--import GI.API-import GI.Callable (genCallable)-import GI.Constant (genConstant)-import GI.Code-import GI.GObject-import GI.Inheritance (instanceTree, fullObjectMethodList,- fullInterfaceMethodList)-import GI.Properties (genInterfaceProperties, genObjectProperties)-import GI.OverloadedSignals (genInterfaceSignals, genObjectSignals)-import GI.OverloadedMethods (genMethodList, genMethodInfo,- genUnsupportedMethodInfo)-import GI.Signal (genSignal, genCallback)-import GI.Struct (genStructOrUnionFields, extractCallbacksInStruct,- fixAPIStructs, ignoreStruct, genZeroStruct, genZeroUnion)-import GI.SymbolNaming (upperName, classConstraint, noName)-import GI.Type-import GI.Util (tshow)--genFunction :: Name -> Function -> CodeGen ()-genFunction n (Function symbol throws fnMovedTo callable) =- -- Only generate the function if it has not been moved.- when (Nothing == fnMovedTo) $- submodule "Functions" $ group $ do- line $ "-- function " <> symbol- handleCGExc (\e -> line ("-- XXX Could not generate function "- <> symbol- <> "\n-- Error was : " <> describeCGError e))- (genCallable n symbol callable throws)--genBoxedObject :: Name -> Text -> CodeGen ()-genBoxedObject n typeInit = do- name' <- upperName n-- group $ do- line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>- typeInit <> " :: "- indent $ line "IO GType"- group $ do- line $ "instance BoxedObject " <> name' <> " where"- indent $ line $ "boxedType _ = c_" <> typeInit-- hsBoot $ line $ "instance BoxedObject " <> name' <> " where"--genBoxedEnum :: Name -> Text -> CodeGen ()-genBoxedEnum n typeInit = do- name' <- upperName n-- group $ do- line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>- typeInit <> " :: "- indent $ line "IO GType"- group $ do- line $ "instance BoxedEnum " <> name' <> " where"- indent $ line $ "boxedEnumType _ = c_" <> typeInit--genEnumOrFlags :: Name -> Enumeration -> ExcCodeGen ()-genEnumOrFlags n@(Name ns name) (Enumeration fields eDomain maybeTypeInit storageBytes isDeprecated) = do- -- Conversion functions expect enums and flags to map to CUInt,- -- which we assume to be of 32 bits. Fail early, instead of giving- -- strange errors at runtime.- when (sizeOf (0 :: CUInt) /= 4) $- notImplementedError $ "Unsupported CUInt size: " <> tshow (sizeOf (0 :: CUInt))- when (storageBytes /= 4) $- notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes-- name' <- upperName n- fields' <- forM fields $ \(fieldName, value) -> do- n <- upperName $ Name ns (name <> "_" <> fieldName)- return (n, value)-- line $ deprecatedPragma name' isDeprecated-- group $ do- exportDecl (name' <> "(..)")- line $ "data " <> name' <> " = "- indent $- case fields' of- ((fieldName, _value):fs) -> do- line $ " " <> fieldName- forM_ fs $ \(n, _) -> line $ "| " <> n- line $ "| Another" <> name' <> " Int"- line "deriving (Show, Eq)"- _ -> return ()- group $ do- line $ "instance Enum " <> name' <> " where"- indent $ do- forM_ fields' $ \(n, v) ->- line $ "fromEnum " <> n <> " = " <> tshow v- line $ "fromEnum (Another" <> name' <> " k) = k"- let valueNames = M.toList . M.fromListWith (curry snd) $ map swap fields'- blank- indent $ do- forM_ valueNames $ \(v, n) ->- line $ "toEnum " <> tshow v <> " = " <> n- line $ "toEnum k = Another" <> name' <> " k"- maybe (return ()) (genErrorDomain name') eDomain- maybe (return ()) (genBoxedEnum n) maybeTypeInit--genEnum :: Name -> Enumeration -> CodeGen ()-genEnum n@(Name _ name) enum = submodule "Enums" $ do- line $ "-- Enum " <> name-- -- Reexported as-is by GI.Pkg.Types- setModuleFlags [Reexport, NoTypesImport, NoCallbacksImport]-- handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e)- (genEnumOrFlags n enum)---- 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- line $ "-- Flags " <> 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-- name' <- upperName n- group $ line $ "instance IsGFlag " <> name')--genErrorDomain :: Text -> Text -> CodeGen ()-genErrorDomain name' domain = do- group $ do- line $ "instance GErrorClass " <> name' <> " where"- indent $ line $- "gerrorClassDomain _ = \"" <> domain <> "\""- -- Generate type specific error handling (saves a bit of typing, and- -- it's clearer to read).- group $ do- let catcher = "catch" <> name'- line $ catcher <> " ::"- indent $ do- line "IO a ->"- line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->"- line "IO a"- line $ catcher <> " = catchGErrorJustDomain"- group $ do- let handler = "handle" <> name'- line $ handler <> " ::"- indent $ do- line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->"- line "IO a ->"- line "IO a"- line $ handler <> " = handleGErrorJustDomain"- exportToplevel ("catch" <> name')- exportToplevel ("handle" <> name')--genStruct :: Name -> Struct -> CodeGen ()-genStruct n s = unless (ignoreStruct n s) $ do- name' <- upperName n-- submodule "Structs" $ submodule name' $ do- let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- hsBoot decl- decl-- addModuleDocumentation (structDocumentation s)-- when (structIsBoxed s) $- genBoxedObject n (fromJust $ structTypeInit s)- exportDecl (name' <> ("(..)"))-- -- Generate a builder for a structure filled with zeroes.- genZeroStruct n s-- noName name'-- -- Generate code for fields.- genStructOrUnionFields n (structFields s)-- -- Methods- 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)--genUnion :: Name -> Union -> CodeGen ()-genUnion n u = do- name' <- upperName n-- submodule "Unions" $ submodule name' $ do- let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- hsBoot decl- decl-- when (unionIsBoxed u) $- genBoxedObject n (fromJust $ unionTypeInit u)- exportDecl (name' <> "(..)")-- -- Generate a builder for a structure filled with zeroes.- genZeroUnion n u-- noName name'-- -- Generate code for fields.- genStructOrUnionFields n (unionFields u)-- -- Methods- 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)---- Add the implicit object argument to methods of an object. Since we--- are prepending an argument we need to adjust the offset of the--- length arguments of CArrays, and closure and destroyer offsets.-fixMethodArgs :: Name -> Callable -> Callable-fixMethodArgs cn c = c { args = args' , returnType = returnType' }- where- returnType' = fixCArrayLength $ returnType c- args' = objArg : map (fixDestroyers . fixClosures . fixLengthArg) (args c)-- fixLengthArg :: Arg -> Arg- fixLengthArg arg = arg { argType = fixCArrayLength (argType arg)}-- fixCArrayLength :: Type -> Type- fixCArrayLength (TCArray zt fixed length t) =- if length > -1- then TCArray zt fixed (length+1) t- else TCArray zt fixed length t- fixCArrayLength t = t-- fixDestroyers :: Arg -> Arg- fixDestroyers arg = let destroy = argDestroy arg in- if destroy > -1- then arg {argDestroy = destroy + 1}- else arg-- fixClosures :: Arg -> Arg- fixClosures arg = let closure = argClosure arg in- if closure > -1- then arg {argClosure = closure + 1}- else arg-- objArg = Arg {- argCName = "_obj",- argType = TInterface (namespace cn) (name cn),- direction = DirectionIn,- mayBeNull = False,- argScope = ScopeTypeInvalid,- argClosure = -1,- argDestroy = -1,- argCallerAllocates = False,- transfer = TransferNothing }---- For constructors we want to return the actual type of the object,--- rather than a generic superclass (so Gtk.labelNew returns a--- Gtk.Label, rather than a Gtk.Widget)-fixConstructorReturnType :: Bool -> Name -> Callable -> Callable-fixConstructorReturnType returnsGObject cn c = c { returnType = returnType' }- where- returnType' = if returnsGObject then- TInterface (namespace cn) (name cn)- else- returnType c--genMethod :: Name -> Method -> ExcCodeGen ()-genMethod cn m@(Method {- methodName = mn,- methodSymbol = sym,- methodCallable = c,- methodType = t,- methodThrows = throws- }) = do- name' <- upperName cn- returnsGObject <- isGObject (returnType c)- line $ "-- method " <> name' <> "::" <> name mn- line $ "-- method type : " <> tshow t- let -- Mangle the name to namespace it to the class.- mn' = mn { name = name cn <> "_" <> name mn }- let c' = if Constructor == t- then fixConstructorReturnType returnsGObject cn c- else c- c'' = if OrdinaryMethod == t- then fixMethodArgs cn c'- else c'- genCallable mn' sym c'' throws-- genMethodInfo cn (m {methodCallable = c''})---- Type casting with type checking-genGObjectCasts :: Bool -> Name -> Text -> [Name] -> CodeGen ()-genGObjectCasts isIU n cn_ parents = do- name' <- upperName n- qualifiedParents <- traverse upperName parents-- 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'- group $ do- exportDecl className- bline $ "class GObject o => " <> className <> " o"- bline $ "instance (GObject o, IsDescendantOf " <> name' <> " o) => "- <> className <> " o"-- -- Safe downcasting.- group $ do- let safeCast = "to" <> name'- exportDecl safeCast- line $ safeCast <> " :: " <> className <> " o => o -> IO " <> name'- line $ safeCast <> " = unsafeCastTo " <> name'---- Wrap a given Object. We enforce that every Object that we wrap is a--- GObject. This is the case for everything except the ParamSpec* set--- of objects, we deal with these separately.-genObject :: Name -> Object -> CodeGen ()-genObject n o = do- 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' <> "(..)")-- -- 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'-- 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)-- genObjectProperties n o- 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)--genInterface :: Name -> Interface -> CodeGen ()-genInterface n iface = do- name' <- upperName n-- submodule "Interfaces" $ submodule name' $ do- line $ "-- interface " <> name' <> " "- line $ deprecatedPragma name' $ ifDeprecated iface- bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"- exportDecl (name' <> "(..)")-- noName name'-- 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)-- genInterfaceProperties n iface- 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-- 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 <> " = '[]"-- -- 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)---- Some type libraries include spurious interface/struct methods,--- where a method Mod.Foo::func also appears as an ordinary function--- in the list of APIs. If we find a matching function (without the--- "moved-to" annotation), we don't generate the method.------ It may be more expedient to keep a map of symbol -> function.-symbolFromFunction :: Text -> CodeGen Bool-symbolFromFunction sym = do- apis <- getAPIs- return $ any (hasSymbol sym . snd) $ M.toList apis- where- hasSymbol sym1 (APIFunction (Function { fnSymbol = sym2,- fnMovedTo = movedTo })) =- sym1 == sym2 && movedTo == Nothing- hasSymbol _ _ = False---- | Remove functions and methods annotated with "moved-to".-dropMovedItems :: API -> Maybe API-dropMovedItems (APIFunction f) = if fnMovedTo f == Nothing- then Just (APIFunction f)- else Nothing-dropMovedItems (APIInterface i) =- (Just . APIInterface) i {ifMethods = filterMovedMethods (ifMethods i)}-dropMovedItems (APIObject o) =- (Just . APIObject) o {objMethods = filterMovedMethods (objMethods o)}-dropMovedItems (APIStruct s) =- (Just . APIStruct) s {structMethods = filterMovedMethods (structMethods s)}-dropMovedItems (APIUnion u) =- (Just . APIUnion) u {unionMethods = filterMovedMethods (unionMethods u)}-dropMovedItems a = Just a---- | Drop the moved methods.-filterMovedMethods :: [Method] -> [Method]-filterMovedMethods = filter (isNothing . methodMovedTo)--genAPI :: Name -> API -> CodeGen ()-genAPI n (APIConst c) = genConstant n c-genAPI n (APIFunction f) = genFunction n f-genAPI n (APIEnum e) = genEnum n e-genAPI n (APIFlags f) = genFlags n f-genAPI n (APICallback c) = genCallback n c-genAPI n (APIStruct s) = genStruct n s-genAPI n (APIUnion u) = genUnion n u-genAPI n (APIObject o) = genObject n o-genAPI n (APIInterface i) = genInterface n i--genModule' :: M.Map Name API -> CodeGen ()-genModule' apis = do- mapM_ (uncurry genAPI)- -- We provide these ourselves- $ filter ((`notElem` [ Name "GLib" "Array"- , Name "GLib" "Error"- , Name "GLib" "HashTable"- , Name "GLib" "List"- , Name "GLib" "SList"- , Name "GLib" "Variant"- , Name "GObject" "Value"- , Name "GObject" "Closure"]) . fst)- $ mapMaybe (traverse dropMovedItems)- -- Some callback types are defined inside structs- $ map fixAPIStructs- $ M.toList- $ apis-- -- 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 ()--genModule :: M.Map Name API -> CodeGen ()-genModule apis = do- -- Reexport Data.GI.Base for convenience (so it does not need to be- -- imported separately).- line "import Data.GI.Base"- exportModule "Data.GI.Base"-- -- Some API symbols are embedded into structures, extract these and- -- inject them into the set of APIs loaded and being generated.- let embeddedAPIs = (M.fromList- . concatMap extractCallbacksInStruct- . M.toList) apis- allAPIs <- getAPIs- recurseWithAPIs (M.union allAPIs embeddedAPIs)- (genModule' (M.union apis embeddedAPIs))
− src/GI/Config.hs
@@ -1,15 +0,0 @@-module GI.Config- ( Config(..)- ) where--import Data.Text (Text)-import GI.Overrides (Overrides)--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- }
− src/GI/Constant.hs
@@ -1,103 +0,0 @@-module GI.Constant- ( genConstant- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Data.Text (Text)--import GI.API-import GI.Code-import GI.Conversions-import GI.Type-import GI.Util (tshow)---- | Data for a bidrectional pattern synonym. It is either a simple--- one of the form "pattern Name = value :: Type" or an explicit one--- of the form--- > pattern Name <- (view -> value) :: Type where--- > Name = expression value :: Type-data PatternSynonym = SimpleSynonym PSValue PSType- | ExplicitSynonym PSView PSExpression PSValue PSType---- Some simple types for legibility-type PSValue = Text-type PSType = Text-type PSView = Text-type PSExpression = Text--writePattern :: Text -> PatternSynonym -> CodeGen ()-writePattern name (SimpleSynonym value t) = line $- "pattern " <> name <> " = " <> value <> " :: " <> t-writePattern name (ExplicitSynonym view expression value t) = do- -- Supported only on ghc >= 7.10- setModuleMinBase Base48- line $ "pattern " <> name <> " <- (" <> view <> " -> "- <> value <> ") :: " <> t <> " where"- indent $ line $- name <> " = " <> expression <> " " <> value <> " :: " <> t--genConstant :: Name -> Constant -> CodeGen ()-genConstant (Name _ name) (Constant t value deprecated) =- submodule "Constants" $ group $ do- setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables",- "ViewPatterns"]- line $ deprecatedPragma name deprecated-- handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)- (assignValue name t value >>- exportToplevel ("pattern " <> name))---- | Assign to the given name the given constant value, in a way that--- can be assigned to the corresponding Haskell type.-assignValue :: Text -> Type -> Text -> ExcCodeGen ()-assignValue name t@(TBasicType TVoid) value = do- ht <- tshow <$> haskellType t- writePattern name (ExplicitSynonym "ptrToIntPtr" "intPtrToPtr" value ht)-assignValue name t@(TBasicType b) value = do- ht <- tshow <$> haskellType t- hv <- showBasicType b value- writePattern name (SimpleSynonym hv ht)-assignValue name t@(TInterface _ _) value = do- ht <- tshow <$> haskellType t- api <- findAPI t- case api of- Just (APIEnum _) ->- writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht)- Just (APIFlags _) -> do- -- gflagsToWord and wordToGFlags are polymorphic, so in this- -- case we need to specialize so the type of the pattern is- -- not ambiguous.- let wordValue = "(" <> value <> " :: Word64)"- writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" wordValue ht)- _ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t-assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t---- | Show a basic type, in a way that can be assigned to the--- corresponding Haskell type.-showBasicType :: BasicType -> Text -> ExcCodeGen Text-showBasicType TInt8 i = return i-showBasicType TUInt8 i = return i-showBasicType TInt16 i = return i-showBasicType TUInt16 i = return i-showBasicType TInt32 i = return i-showBasicType TUInt32 i = return i-showBasicType TInt64 i = return i-showBasicType TUInt64 i = return i-showBasicType TBoolean "0" = return "False"-showBasicType TBoolean "false" = return "False"-showBasicType TBoolean "1" = return "True"-showBasicType TBoolean "true" = return "True"-showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" <> b <> "\""-showBasicType TFloat f = return f-showBasicType TDouble d = return d-showBasicType TUTF8 s = return . tshow $ s-showBasicType TFileName fn = return . tshow $ fn-showBasicType TUniChar c = return $ "'" <> c <> "'"-showBasicType TGType gtype = return $ "GType " <> gtype-showBasicType TIntPtr ptr = return ptr-showBasicType TUIntPtr ptr = return ptr--- We take care of this one separately above-showBasicType TVoid _ = notImplementedError $ "Cannot directly show a pointer"
− src/GI/Conversions.hs
@@ -1,776 +0,0 @@-{-# LANGUAGE PatternGuards, DeriveFunctor #-}--module GI.Conversions- ( convert- , genConversion- , unpackCArray- , computeArrayLength-- , hToF- , fToH- , haskellType- , foreignType-- , argumentType- , elementType- , elementMap- , elementTypeAndMap-- , isManaged- , isNullable-- , getIsScalar- , requiresAlloc-- , apply- , mapC- , literal- , Constructor(..)- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (when)-import Control.Monad.Free (Free(..), liftF)-import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)-import Data.Int-import Data.Text (Text)-import qualified Data.Text as T-import Data.Word-import GHC.Exts (IsString(..))--import GI.API-import GI.Code-import GI.GObject-import GI.SymbolNaming-import GI.Type-import GI.Util---- String identifying a constructor in the generated code, which is--- either (by default) a pure function (indicated by the P--- constructor) or a function returning values on a monad (M--- constructor). 'Id' denotes the identity function.-data Constructor = P Text | M Text | Id- deriving (Eq,Show)-instance IsString Constructor where- fromString = P . T.pack--data FExpr next = Apply Constructor next- | MapC Map Constructor next- | Literal Constructor next- deriving (Show, Functor)--type Converter = Free FExpr ()---- Different available maps.-data Map = Map | MapFirst | MapSecond- deriving (Show)---- Naming for the maps.-mapName :: Map -> Text-mapName Map = "map"-mapName MapFirst = "mapFirst"-mapName MapSecond = "mapSecond"---- Naming for the monadic versions of the maps that we use-monadicMapName :: Map -> Text-monadicMapName Map = "mapM"-monadicMapName MapFirst = "mapFirstA"-monadicMapName MapSecond = "mapSecondA"--apply :: Constructor -> Converter-apply f = liftF $ Apply f ()--mapC :: Constructor -> Converter-mapC f = liftF $ MapC Map f ()--mapFirst :: Constructor -> Converter-mapFirst f = liftF $ MapC MapFirst f ()--mapSecond :: Constructor -> Converter-mapSecond f = liftF $ MapC MapSecond f ()--literal :: Constructor -> Converter-literal f = liftF $ Literal f ()--genConversion :: Text -> Converter -> CodeGen Text-genConversion l (Pure ()) = return l-genConversion l (Free k) = do- let l' = prime l- case k of- Apply (P f) next ->- do line $ "let " <> l' <> " = " <> f <> " " <> l- genConversion l' next- Apply (M f) next ->- do line $ l' <> " <- " <> f <> " " <> l- genConversion l' next- Apply Id next -> genConversion l next-- MapC m (P f) next ->- do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l- genConversion l' next- MapC m (M f) next ->- do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l- genConversion l' next- MapC _ Id next -> genConversion l next-- Literal (P f) next ->- do line $ "let " <> l <> " = " <> f- genConversion l next- Literal (M f) next ->- do line $ l <> " <- " <> f- genConversion l next- Literal Id next -> genConversion l next---- Given an array, together with its type, return the code for reading--- its length.-computeArrayLength :: Text -> Type -> ExcCodeGen Text-computeArrayLength array (TCArray _ _ _ t) = do- reader <- findReader- return $ "fromIntegral $ " <> reader <> " " <> array- where findReader = case t of- TBasicType TUInt8 -> return "B.length"- TBasicType _ -> return "length"- TInterface _ _ -> return "length"- TCArray{} -> return "length"- _ -> notImplementedError $- "Don't know how to compute length of " <> tshow t-computeArrayLength _ t =- notImplementedError $ "computeArrayLength called on non-CArray type "- <> tshow t--convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text-convert l c = do- c' <- c- genConversion l c'--hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor-hObjectToF t transfer =- if transfer == TransferEverything- then do- isGO <- isGObject t- if isGO- then return $ M "refObject"- else badIntroError "Transferring a non-GObject object"- -- castPtr since we accept any instance of the class associated with- -- the GObject, not just the precise type of the GObject, while the- -- foreign function declaration requires a pointer of the precise- -- type.- else return "unsafeManagedPtrCastPtr"--hVariantToF :: Transfer -> CodeGen Constructor-hVariantToF transfer =- if transfer == TransferEverything- then return $ M "refGVariant"- else return "unsafeManagedPtrGetPtr"--hParamSpecToF :: Transfer -> CodeGen Constructor-hParamSpecToF transfer =- if transfer == TransferEverything- then return $ M "refGParamSpec"- else return "unsafeManagedPtrGetPtr"--hBoxedToF :: Transfer -> CodeGen Constructor-hBoxedToF transfer =- if transfer == TransferEverything- then return $ M "copyBoxed"- else return "unsafeManagedPtrGetPtr"--hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor-hStructToF s transfer =- if transfer /= TransferEverything || structIsBoxed s then- hBoxedToF transfer- else do- when (structSize s == 0) $- badIntroError "Transferring a non-boxed struct with unknown size!"- return "unsafeManagedPtrGetPtr"--hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor-hUnionToF u transfer =- if transfer /= TransferEverything || unionIsBoxed u then- hBoxedToF transfer- else do- when (unionSize u == 0) $- badIntroError "Transferring a non-boxed union with unknown size!"- return "unsafeManagedPtrGetPtr"---- Given the Haskell and Foreign types, returns the name of the--- function marshalling between both.-hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer- -> ExcCodeGen Constructor-hToF' t a hType fType transfer- | ( hType == fType ) = return Id- | TError <- t = hBoxedToF transfer- | TVariant <- t = hVariantToF transfer- | TParamSpec <- t = hParamSpecToF transfer- | Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"- | Just (APIFlags _) <- a = return "gflagsToWord"- | Just (APIObject _) <- a = hObjectToF t transfer- | Just (APIInterface _) <- a = hObjectToF t transfer- | Just (APIStruct s) <- a = hStructToF s transfer- | Just (APIUnion u) <- a = hUnionToF u transfer- -- Converting callback types requires more context, we leave that- -- as a special case to be implemented by the caller.- | Just (APICallback _) <- a = error "Cannot handle callback type here!! "- | TByteArray <- t = return $ M "packGByteArray"- | TCArray True _ _ (TBasicType TUTF8) <- t =- return $ M "packZeroTerminatedUTF8CArray"- | TCArray True _ _ (TBasicType TFileName) <- t =- return $ M "packZeroTerminatedFileNameArray"- | TCArray True _ _ (TBasicType TVoid) <- t =- return $ M "packZeroTerminatedPtrArray"- | TCArray True _ _ (TBasicType TUInt8) <- t =- return $ M "packZeroTerminatedByteString"- | TCArray True _ _ (TBasicType TBoolean) <- t =- return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))"- | TCArray True _ _ (TBasicType TGType) <- t =- return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)"- | TCArray True _ _ (TBasicType _) <- t =- return $ M "packZeroTerminatedStorableArray"- | TCArray False _ _ (TBasicType TUTF8) <- t =- return $ M "packUTF8CArray"- | TCArray False _ _ (TBasicType TFileName) <- t =- return $ M "packFileNameArray"- | TCArray False _ _ (TBasicType TVoid) <- t =- return $ M "packPtrArray"- | TCArray False _ _ (TBasicType TUInt8) <- t =- return $ M "packByteString"- | TCArray False _ _ (TBasicType TBoolean) <- t =- return $ M "(packMapStorableArray (fromIntegral . fromEnum))"- | TCArray False _ _ (TBasicType TGType) <- t =- return $ M "(packMapStorableArray gtypeToCGType)"- | TCArray False _ _ (TBasicType TFloat) <- t =- return $ M "(packMapStorableArray realToFrac)"- | TCArray False _ _ (TBasicType TDouble) <- t =- return $ M "(packMapStorableArray realToFrac)"- | TCArray False _ _ (TBasicType _) <- t =- return $ M "packStorableArray"- | TCArray{} <- t = notImplementedError $- "Don't know how to pack C array of type " <> tshow t- | otherwise = case (tshow hType, tshow fType) of- ("T.Text", "CString") -> return $ M "textToCString"- ("[Char]", "CString") -> return $ M "stringToCString"- ("Char", "CInt") -> return "(fromIntegral . ord)"- ("Bool", "CInt") -> return "(fromIntegral . fromEnum)"- ("Float", "CFloat") -> return "realToFrac"- ("Double", "CDouble") -> return "realToFrac"- ("GType", "CGType") -> return "gtypeToCGType"- _ -> notImplementedError $- "Don't know how to convert "- <> tshow hType <> " into "- <> tshow fType <> ".\n"- <> "Internal type: "- <> tshow t--getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor-getForeignConstructor t transfer = do- a <- findAPI t- hType <- haskellType t- fType <- foreignType t- hToF' t a hType fType transfer--hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter-hToF_PackedType t packer transfer = do- innerConstructor <- getForeignConstructor t transfer- return $ do- mapC innerConstructor- apply (M packer)---- | Try to find the `hash` and `equal` functions appropriate for the--- given type, when used as a key in a GHashTable.-hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text)-hashTableKeyMappings (TBasicType TVoid) = return ("gDirectHash", "gDirectEqual")-hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual")-hashTableKeyMappings t =- notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported."---- | `GHashTable` tries to fit every type into a pointer, the--- following function tries to find the appropriate--- (destroy,packer,unpacker) for the given type.-hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text)-hashTablePtrPackers (TBasicType TVoid) =- return ("Nothing", "ptrPackPtr", "ptrUnpackPtr")-hashTablePtrPackers (TBasicType TUTF8) =- return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr")-hashTablePtrPackers t =- notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported."--hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter-hToF_PackGHashTable keys elems = do- -- We will be adding elements to the Hash list with appropriate- -- destructors, so we always want a fresh copy.- keysConstructor <- getForeignConstructor keys TransferEverything- elemsConstructor <- getForeignConstructor elems TransferEverything- (keyHash, keyEqual) <- hashTableKeyMappings keys- (keyDestroy, keyPack, _) <- hashTablePtrPackers keys- (elemDestroy, elemPack, _) <- hashTablePtrPackers elems- return $ do- apply (P "Map.toList")- mapFirst keysConstructor- mapSecond elemsConstructor- mapFirst (P keyPack)- mapSecond (P elemPack)- apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual,- keyDestroy, elemDestroy]))--hToF :: Type -> Transfer -> ExcCodeGen Converter-hToF (TGList t) transfer = hToF_PackedType t "packGList" transfer-hToF (TGSList t) transfer = hToF_PackedType t "packGSList" transfer-hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer-hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer-hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb--- Arrays without length info are just passed along.-hToF (TCArray False (-1) (-1) _) _ = return $ Pure ()-hToF (TCArray zt _ _ t@(TCArray{})) transfer = do- let packer = if zt- then "packZeroTerminated"- else "pack"- hToF_PackedType t (packer <> "PtrArray") transfer--hToF (TCArray zt _ _ t@(TInterface _ _)) transfer = do- isScalar <- getIsScalar t- let packer = if zt- then "packZeroTerminated"- else "pack"- if isScalar- then hToF_PackedType t (packer <> "StorableArray") transfer- else do- api <- findAPI t- let size = case api of- Just (APIStruct s) -> structSize s- Just (APIUnion u) -> unionSize u- _ -> 0- if size == 0 || zt- then hToF_PackedType t (packer <> "PtrArray") transfer- else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer--hToF t transfer = do- a <- findAPI t- hType <- haskellType t- fType <- foreignType t- constructor <- hToF' t a hType fType transfer- return $ apply constructor--boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor-boxedForeignPtr constructor transfer = return $- case transfer of- TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor- _ -> M $ parenthesize $ "newBoxed " <> constructor--suForeignPtr :: Bool -> Int -> TypeRep -> Transfer -> CodeGen Constructor-suForeignPtr isBoxed size hType transfer = do- let constructor = T.pack . tyConName . typeRepTyCon $ hType- if isBoxed then- boxedForeignPtr constructor transfer- else case size of- 0 -> do- line "-- XXX Wrapping a foreign struct/union with no known destructor, leak?"- return $ M $ parenthesize $- "\\x -> " <> constructor <> " <$> newForeignPtr_ x"- n -> return $ M $ parenthesize $- case transfer of- TransferEverything -> "wrapPtr " <> constructor- _ -> "newPtr " <> tshow n <> " " <> constructor--structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor-structForeignPtr s =- suForeignPtr (structIsBoxed s) (structSize s)--unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor-unionForeignPtr u =- suForeignPtr (unionIsBoxed u) (unionSize u)--fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor-fObjectToH t hType transfer = do- let constructor = T.pack . tyConName . typeRepTyCon $ hType- isGO <- isGObject t- case transfer of- TransferEverything ->- if isGO- then return $ M $ parenthesize $ "wrapObject " <> constructor- else badIntroError "Got a transfer of something not a GObject"- _ ->- if isGO- then return $ M $ parenthesize $ "newObject " <> constructor- else badIntroError "Wrapping not a GObject with no copy..."--fCallbackToH :: Callback -> TypeRep -> Transfer -> ExcCodeGen Constructor-fCallbackToH _ _ _ =- notImplementedError "Wrapping foreign callbacks is not supported yet"--fVariantToH :: Transfer -> CodeGen Constructor-fVariantToH transfer =- return $ M $ case transfer of- TransferEverything -> "wrapGVariantPtr"- _ -> "newGVariantFromPtr"--fParamSpecToH :: Transfer -> CodeGen Constructor-fParamSpecToH transfer =- return $ M $ case transfer of- TransferEverything -> "wrapGParamSpecPtr"- _ -> "newGParamSpecFromPtr"--fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer- -> ExcCodeGen Constructor-fToH' t a hType fType transfer- | ( hType == fType ) = return Id- | Just (APIEnum _) <- a = return "(toEnum . fromIntegral)"- | Just (APIFlags _) <- a = return "wordToGFlags"- | TError <- t = boxedForeignPtr "GError" transfer- | TVariant <- t = fVariantToH transfer- | TParamSpec <- t = fParamSpecToH transfer- | Just (APIStruct s) <- a = structForeignPtr s hType transfer- | Just (APIUnion u) <- a = unionForeignPtr u hType transfer- | Just (APIObject _) <- a = fObjectToH t hType transfer- | Just (APIInterface _) <- a = fObjectToH t hType transfer- | Just (APICallback c) <- a = fCallbackToH c hType transfer- | TCArray True _ _ (TBasicType TUTF8) <- t =- return $ M "unpackZeroTerminatedUTF8CArray"- | TCArray True _ _ (TBasicType TFileName) <- t =- return $ M "unpackZeroTerminatedFileNameArray"- | TCArray True _ _ (TBasicType TUInt8) <- t =- return $ M "unpackZeroTerminatedByteString"- | TCArray True _ _ (TBasicType TVoid) <- t =- return $ M "unpackZeroTerminatedPtrArray"- | TCArray True _ _ (TBasicType TBoolean) <- t =- return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))"- | TCArray True _ _ (TBasicType TGType) <- t =- return $ M "(unpackMapZeroTerminatedStorableArray GType)"- | TCArray True _ _ (TBasicType TFloat) <- t =- return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"- | TCArray True _ _ (TBasicType TDouble) <- t =- return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"- | TCArray True _ _ (TBasicType _) <- t =- return $ M "unpackZeroTerminatedStorableArray"- | TCArray{} <- t = notImplementedError $- "Don't know how to unpack C array of type " <> tshow t- | TByteArray <- t = return $ M "unpackGByteArray"- | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet"- | otherwise = case (tshow fType, tshow hType) of- ("CString", "T.Text") -> return $ M "cstringToText"- ("CString", "[Char]") -> return $ M "cstringToString"- ("CInt", "Char") -> return "(chr . fromIntegral)"- ("CInt", "Bool") -> return "(/= 0)"- ("CFloat", "Float") -> return "realToFrac"- ("CDouble", "Double") -> return "realToFrac"- ("CGType", "GType") -> return "GType"- _ ->- notImplementedError $ "Don't know how to convert "- <> tshow fType <> " into "- <> tshow hType <> ".\n"- <> "Internal type: "- <> tshow t--getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor-getHaskellConstructor t transfer = do- a <- findAPI t- hType <- haskellType t- fType <- foreignType t- fToH' t a hType fType transfer--fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter-fToH_PackedType t unpacker transfer = do- innerConstructor <- getHaskellConstructor t transfer- return $ do- apply (M unpacker)- mapC innerConstructor--fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter-fToH_UnpackGHashTable keys elems transfer = do- keysConstructor <- getHaskellConstructor keys transfer- (_,_,keysUnpack) <- hashTablePtrPackers keys- elemsConstructor <- getHaskellConstructor elems transfer- (_,_,elemsUnpack) <- hashTablePtrPackers elems- return $ do- apply (M "unpackGHashTable")- mapFirst (P keysUnpack)- mapFirst keysConstructor- mapSecond (P elemsUnpack)- mapSecond elemsConstructor- apply (P "Map.fromList")--fToH :: Type -> Transfer -> ExcCodeGen Converter--fToH (TGList t) transfer = fToH_PackedType t "unpackGList" transfer-fToH (TGSList t) transfer = fToH_PackedType t "unpackGSList" transfer-fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer-fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer-fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer--- Arrays without length info are just passed along.-fToH (TCArray False (-1) (-1) _) _ = return $ Pure ()-fToH (TCArray True _ _ t@(TCArray{})) transfer =- fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer-fToH (TCArray True _ _ t@(TInterface _ _)) transfer = do- isScalar <- getIsScalar t- if isScalar- then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer- else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer--fToH t transfer = do- a <- findAPI t- hType <- haskellType t- fType <- foreignType t- constructor <- fToH' t a hType fType transfer- return $ apply constructor--unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter-unpackCArray length (TCArray False _ _ t) transfer =- case t of- TBasicType TUTF8 -> return $ apply $ M $ parenthesize $- "unpackUTF8CArrayWithLength " <> length- TBasicType TFileName -> return $ apply $ M $ parenthesize $- "unpackFileNameArrayWithLength " <> length- TBasicType TUInt8 -> return $ apply $ M $ parenthesize $- "unpackByteStringWithLength " <> length- TBasicType TVoid -> return $ apply $ M $ parenthesize $- "unpackPtrArrayWithLength " <> length- TBasicType TBoolean -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength (/= 0) " <> length- TBasicType TGType -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength GType " <> length- TBasicType TFloat -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength realToFrac " <> length- TBasicType TDouble -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength realToFrac " <> length- TBasicType _ -> return $ apply $ M $ parenthesize $- "unpackStorableArrayWithLength " <> length- TInterface _ _ -> do- a <- findAPI t- isScalar <- getIsScalar t- hType <- haskellType t- fType <- foreignType t- innerConstructor <- fToH' t a hType fType transfer- let (boxed, size) = case a of- Just (APIStruct s) -> (structIsBoxed s, structSize s)- Just (APIUnion u) -> (unionIsBoxed u, unionSize u)- _ -> (False, 0)- let unpacker | isScalar = "unpackStorableArrayWithLength"- | (size == 0) = "unpackPtrArrayWithLength"- | boxed = "unpackBoxedArrayWithLength " <> tshow size- | otherwise = "unpackBlockArrayWithLength " <> tshow size- return $ do- apply $ M $ parenthesize $ unpacker <> " " <> length- mapC innerConstructor- _ -> notImplementedError $- "unpackCArray : Don't know how to unpack C Array of type " <> tshow t--unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type."---- Given a type find the typeclasses the type belongs to, and return--- the representation of the type in the function signature and the--- list of typeclass constraints for the type.-argumentType :: [Char] -> Type -> CodeGen ([Char], Text, [Text])-argumentType [] _ = error "out of letters"-argumentType letters (TGList a) = do- (ls, name, constraints) <- argumentType letters a- return (ls, "[" <> name <> "]", constraints)-argumentType letters (TGSList a) = do- (ls, name, constraints) <- argumentType letters a- return (ls, "[" <> name <> "]", constraints)-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 (APIObject _) -> do- isGO <- isGObject t- if isGO- then return (ls, T.singleton l,- [classConstraint s <> " " <> T.singleton l])- else return (letters, s, [])- _ -> return (letters, s, [])--haskellBasicType TVoid = ptr $ typeOf ()-haskellBasicType TBoolean = typeOf True-haskellBasicType TInt8 = typeOf (0 :: Int8)-haskellBasicType TUInt8 = typeOf (0 :: Word8)-haskellBasicType TInt16 = typeOf (0 :: Int16)-haskellBasicType TUInt16 = typeOf (0 :: Word16)-haskellBasicType TInt32 = typeOf (0 :: Int32)-haskellBasicType TUInt32 = typeOf (0 :: Word32)-haskellBasicType TInt64 = typeOf (0 :: Int64)-haskellBasicType TUInt64 = typeOf (0 :: Word64)-haskellBasicType TGType = "GType" `con` []-haskellBasicType TUTF8 = "T.Text" `con` []-haskellBasicType TFloat = typeOf (0 :: Float)-haskellBasicType TDouble = typeOf (0 :: Double)-haskellBasicType TUniChar = typeOf ('\0' :: Char)-haskellBasicType TFileName = "[Char]" `con` []-haskellBasicType TIntPtr = "CIntPtr" `con` []-haskellBasicType TUIntPtr = "CUIntPtr" `con` []---- This translates GI types to the types used for generated Haskell code.-haskellType :: Type -> CodeGen TypeRep-haskellType (TBasicType bt) = return $ haskellBasicType bt--- We cannot really do anything sensible for a foreign array with no--- length info, so just pass the pointer along.-haskellType (TCArray False (-1) (-1) t) =- ptr <$> foreignType t-haskellType (TCArray _ _ _ (TBasicType TUInt8)) =- return $ "ByteString" `con` []-haskellType (TCArray _ _ _ a) = do- inner <- haskellType a- return $ "[]" `con` [inner]-haskellType (TGArray a) = do- inner <- haskellType a- return $ "[]" `con` [inner]-haskellType (TPtrArray a) = do- inner <- haskellType a- return $ "[]" `con` [inner]-haskellType (TByteArray) = return $ "ByteString" `con` []-haskellType (TGList a) = do- inner <- haskellType a- return $ "[]" `con` [inner]-haskellType (TGSList a) = do- inner <- haskellType a- return $ "[]" `con` [inner]-haskellType (TGHash a b) = do- innerA <- haskellType a- innerB <- haskellType b- return $ "Map.Map" `con` [innerA, innerB]-haskellType TError = return $ "GError" `con` []-haskellType TVariant = return $ "GVariant" `con` []-haskellType TParamSpec = return $ "GParamSpec" `con` []-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` []- return $ case api of- Just (APIFlags _) -> "[]" `con` [tname]- _ -> tname--foreignBasicType TVoid = ptr (typeOf ())-foreignBasicType TBoolean = "CInt" `con` []-foreignBasicType TUTF8 = "CString" `con` []-foreignBasicType TFileName = "CString" `con` []-foreignBasicType TUniChar = "CInt" `con` []-foreignBasicType TFloat = "CFloat" `con` []-foreignBasicType TDouble = "CDouble" `con` []-foreignBasicType TGType = "CGType" `con` []-foreignBasicType t = haskellBasicType t---- This translates GI types to the types used in foreign function calls.-foreignType :: Type -> CodeGen TypeRep-foreignType (TBasicType t) = return $ foreignBasicType t-foreignType (TCArray False (-1) (-1) t) =- ptr <$> foreignType t-foreignType (TCArray zt _ _ t) = do- api <- findAPI t- let size = case api of- Just (APIStruct s) -> structSize s- Just (APIUnion u) -> unionSize u- _ -> 0- if size == 0 || zt- then ptr <$> foreignType t- else foreignType t-foreignType (TGArray a) = do- inner <- foreignType a- return $ ptr ("GArray" `con` [inner])-foreignType (TPtrArray a) = do- inner <- foreignType a- return $ ptr ("GPtrArray" `con` [inner])-foreignType (TByteArray) = return $ ptr ("GByteArray" `con` [])-foreignType (TGList a) = do- inner <- foreignType a- return $ ptr ("GList" `con` [inner])-foreignType (TGSList a) = do- inner <- foreignType a- return $ ptr ("GSList" `con` [inner])-foreignType (TGHash a b) = do- innerA <- foreignType a- innerB <- foreignType b- return $ ptr ("GHashTable" `con` [innerA, innerB])-foreignType t@TError = ptr <$> haskellType t-foreignType t@TVariant = ptr <$> haskellType t-foreignType t@TParamSpec = ptr <$> haskellType t-foreignType (TInterface "GObject" "Value") = return $ ptr $ "GValue" `con` []-foreignType (TInterface "GObject" "Closure") =- return $ ptr $ "Closure" `con` []-foreignType t@(TInterface ns n) = do- isScalar <- getIsScalar t- 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` []--getIsScalar :: Type -> CodeGen Bool-getIsScalar t = do- a <- findAPI t- case a of- Nothing -> return False- (Just (APIEnum _)) -> return True- (Just (APIFlags _)) -> return True- _ -> return False---- Whether the given type corresponds to a struct we allocate--- ourselves. If we need to allocate the struct we return its size in--- bytes and whether the type is boxed, otherwise we return Nothing.-requiresAlloc :: Type -> CodeGen (Maybe (Bool, Int))-requiresAlloc t = do- api <- findAPI t- case api of- Just (APIStruct s) -> case structSize s of- 0 -> return Nothing- n -> return (Just (structIsBoxed s, n))- _ -> return Nothing---- Returns whether the given type corresponds to a ManagedPtr--- instance (a thin wrapper over a ForeignPtr).-isManaged :: Type -> CodeGen Bool-isManaged t = do- a <- findAPI t- case a of- Just (APIObject _) -> return True- Just (APIInterface _) -> return True- Just (APIStruct _) -> return True- Just (APIUnion _) -> return True- _ -> return False---- Returns whether the given type is nullable in the C sense,--- i.e. whether it can be set to NULL.-isNullable :: Type -> CodeGen Bool-isNullable (TBasicType TVoid) = return True-isNullable (TBasicType TUTF8) = return True-isNullable (TBasicType TFileName) = return True-isNullable t = do- ft <- foreignType t- return (tyConName (typeRepTyCon ft) `elem` ["Ptr", "FunPtr"])---- If the given type maps to a list in Haskell, return the type of the--- elements, and the function that maps over them.-elementTypeAndMap :: Type -> Text -> Maybe (Type, Text)--- Passed along as a raw pointer.-elementTypeAndMap (TCArray False (-1) (-1) _) _ = Nothing--- ByteString-elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing-elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray")-elementTypeAndMap (TCArray False (-1) _ t) len =- Just (t, parenthesize $ "mapCArrayWithLength " <> len)-elementTypeAndMap (TCArray False fixed _ t) _ =- Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed)-elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray")-elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray")-elementTypeAndMap (TGList t) _ = Just (t, "mapGList")-elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList")--- GHashTable is treated separately, see Transfer.hs-elementTypeAndMap _ _ = Nothing---- Return just the element type.-elementType :: Type -> Maybe Type-elementType t = fst <$> elementTypeAndMap t undefined---- Return just the map.-elementMap :: Type -> Text -> Maybe Text-elementMap t len = snd <$> elementTypeAndMap t len
− src/GI/GIR/Alias.hs
@@ -1,40 +0,0 @@-module GI.GIR.Alias- ( documentListAliases- ) where--import qualified Data.Map as M-import Data.Text (Text)-import qualified Data.Text as T-import Text.XML (Element(elementAttributes), Document(documentRoot))--import GI.Type (Type)-import GI.GIR.BasicTypes (Alias(..))-import GI.GIR.Type (parseType)-import GI.GIR.Parser-import GI.GIR.XMLUtils (childElemsWithLocalName)---- | Find all aliases in a given namespace.-namespaceListAliases :: Element -> M.Map Alias Type-namespaceListAliases ns =- case M.lookup "name" (elementAttributes ns) of- Nothing -> error $ "Namespace with no name!"- Just nsName -> case runParser nsName M.empty ns parseAliases of- Left err -> (error . T.unpack) err- Right aliases -> M.fromList (map addNS aliases)- where addNS (n, t) = (Alias (nsName, n), t)---- | Parse all the aliases in the current namespace-parseAliases :: Parser [(Text, Type)]-parseAliases = parseChildrenWithLocalName "alias" parseAlias---- | Parse a single alias-parseAlias :: Parser (Text, Type)-parseAlias = do- name <- getAttr "name"- t <- parseType- return (name, t)---- | Find all aliases in a given document.-documentListAliases :: Document -> M.Map Alias Type-documentListAliases doc = M.unions (map namespaceListAliases namespaces)- where namespaces = childElemsWithLocalName "namespace" (documentRoot doc)
− src/GI/GIR/Arg.hs
@@ -1,81 +0,0 @@-module GI.GIR.Arg- ( Arg(..)- , Direction(..)- , Scope(..)- , parseArg- , parseTransfer- ) where--import Data.Monoid ((<>))-import Data.Text (Text)--import GI.GIR.BasicTypes (Transfer(..))-import GI.GIR.Parser-import GI.GIR.Type (parseType)-import GI.Type (Type)--data Direction = DirectionIn- | DirectionOut- | DirectionInout- deriving (Show, Eq, Ord)--data Scope = ScopeTypeInvalid- | ScopeTypeCall- | ScopeTypeAsync- | ScopeTypeNotified- deriving (Show, Eq, Ord)--data Arg = Arg {- argCName :: Text, -- ^ "C" name for the argument. For a- -- escaped name valid in Haskell code, use- -- `GI.SymbolNaming.escapedArgName`.- argType :: Type,- direction :: Direction,- mayBeNull :: Bool,- argScope :: Scope,- argClosure :: Int,- argDestroy :: Int,- argCallerAllocates :: Bool,- transfer :: Transfer- } deriving (Show, Eq, Ord)--parseTransfer :: Parser Transfer-parseTransfer = getAttr "transfer-ownership" >>= \case- "none" -> return TransferNothing- "container" -> return TransferContainer- "full" -> return TransferEverything- t -> parseError $ "Unknown transfer type \"" <> t <> "\""--parseScope :: Text -> Parser Scope-parseScope "call" = return ScopeTypeCall-parseScope "async" = return ScopeTypeAsync-parseScope "notified" = return ScopeTypeNotified-parseScope s = parseError $ "Unknown scope type \"" <> s <> "\""--parseDirection :: Text -> Parser Direction-parseDirection "in" = return DirectionIn-parseDirection "out" = return DirectionOut-parseDirection "inout" = return DirectionInout-parseDirection d = parseError $ "Unknown direction \"" <> d <> "\""--parseArg :: Parser Arg-parseArg = do- name <- getAttr "name"- ownership <- parseTransfer- scope <- optionalAttr "scope" ScopeTypeInvalid parseScope- d <- optionalAttr "direction" DirectionIn parseDirection- closure <- optionalAttr "closure" (-1) parseIntegral- destroy <- optionalAttr "destroy" (-1) parseIntegral- nullable <- optionalAttr "nullable" False parseBool- callerAllocates <- optionalAttr "caller-allocates" False parseBool- t <- parseType- return $ Arg { argCName = name- , argType = t- , direction = d- , mayBeNull = nullable- , argScope = scope- , argClosure = closure- , argDestroy = destroy- , argCallerAllocates = callerAllocates- , transfer = ownership- }
− src/GI/GIR/BasicTypes.hs
@@ -1,21 +0,0 @@--- | Basic types used in GIR parsing.-module GI.GIR.BasicTypes- ( Name(..)- , Transfer(..)- , Alias(..)- ) where--import Data.Text (Text)---- | Name for a symbol in the GIR file.-data Name = Name { namespace :: Text, name :: Text }- deriving (Eq, Ord, Show)---- | Transfer mode for an argument or property.-data Transfer = TransferNothing- | TransferContainer- | TransferEverything- deriving (Show, Eq, Ord)---- | An alias, which is simply (Namespace, name).-newtype Alias = Alias (Text, Text) deriving (Ord, Eq, Show)
− src/GI/GIR/Callable.hs
@@ -1,58 +0,0 @@-module GI.GIR.Callable- ( Callable(..)- , parseCallable- ) where--import GI.Type (Type)-import GI.GIR.Arg (Arg(..), parseArg, parseTransfer)-import GI.GIR.BasicTypes (Transfer(..))-import GI.GIR.Parser-import GI.GIR.Type (parseType)--data Callable = Callable {- returnType :: Type,- returnMayBeNull :: Bool,- returnTransfer :: Transfer,- args :: [Arg],- skipReturn :: Bool,- callableDeprecated :: Maybe DeprecationInfo- } deriving (Show, Eq)--parseArgs :: Parser [Arg]-parseArgs = do- paramSets <- parseChildrenWithLocalName "parameters" parseArgSet- case paramSets of- [] -> return []- (ps:[]) -> return ps- _ -> parseError $ "Unexpected multiple \"parameters\" tag"- where parseArgSet = parseChildrenWithLocalName "parameter" parseArg--parseOneReturn :: Parser (Type, Bool, Transfer, Bool)-parseOneReturn = do- returnType <- parseType- mayBeNull <- optionalAttr "allow-none" False parseBool- transfer <- parseTransfer- skip <- optionalAttr "skip" False parseBool- return (returnType, mayBeNull, transfer, skip)--parseReturn :: Parser (Type, Bool, Transfer, Bool)-parseReturn = do- returnSets <- parseChildrenWithLocalName "return-value" parseOneReturn- case returnSets of- (r:[]) -> return r- [] -> parseError $ "No return information found"- _ -> parseError $ "Multiple return values found"--parseCallable :: Parser Callable-parseCallable = do- args <- parseArgs- (returnType, mayBeNull, transfer, skip) <- parseReturn- deprecated <- parseDeprecation- return $ Callable {- returnType = returnType- , returnMayBeNull = mayBeNull- , returnTransfer = transfer- , args = args- , skipReturn = skip- , callableDeprecated = deprecated- }
− src/GI/GIR/Callback.hs
@@ -1,17 +0,0 @@--- | Parsing of callbacks.-module GI.GIR.Callback- ( Callback(..)- , parseCallback- ) where--import GI.GIR.Parser-import GI.GIR.Callable (Callable, parseCallable)--data Callback = Callback Callable- deriving Show--parseCallback :: Parser (Name, Callback)-parseCallback = do- name <- parseName- callable <- parseCallable- return (name, Callback callable)
− src/GI/GIR/Constant.hs
@@ -1,27 +0,0 @@--- | Parsing of constants in GIR files.-module GI.GIR.Constant- ( Constant(..)- , parseConstant- ) where--import Data.Text (Text)--import GI.Type (Type)-import GI.GIR.Type (parseType)-import GI.GIR.Parser---- | Info about a constant.-data Constant = Constant {- constantType :: Type,- constantValue :: Text,- constantDeprecated :: Maybe DeprecationInfo- } deriving (Show)---- | Parse a "constant" element from the GIR file.-parseConstant :: Parser (Name, Constant)-parseConstant = do- name <- parseName- deprecated <- parseDeprecation- value <- getAttr "value"- t <- parseType- return (name, Constant t value deprecated)
− src/GI/GIR/Deprecation.hs
@@ -1,43 +0,0 @@-module GI.GIR.Deprecation- ( DeprecationInfo- , deprecatedPragma- , queryDeprecated- ) where--import Data.Monoid ((<>))-import qualified Data.Map as M-import qualified Data.Text as T-import Data.Text (Text)-import Text.XML (Element(elementAttributes))--import GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)---- | Deprecation information on a symbol.-data DeprecationInfo = DeprecationInfo {- deprecatedSinceVersion :: Maybe Text,- deprecationMessage :: Maybe Text- } deriving (Show, Eq)---- | Encode the given `DeprecationInfo` for the given symbol as a--- deprecation pragma.-deprecatedPragma :: Text -> Maybe DeprecationInfo -> Text-deprecatedPragma _ Nothing = ""-deprecatedPragma name (Just info) = "{-# DEPRECATED " <> name <> " " <>- (T.pack . show) (note <> reason) <> "#-}"- where reason = case deprecationMessage info of- Nothing -> []- Just msg -> T.lines msg- note = case deprecatedSinceVersion info of- Nothing -> []- Just v -> ["(Since version " <> v <> ")"]---- | Parse the deprecation information for the given element of the GIR file.-queryDeprecated :: Element -> Maybe DeprecationInfo-queryDeprecated element =- case M.lookup "deprecated" attrs of- Just _ -> let version = M.lookup "deprecated-version" attrs- msg = firstChildWithLocalName "doc-deprecated" element >>=- getElementContent- in Just (DeprecationInfo version msg)- Nothing -> Nothing- where attrs = elementAttributes element
− src/GI/GIR/Documentation.hs
@@ -1,20 +0,0 @@--- | Parsing of documentation nodes.-module GI.GIR.Documentation- ( Documentation(..)- , queryDocumentation- ) where--import Data.Text (Text)-import Text.XML (Element)--import GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)---- | Documentation for a given element.-data Documentation = Documentation {- docText :: Text- } deriving (Show, Eq)---- | Parse the documentation node for the given element of the GIR file.-queryDocumentation :: Element -> Maybe Documentation-queryDocumentation element = fmap Documentation- (firstChildWithLocalName "doc" element >>= getElementContent)
− src/GI/GIR/Enum.hs
@@ -1,52 +0,0 @@--- | Parsing of Enums.-module GI.GIR.Enum- ( Enumeration(..)- , parseEnum- ) where--import Data.Int (Int64)-import Data.Text (Text)-import Foreign.C (CInt(..))--import GI.GIR.Parser--data Enumeration = Enumeration {- enumValues :: [(Text, Int64)],- errorDomain :: Maybe Text,- enumTypeInit :: Maybe Text,- enumStorageBytes :: Int, -- ^ Bytes used for storage of this struct.- enumDeprecated :: Maybe DeprecationInfo }- deriving Show---- | Parse a struct member.-parseEnumMember :: Parser (Text, Int64)-parseEnumMember = do- name <- getAttr "name"- value <- getAttr "value" >>= parseIntegral- return (name, value)--foreign import ccall "_gi_get_enum_storage_bytes" get_storage_bytes ::- Int64 -> Int64 -> CInt---- | Return the number of bytes that should be allocated for storage--- of the given values in an enum.-extractEnumStorageBytes :: [Int64] -> Int-extractEnumStorageBytes values =- fromIntegral $ get_storage_bytes (minimum values) (maximum values)---- | Parse an "enumeration" element from the GIR file.-parseEnum :: Parser (Name, Enumeration)-parseEnum = do- name <- parseName- deprecated <- parseDeprecation- errorDomain <- queryAttrWithNamespace GLibGIRNS "error-domain"- typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"- values <- parseChildrenWithLocalName "member" parseEnumMember- return (name,- Enumeration {- enumValues = values- , errorDomain = errorDomain- , enumTypeInit = typeInit- , enumStorageBytes = extractEnumStorageBytes (map snd values)- , enumDeprecated = deprecated- })
− src/GI/GIR/Field.hs
@@ -1,75 +0,0 @@--- | Parsing of object/struct/union fields.-module GI.GIR.Field- ( Field(..)- , FieldInfoFlag- , parseFields- ) where--import Data.Monoid ((<>))-import Data.Text (Text)--import GI.Type (Type(..))--import GI.GIR.Callback (Callback, parseCallback)-import GI.GIR.Type (parseType)-import GI.GIR.Parser--data Field = Field {- fieldName :: Text,- fieldVisible :: Bool,- fieldType :: Type,- fieldCallback :: Maybe Callback,- fieldOffset :: Int,- fieldFlags :: [FieldInfoFlag],- fieldDeprecated :: Maybe DeprecationInfo }- deriving Show--data FieldInfoFlag = FieldIsReadable | FieldIsWritable- deriving Show---- | Parse a single field in a struct or union. We parse--- non-introspectable fields too (but set fieldVisible = False for--- them), this is necessary since they affect the computation of--- offsets of fields and sizes of containing structs.-parseField :: Parser Field-parseField = do- name <- getAttr "name"- deprecated <- parseDeprecation- readable <- optionalAttr "readable" True parseBool- writable <- optionalAttr "writable" False parseBool- let flags = if readable then [FieldIsReadable] else []- <> if writable then [FieldIsWritable] else []- introspectable <- optionalAttr "introspectable" True parseBool- private <- optionalAttr "private" False parseBool- (t, callback) <-- if introspectable- then do- callbacks <- parseChildrenWithLocalName "callback" parseCallback- (cbn, callback) <- case callbacks of- [] -> return (Nothing, Nothing)- [(n, cb)] -> return (Just n, Just cb)- _ -> parseError "Multiple callbacks in field"- t <- case cbn of- Nothing -> parseType- Just (Name ns n) -> return (TInterface ns n)- return (t, callback)- else do- callbacks <- parseAllChildrenWithLocalName "callback" parseName- case callbacks of- [] -> do- t <- parseType- return (t, Nothing)- [Name ns n] -> return (TInterface ns n, Nothing)- _ -> parseError "Multiple callbacks in field"- return $ Field {- fieldName = name- , fieldVisible = introspectable && not private- , fieldType = t- , fieldCallback = callback- , fieldOffset = error ("unfixed field offset " ++ show name)- , fieldFlags = flags- , fieldDeprecated = deprecated- }--parseFields :: Parser [Field]-parseFields = parseAllChildrenWithLocalName "field" parseField
− src/GI/GIR/Flags.hs
@@ -1,17 +0,0 @@--- | Parsing of bitfields, a.k.a. flags. They are represented in the--- same way as enums, so this is a thin wrapper over that code.-module GI.GIR.Flags- ( Flags(..)- , parseFlags- ) where--import GI.GIR.Enum (Enumeration, parseEnum)-import GI.GIR.Parser--data Flags = Flags Enumeration- deriving Show--parseFlags :: Parser (Name, Flags)-parseFlags = do- (n, enum) <- parseEnum- return (n, Flags enum)
− src/GI/GIR/Function.hs
@@ -1,35 +0,0 @@-module GI.GIR.Function- ( Function(..)- , parseFunction- ) where--import Data.Text (Text)--import GI.GIR.Callable (Callable(..), parseCallable)-import GI.GIR.Parser--data Function = Function {- fnSymbol :: Text- , fnThrows :: Bool- , fnMovedTo :: Maybe Text- , fnCallable :: Callable- } deriving Show--parseFunction :: Parser (Name, Function)-parseFunction = do- name <- parseName- shadows <- queryAttr "shadows"- let exposedName = case shadows of- Just n -> name {name = n}- Nothing -> name- callable <- parseCallable- symbol <- getAttrWithNamespace CGIRNS "identifier"- throws <- optionalAttr "throws" False parseBool- movedTo <- queryAttr "moved-to"- return $ (exposedName,- Function {- fnSymbol = symbol- , fnCallable = callable- , fnThrows = throws- , fnMovedTo = movedTo- })
− src/GI/GIR/Interface.hs
@@ -1,40 +0,0 @@-module GI.GIR.Interface- ( Interface(..)- , parseInterface- ) where--import Data.Text (Text)--import GI.GIR.Method (Method, MethodType(..), parseMethod)-import GI.GIR.Property (Property, parseProperty)-import GI.GIR.Signal (Signal, parseSignal)-import GI.GIR.Parser--data Interface = Interface {- ifTypeInit :: Maybe Text,- ifPrerequisites :: [Name],- ifProperties :: [Property],- ifSignals :: [Signal],- ifMethods :: [Method],- ifDeprecated :: Maybe DeprecationInfo- } deriving Show--parseInterface :: Parser (Name, Interface)-parseInterface = do- name <- parseName- props <- parseChildrenWithLocalName "property" parseProperty- signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal- typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"- methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)- functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)- constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)- deprecated <- parseDeprecation- return (name,- Interface {- ifProperties = props- , ifPrerequisites = error ("unfixed interface " ++ show name)- , ifSignals = signals- , ifTypeInit = typeInit- , ifMethods = constructors ++ methods ++ functions- , ifDeprecated = deprecated- })
− src/GI/GIR/Method.hs
@@ -1,45 +0,0 @@-module GI.GIR.Method- ( Method(..)- , MethodType(..)- , parseMethod- ) where--import Data.Text (Text)--import GI.GIR.Callable (Callable(..), parseCallable)-import GI.GIR.Parser--data MethodType = Constructor -- ^ Constructs an instance of the parent type- | MemberFunction -- ^ A function in the namespace- | OrdinaryMethod -- ^ A function taking the parent- -- instance as first argument.- deriving (Eq, Show)--data Method = Method {- methodName :: Name,- methodSymbol :: Text,- methodThrows :: Bool,- methodType :: MethodType,- methodMovedTo :: Maybe Text,- methodCallable :: Callable- } deriving (Eq, Show)--parseMethod :: MethodType -> Parser Method-parseMethod mType = do- name <- parseName- shadows <- queryAttr "shadows"- let exposedName = case shadows of- Just n -> name {name = n}- Nothing -> name- callable <- parseCallable- symbol <- getAttrWithNamespace CGIRNS "identifier"- throws <- optionalAttr "throws" False parseBool- movedTo <- queryAttr "moved-to"- return $ Method {- methodName = exposedName- , methodSymbol = symbol- , methodThrows = throws- , methodType = mType- , methodMovedTo = movedTo- , methodCallable = callable- }
− src/GI/GIR/Object.hs
@@ -1,52 +0,0 @@--- | Parsing of objects.-module GI.GIR.Object- ( Object(..)- , parseObject- ) where--import Data.Text (Text)--import GI.GIR.Method (Method, parseMethod, MethodType(..))-import GI.GIR.Property (Property, parseProperty)-import GI.GIR.Signal (Signal, parseSignal)-import GI.GIR.Parser--data Object = Object {- objParent :: Maybe Name,- objTypeInit :: Text,- objTypeName :: Text,- objInterfaces :: [Name],- objDeprecated :: Maybe DeprecationInfo,- objDocumentation :: Maybe Documentation,- objMethods :: [Method],- objProperties :: [Property],- objSignals :: [Signal]- } deriving Show--parseObject :: Parser (Name, Object)-parseObject = do- name <- parseName- deprecated <- parseDeprecation- doc <- parseDocumentation- methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)- constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)- functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)- parent <- optionalAttr "parent" Nothing (fmap Just . qualifyName)- interfaces <- parseChildrenWithLocalName "implements" parseName- props <- parseChildrenWithLocalName "property" parseProperty- typeInit <- getAttrWithNamespace GLibGIRNS "get-type"- typeName <- getAttrWithNamespace GLibGIRNS "type-name"- signals <- parseChildrenWithNSName GLibGIRNS "signal" parseSignal- return (name,- Object {- objParent = parent- , objTypeInit = typeInit- , objTypeName = typeName- , objInterfaces = interfaces- , objDeprecated = deprecated- , objDocumentation = doc- , objMethods = constructors ++ methods ++ functions- , objProperties = props- , objSignals = signals- })-
− src/GI/GIR/Parser.hs
@@ -1,239 +0,0 @@--- | The Parser monad.-module GI.GIR.Parser- ( Parser- , ParseError- , parseError-- , runParser-- , parseName- , parseDeprecation- , parseDocumentation- , parseIntegral- , parseBool- , parseChildrenWithLocalName- , parseAllChildrenWithLocalName- , parseChildrenWithNSName-- , getAttr- , getAttrWithNamespace- , queryAttr- , queryAttrWithNamespace- , optionalAttr-- , currentNamespace- , qualifyName- , resolveQualifiedTypeName-- -- Reexported for convenience- , Name(..)- , Element- , GIRXMLNamespace(..)- , DeprecationInfo- , Documentation- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Control.Monad.Except-import Control.Monad.Reader--import Data.Monoid ((<>))-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.Read as TR-import Data.Text (Text)-import qualified Text.XML as XML-import Text.XML (Element(elementAttributes))-import Text.Show.Pretty (ppShow)--import GI.Type (Type(TInterface))--import GI.GIR.BasicTypes (Name(..), Alias(..))-import GI.GIR.Deprecation (DeprecationInfo, queryDeprecated)-import GI.GIR.Documentation (Documentation, queryDocumentation)-import GI.GIR.XMLUtils (localName, GIRXMLNamespace(..),- childElemsWithLocalName, childElemsWithNSName,- lookupAttr, lookupAttrWithNamespace)---- | Info to carry around when parsing.-data ParseContext = ParseContext {- ctxNamespace :: Text,- -- Location in the XML tree of the node being parsed (for- -- debugging purposes).- treePosition :: [Text],- -- Current element being parsed (to be set by withElement)- currentElement :: Element,- knownAliases :: M.Map Alias Type- } deriving Show---- | A message describing a parsing error in human readable form.-type ParseError = Text---- | Monad where parsers live: we carry a context around, and can--- throw errors that abort the parsing.-type Parser a = ReaderT ParseContext (Except ParseError) a---- | Throw a parse error.-parseError :: ParseError -> Parser a-parseError msg = do- ctx <- ask- let position = (T.intercalate " / " . reverse . treePosition) ctx- throwError $ "Error when parsing \"" <> position <> "\": " <> msg <> "\n"- <> (T.pack . ppShow . currentElement) ctx---- | Build a textual description (for debug purposes) of a given element.-elementDescription :: Element -> Text-elementDescription element =- case M.lookup "name" (elementAttributes element) of- Nothing -> localName element- Just n -> localName element <> " [" <> n <> "]"---- | Build a name in the current namespace.-nameInCurrentNS :: Text -> Parser Name-nameInCurrentNS n = do- ctx <- ask- return $ Name (ctxNamespace ctx) n---- | Return the current namespace.-currentNamespace :: Parser Text-currentNamespace = ctxNamespace <$> ask---- | Check whether there is an alias for the given name, and return--- the corresponding type in case it exists, and otherwise a TInterface.-resolveQualifiedTypeName :: Text -> Text -> Parser Type-resolveQualifiedTypeName ns n = do- ctx <- ask- case M.lookup (Alias (ns, n)) (knownAliases ctx) of- -- The resolved type may be an alias itself, like for- -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt- Just (TInterface ns n) -> resolveQualifiedTypeName ns n- Just t -> return t- Nothing -> return $ TInterface ns n---- | Return the value of an attribute for the given element. If the--- attribute is not present this throws an error.-getAttr :: XML.Name -> Parser Text-getAttr attr = do- ctx <- ask- case lookupAttr attr (currentElement ctx) of- Just val -> return val- Nothing -> parseError $ "Expected attribute \"" <>- (T.pack . show) attr <> "\" not present."---- | Like 'getAttr', but allow for specifying the namespace.-getAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser Text-getAttrWithNamespace ns attr = do- ctx <- ask- case lookupAttrWithNamespace ns attr (currentElement ctx) of- Just val -> return val- Nothing -> parseError $ "Expected attribute \"" <>- (T.pack . show) attr <> "\" in namespace \"" <>- (T.pack . show) ns <> "\" not present."---- | Return the value of an attribute if it is present, and Nothing otherwise.-queryAttr :: XML.Name -> Parser (Maybe Text)-queryAttr attr = do- ctx <- ask- return $ lookupAttr attr (currentElement ctx)---- | Like `queryAttr`, but allow for specifying the namespace.-queryAttrWithNamespace :: GIRXMLNamespace -> XML.Name -> Parser (Maybe Text)-queryAttrWithNamespace ns attr = do- ctx <- ask- return $ lookupAttrWithNamespace ns attr (currentElement ctx)---- | Ask for an optional attribute, applying the given parser to--- it. If the argument does not exist return the default value provided.-optionalAttr :: XML.Name -> a -> (Text -> Parser a) -> Parser a-optionalAttr attr def parser =- queryAttr attr >>= \case- Just a -> parser a- Nothing -> return def---- | Build a 'Name' out of the (possibly qualified) supplied name. If--- the supplied name is unqualified we qualify with the current--- namespace, and otherwise we simply parse it.-qualifyName :: Text -> Parser Name-qualifyName n = case T.split (== '.') n of- [ns, name] -> return $ Name ns name- [name] -> nameInCurrentNS name- _ -> parseError "Could not understand name"---- | Get the qualified name for the current element.-parseName :: Parser Name-parseName = getAttr "name" >>= qualifyName---- | Parse the deprecation text, if present.-parseDeprecation :: Parser (Maybe DeprecationInfo)-parseDeprecation = do- ctx <- ask- return $ queryDeprecated (currentElement ctx)---- | Parse the documentation text, if present.-parseDocumentation :: Parser (Maybe Documentation)-parseDocumentation = do- ctx <- ask- return $ queryDocumentation (currentElement ctx)---- | Parse a signed integral number.-parseIntegral :: Integral a => Text -> Parser a-parseIntegral str =- case TR.signed TR.decimal str of- Right (n, r) | T.null r -> return n- _ -> parseError $ "Could not parse integral value: \"" <> str <> "\"."---- | A boolean value given by a numerical constant.-parseBool :: Text -> Parser Bool-parseBool "0" = return False-parseBool "1" = return True-parseBool other = parseError $ "Unsupported boolean value: " <> T.pack (show other)---- | Parse all the introspectable subelements with the given local name.-parseChildrenWithLocalName :: Text -> Parser a -> Parser [a]-parseChildrenWithLocalName n parser = do- ctx <- ask- let introspectableChildren = filter introspectable- (childElemsWithLocalName n (currentElement ctx))- mapM (withElement parser) introspectableChildren- where introspectable :: Element -> Bool- introspectable e = lookupAttr "introspectable" e /= Just "0" &&- lookupAttr "shadowed-by" e == Nothing---- | Parse all subelements with the given local name.-parseAllChildrenWithLocalName :: Text -> Parser a -> Parser [a]-parseAllChildrenWithLocalName n parser = do- ctx <- ask- mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx))---- | Parse all introspectable children with the given namespace and--- local name.-parseChildrenWithNSName :: GIRXMLNamespace -> Text -> Parser a -> Parser [a]-parseChildrenWithNSName ns n parser = do- ctx <- ask- let introspectableChildren = filter introspectable- (childElemsWithNSName ns n (currentElement ctx))- mapM (withElement parser) introspectableChildren- where introspectable :: Element -> Bool- introspectable e = lookupAttr "introspectable" e /= Just "0"---- | Run the given parser for a given subelement in the XML tree.-withElement :: Parser a -> Element -> Parser a-withElement parser element = local modifyParsePosition parser- where modifyParsePosition ctx =- ctx { treePosition = elementDescription element : treePosition ctx- , currentElement = element}---- | Run the given parser, returning either success or an error.-runParser :: Text -> M.Map Alias Type -> Element -> Parser a ->- Either ParseError a-runParser ns aliases element parser =- runExcept (runReaderT parser ctx)- where ctx = ParseContext {- ctxNamespace = ns- , treePosition = [elementDescription element]- , currentElement = element- , knownAliases = aliases- }
− src/GI/GIR/Property.hs
@@ -1,51 +0,0 @@-module GI.GIR.Property- ( Property(..)- , PropertyFlag(..)- , parseProperty- ) where--import Data.Text (Text)-import Data.Monoid ((<>))--import GI.Type (Type)--import GI.GIR.Arg (parseTransfer)-import GI.GIR.BasicTypes (Transfer)-import GI.GIR.Parser-import GI.GIR.Type (parseType)--data PropertyFlag = PropertyReadable- | PropertyWritable- | PropertyConstruct- | PropertyConstructOnly- deriving (Show,Eq)--data Property = Property {- propName :: Text,- propType :: Type,- propFlags :: [PropertyFlag],- propTransfer :: Transfer,- propDeprecated :: Maybe DeprecationInfo- } deriving (Show, Eq)--parseProperty :: Parser Property-parseProperty = do- name <- getAttr "name"- t <- parseType- transfer <- parseTransfer- deprecated <- parseDeprecation- readable <- optionalAttr "readable" True parseBool- writable <- optionalAttr "writable" False parseBool- construct <- optionalAttr "construct" False parseBool- constructOnly <- optionalAttr "construct-only" False parseBool- let flags = (if readable then [PropertyReadable] else [])- <> (if writable then [PropertyWritable] else [])- <> (if construct then [PropertyConstruct] else [])- <> (if constructOnly then [PropertyConstructOnly] else [])- return $ Property {- propName = name- , propType = t- , propFlags = flags- , propTransfer = transfer- , propDeprecated = deprecated- }
− src/GI/GIR/Repository.hs
@@ -1,62 +0,0 @@-module GI.GIR.Repository (readGiRepository) where--import Prelude hiding (readFile)--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Control.Monad (when)-import Data.Maybe-import qualified Data.List as List-import qualified Data.Text as T-import Data.Text (Text)-import Safe (maximumMay)-import Text.XML--import System.Directory-import System.Environment.XDG.BaseDir (getSystemDataDirs)-import System.FilePath--girDataDirs :: IO [FilePath]-girDataDirs = getSystemDataDirs "gir-1.0"--girFilePath :: String -> String -> FilePath -> FilePath-girFilePath name version path = path </> name ++ "-" ++ version <.> "gir"--girFile' :: Text -> Maybe Text -> FilePath -> IO (Maybe FilePath)-girFile' name (Just version) path =- let filePath = girFilePath (T.unpack name) (T.unpack version) path- in doesFileExist filePath >>= \case- True -> return $ Just filePath- False -> return Nothing-girFile' name Nothing path =- doesDirectoryExist path >>= \case- True -> do- repositories <- map takeBaseName <$> getDirectoryContents path- let version = maximumMay . catMaybes $- List.stripPrefix (T.unpack name ++ "-") <$> repositories-- return $ case version of- Just v -> Just $ girFilePath (T.unpack name) v path- Nothing -> Nothing-- False -> return Nothing--girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath)-girFile name version extraPaths = do- dataDirs <- girDataDirs- firstJust <$> (mapM (girFile' name version) (extraPaths ++ dataDirs))- where firstJust = listToMaybe . catMaybes--readGiRepository :: Bool -> Text -> Maybe Text -> [FilePath] -> IO Document-readGiRepository verbose name version extraPaths =- girFile name version extraPaths >>= \case- Just path -> do- when verbose $ putStrLn $ "Loading GI repository: " ++ path- readFile def path- Nothing -> do- dataDirs <- girDataDirs- error $ "Did not find a GI repository for " ++ (T.unpack name)- ++ maybe "" ("-" ++) (T.unpack <$> version)- ++ " in " ++ show dataDirs
− src/GI/GIR/Signal.hs
@@ -1,26 +0,0 @@-module GI.GIR.Signal- ( Signal(..)- , parseSignal- ) where--import Data.Text (Text)--import GI.GIR.Callable (Callable(..), parseCallable)-import GI.GIR.Parser--data Signal = Signal {- sigName :: Text,- sigCallable :: Callable,- sigDeprecated :: Maybe DeprecationInfo- } deriving (Show, Eq)--parseSignal :: Parser Signal-parseSignal = do- n <- getAttr "name"- deprecated <- parseDeprecation- callable <- parseCallable- return $ Signal {- sigName = n- , sigCallable = callable- , sigDeprecated = deprecated- }
− src/GI/GIR/Struct.hs
@@ -1,51 +0,0 @@--- | Parsing of structs.-module GI.GIR.Struct- ( Struct(..)- , parseStruct- ) where--import Data.Text (Text)--import GI.GIR.Field (Field, parseFields)-import GI.GIR.Method (Method, MethodType(..), parseMethod)-import GI.GIR.Parser--data Struct = Struct {- structIsBoxed :: Bool,- structTypeInit :: Maybe Text,- structSize :: Int,- gtypeStructFor :: Maybe Name,- -- https://bugzilla.gnome.org/show_bug.cgi?id=560248- structIsDisguised :: Bool,- structFields :: [Field],- structMethods :: [Method],- structDeprecated :: Maybe DeprecationInfo,- structDocumentation :: Maybe Documentation }- deriving Show--parseStruct :: Parser (Name, Struct)-parseStruct = do- name <- parseName- deprecated <- parseDeprecation- doc <- parseDocumentation- structFor <- queryAttrWithNamespace GLibGIRNS "is-gtype-struct-for" >>= \case- Just t -> (fmap Just . qualifyName) t- Nothing -> return Nothing- typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"- disguised <- optionalAttr "disguised" False parseBool- fields <- parseFields- constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)- methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)- functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)- return (name,- Struct {- structIsBoxed = error ("[boxed] unfixed struct " ++ show name)- , structTypeInit = typeInit- , structSize = error ("[size] unfixed struct " ++ show name)- , gtypeStructFor = structFor- , structIsDisguised = disguised- , structFields = fields- , structMethods = constructors ++ methods ++ functions- , structDeprecated = deprecated- , structDocumentation = doc- })
− src/GI/GIR/Type.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards #-}--- | Parsing type information from GIR files.-module GI.GIR.Type- ( parseType- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif--import Data.Monoid ((<>))-import Data.Text (Text)-import qualified Data.Text as T-import Foreign.Storable (sizeOf)-import Foreign.C (CShort, CUShort, CInt, CUInt, CLong, CULong, CSize)-import System.Posix.Types (CSsize)--import GI.Type (Type(..), BasicType(..))-import GI.GIR.Parser---- | Map the given type name to a BasicType (in GI.Type), if possible.-nameToBasicType :: Text -> Maybe BasicType-nameToBasicType "none" = Just TVoid--- XXX Should we try to distinguish TPtr from TVoid?-nameToBasicType "gpointer" = Just TVoid-nameToBasicType "gboolean" = Just TBoolean-nameToBasicType "gchar" = Just TInt8-nameToBasicType "gint8" = Just TInt8-nameToBasicType "guint8" = Just TUInt8-nameToBasicType "gint16" = Just TInt16-nameToBasicType "guint16" = Just TUInt16-nameToBasicType "gint32" = Just TInt32-nameToBasicType "guint32" = Just TUInt32-nameToBasicType "gint64" = Just TInt64-nameToBasicType "guint64" = Just TUInt64-nameToBasicType "gfloat" = Just TFloat-nameToBasicType "gdouble" = Just TDouble-nameToBasicType "gunichar" = Just TUniChar-nameToBasicType "GType" = Just TGType-nameToBasicType "utf8" = Just TUTF8-nameToBasicType "filename" = Just TFileName-nameToBasicType "gintptr" = Just TIntPtr-nameToBasicType "guintptr" = Just TUIntPtr-nameToBasicType "gshort" = case sizeOf (0 :: CShort) of- 2 -> Just TInt16- 4 -> Just TInt32- 8 -> Just TInt64- n -> error $ "Unexpected short size: " ++ show n-nameToBasicType "gushort" = case sizeOf (0 :: CUShort) of- 2 -> Just TUInt16- 4 -> Just TUInt32- 8 -> Just TUInt64- n -> error $ "Unexpected ushort size: " ++ show n-nameToBasicType "gint" = case sizeOf (0 :: CInt) of- 4 -> Just TInt32- 8 -> Just TInt64- n -> error $ "Unexpected int length: " ++ show n-nameToBasicType "guint" = case sizeOf (0 :: CUInt) of- 4 -> Just TUInt32- 8 -> Just TUInt64- n -> error $ "Unexpected uint length: " ++ show n-nameToBasicType "glong" = case sizeOf (0 :: CLong) of- 4 -> Just TInt32- 8 -> Just TInt64- n -> error $ "Unexpected long length: " ++ show n-nameToBasicType "gulong" = case sizeOf (0 :: CULong) of- 4 -> Just TUInt32- 8 -> Just TUInt64- n -> error $ "Unexpected ulong length: " ++ show n-nameToBasicType "gssize" = case sizeOf (0 :: CSsize) of- 4 -> Just TInt32- 8 -> Just TInt64- n -> error $ "Unexpected ssize length: " ++ show n-nameToBasicType "gsize" = case sizeOf (0 :: CSize) of- 4 -> Just TUInt32- 8 -> Just TUInt64- n -> error $ "Unexpected size length: " ++ show n-nameToBasicType _ = Nothing---- | The different array types.-parseArrayInfo :: Parser Type-parseArrayInfo = queryAttr "name" >>= \case- Just "GLib.Array" -> TGArray <$> parseType- Just "GLib.PtrArray" -> TPtrArray <$> parseType- Just "GLib.ByteArray" -> return TByteArray- Just other -> parseError $ "Unsupported array type: \"" <> other <> "\""- Nothing -> parseCArrayType---- | A C array-parseCArrayType :: Parser Type-parseCArrayType = do- zeroTerminated <- queryAttr "zero-terminated" >>= \case- Just b -> parseBool b- Nothing -> return True- length <- queryAttr "length" >>= \case- Just l -> parseIntegral l- Nothing -> return (-1)- fixedSize <- queryAttr "fixed-size" >>= \case- Just s -> parseIntegral s- Nothing -> return (-1)- elementType <- parseType- return $ TCArray zeroTerminated fixedSize length elementType---- | A hash table.-parseHashTable :: Parser Type-parseHashTable = parseTypeElements >>= \case- [key, value] -> return $ TGHash key value- other -> parseError $ "Unsupported hash type: "- <> T.pack (show other)---- | For GLists and GSLists there is sometimes no information about--- the type of the elements. In these cases we report them as--- pointers.-parseListType :: Parser Type-parseListType = queryType >>= \case- Just t -> return t- Nothing -> return (TBasicType TVoid)---- | A type which is not a BasicType or array.-parseFundamentalType :: Text -> Text -> Parser Type-parseFundamentalType "GLib" "List" = TGList <$> parseListType-parseFundamentalType "GLib" "SList" = TGSList <$> parseListType-parseFundamentalType "GLib" "HashTable" = parseHashTable-parseFundamentalType "GLib" "Error" = return TError-parseFundamentalType "GLib" "Variant" = return TVariant-parseFundamentalType "GObject" "ParamSpec" = return TParamSpec--- A TInterface type (basically, everything that is not of a known type).-parseFundamentalType ns n = resolveQualifiedTypeName ns n---- | Parse information on a "type" element.-parseTypeInfo :: Parser Type-parseTypeInfo = do- typeName <- getAttr "name"- case nameToBasicType typeName of- Just b -> return (TBasicType b)- Nothing -> case T.split ('.' ==) typeName of- [ns, n] -> parseFundamentalType ns n- [n] -> do- ns <- currentNamespace- parseFundamentalType ns n- _ -> parseError $ "Unsupported type form: \""- <> typeName <> "\""---- | Find the children giving the type of the given element.-parseTypeElements :: Parser [Type]-parseTypeElements = (++) <$> parseChildrenWithLocalName "type" parseTypeInfo <*>- parseChildrenWithLocalName "array" parseArrayInfo---- | Try to find a type node, but do not error out if it is not--- found. This _does_ give an error if more than one type node is--- found.-queryType :: Parser (Maybe Type)-queryType = parseTypeElements >>= \case- [e] -> return (Just e)- [] -> return Nothing- _ -> parseError $ "Found more than one type for the element."---- | Parse the type of a node (which will be described by a child node--- named "type" or "array").-parseType :: Parser Type-parseType = parseTypeElements >>= \case- [e] -> return e- [] -> parseError $ "Did not find a type for the element."- _ -> parseError $ "Found more than one type for the element."
− src/GI/GIR/Union.hs
@@ -1,41 +0,0 @@--- | Parsing of unions.-module GI.GIR.Union- ( Union(..)- , parseUnion- ) where--import Data.Maybe (isJust)-import Data.Text (Text)--import GI.GIR.Field (Field, parseFields)-import GI.GIR.Method (Method, MethodType(..), parseMethod)-import GI.GIR.Parser--data Union = Union {- unionIsBoxed :: Bool,- unionSize :: Int,- unionTypeInit :: Maybe Text,- unionFields :: [Field],- unionMethods :: [Method],- unionDeprecated :: Maybe DeprecationInfo }- deriving Show--parseUnion :: Parser (Name, Union)-parseUnion = do- name <- parseName- deprecated <- parseDeprecation- typeInit <- queryAttrWithNamespace GLibGIRNS "get-type"- fields <- parseFields- constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor)- methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod)- functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)- return (name,- Union {- unionIsBoxed = isJust typeInit- , unionTypeInit = typeInit- , unionSize = error ("unfixed union size " ++ show name)- , unionFields = fields- , unionMethods = constructors ++ methods ++ functions- , unionDeprecated = deprecated- })-
− src/GI/GIR/XMLUtils.hs
@@ -1,79 +0,0 @@--- | Some helpers for making traversals of GIR documents easier.-module GI.GIR.XMLUtils- ( nodeToElement- , subelements- , localName- , lookupAttr- , GIRXMLNamespace(..)- , lookupAttrWithNamespace- , childElemsWithLocalName- , childElemsWithNSName- , firstChildWithLocalName- , getElementContent- ) where--import Text.XML (Element(elementNodes, elementName, elementAttributes),- Node(NodeContent, NodeElement), nameLocalName, Name(..))-import Data.Maybe (mapMaybe, listToMaybe)-import qualified Data.Map as M-import Data.Text (Text)---- | Turn a node into an element (if it is indeed an element node).-nodeToElement :: Node -> Maybe Element-nodeToElement (NodeElement e) = Just e-nodeToElement _ = Nothing---- | Find all children of the given element which are XML Elements--- themselves.-subelements :: Element -> [Element]-subelements = mapMaybe nodeToElement . elementNodes---- | The local name of an element.-localName :: Element -> Text-localName = nameLocalName . elementName---- | Restrict to those with the given local name.-childElemsWithLocalName :: Text -> Element -> [Element]-childElemsWithLocalName n =- filter localNameMatch . subelements- where localNameMatch = (== n) . localName---- | Restrict to those with given name.-childElemsWithNSName :: GIRXMLNamespace -> Text -> Element -> [Element]-childElemsWithNSName ns n = filter nameMatch . subelements- where nameMatch = (== name) . elementName- name = Name {- nameLocalName = n- , nameNamespace = Just (girNamespace ns)- , namePrefix = Nothing- }---- | Find the first child element with the given name.-firstChildWithLocalName :: Text -> Element -> Maybe Element-firstChildWithLocalName n = listToMaybe . childElemsWithLocalName n---- | Get the content of a given element, if it exists.-getElementContent :: Element -> Maybe Text-getElementContent = listToMaybe . mapMaybe getContent . elementNodes- where getContent :: Node -> Maybe Text- getContent (NodeContent t) = Just t- getContent _ = Nothing---- | Lookup an attribute for an element (with no prefix).-lookupAttr :: Name -> Element -> Maybe Text-lookupAttr attr element = M.lookup attr (elementAttributes element)---- | GIR namespaces we know about.-data GIRXMLNamespace = GLibGIRNS | CGIRNS- deriving Show---- | Return the text representation of the known GIR namespaces.-girNamespace :: GIRXMLNamespace -> Text-girNamespace GLibGIRNS = "http://www.gtk.org/introspection/glib/1.0"-girNamespace CGIRNS = "http://www.gtk.org/introspection/c/1.0"---- | Lookup an attribute for an element, given the namespace where it lives.-lookupAttrWithNamespace :: GIRXMLNamespace -> Name -> Element -> Maybe Text-lookupAttrWithNamespace ns attr element =- let attr' = attr {nameNamespace = Just (girNamespace ns)}- in M.lookup attr' (elementAttributes element)
− src/GI/GObject.hs
@@ -1,52 +0,0 @@-module GI.GObject- ( isGObject- , apiIsGObject- , nameIsGObject- , isInitiallyUnowned- , apiIsInitiallyUnowned- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import GI.API-import GI.Code-import GI.Type---- Returns whether the given type is a descendant of the given parent.-typeDoParentSearch :: Name -> Type -> CodeGen Bool-typeDoParentSearch parent (TInterface ns n) = findAPIByName name >>=- apiDoParentSearch parent name- where name = Name ns n-typeDoParentSearch _ _ = return False--apiDoParentSearch :: Name -> Name -> API -> CodeGen Bool-apiDoParentSearch parent n api- | parent == n = return True- | otherwise = case api of- APIObject o ->- case objParent o of- Just (Name pns pn) -> typeDoParentSearch parent (TInterface pns pn)- Nothing -> return False- APIInterface iface ->- do let prs = ifPrerequisites iface- prereqs <- zip prs <$> mapM findAPIByName prs- or <$> mapM (uncurry (apiDoParentSearch parent)) prereqs- _ -> return False--isGObject :: Type -> CodeGen Bool-isGObject = typeDoParentSearch $ Name "GObject" "Object"---- | Check whether the given name descends from GObject.-nameIsGObject :: Name -> CodeGen Bool-nameIsGObject n = findAPIByName n >>= apiIsGObject n--apiIsGObject :: Name -> API -> CodeGen Bool-apiIsGObject = apiDoParentSearch $ Name "GObject" "Object"--isInitiallyUnowned :: Type -> CodeGen Bool-isInitiallyUnowned = typeDoParentSearch $ Name "GObject" "InitiallyUnowned"--apiIsInitiallyUnowned :: Name -> API -> CodeGen Bool-apiIsInitiallyUnowned = apiDoParentSearch $ Name "GObject" "InitiallyUnowned"
− src/GI/GType.hsc
@@ -1,24 +0,0 @@-module GI.GType- ( GType -- Reexport from Data.GI.Base.BasicTypes for convenience- , gtypeIsA- , gtypeIsBoxed- ) where--#include <glib-object.h>--import Foreign.C-import System.IO.Unsafe (unsafePerformIO)-import Data.GI.Base.BasicTypes (CGType, GType(..))--foreign import ccall unsafe "g_type_is_a" g_type_is_a ::- CGType -> CGType -> IO CInt--gtypeIsA :: GType -> GType -> Bool-gtypeIsA (GType gtype) (GType is_a) = (/= 0) $- unsafePerformIO $ g_type_is_a gtype is_a--gtypeBoxed :: GType-gtypeBoxed = GType #const G_TYPE_BOXED--gtypeIsBoxed :: GType -> Bool-gtypeIsBoxed gtype = gtypeIsA gtype gtypeBoxed
− src/GI/Inheritance.hs
@@ -1,163 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module GI.Inheritance- ( fullObjectPropertyList- , fullInterfacePropertyList- , fullObjectSignalList- , fullInterfaceSignalList- , fullObjectMethodList- , fullInterfaceMethodList- , instanceTree- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif-import Control.Monad (foldM, when)-import qualified Data.Map as M-import Data.Text (Text)--import GI.API-import GI.Code (findAPIByName, CodeGen, line, (<>))-import GI.Util (tshow)---- | Find the parent of a given object when building the--- instanceTree. For the purposes of the binding we do not need to--- distinguish between GObject.Object and GObject.InitiallyUnowned.-getParent :: API -> Maybe Name-getParent (APIObject o) = rename $ objParent o- where- rename :: Maybe Name -> Maybe Name- rename (Just (Name "GObject" "InitiallyUnowned")) =- Just (Name "GObject" "Object")- rename x = x-getParent _ = Nothing---- | Compute the (ordered) list of parents of the current object.-instanceTree :: Name -> CodeGen [Name]-instanceTree n = do- api <- findAPIByName n- case getParent api of- Just p -> (p :) <$> instanceTree p- Nothing -> return []---- A class for qualities of an object/interface that it inherits from--- its ancestors. Properties and Signals are two classes of interest.-class Inheritable i where- ifInheritables :: Interface -> [i]- objInheritables :: Object -> [i]- iName :: i -> Text--instance Inheritable Property where- ifInheritables = ifProperties- objInheritables = objProperties- iName = propName--instance Inheritable Signal where- ifInheritables = ifSignals- objInheritables = objSignals- iName = sigName--instance Inheritable Method where- ifInheritables = ifMethods- objInheritables = objMethods- iName = name . methodName---- Returns a list of all inheritables defined for this object--- (including those defined by its ancestors and the interfaces it--- implements), together with the name of the interface defining the--- property.-apiInheritables :: Inheritable i => Name -> CodeGen [(Name, i)]-apiInheritables n = do- api <- findAPIByName n- case api of- APIInterface iface -> return $ map ((,) n) (ifInheritables iface)- APIObject object -> return $ map ((,) n) (objInheritables object)- _ -> error $ "apiInheritables : Unexpected API : " ++ show n--fullAPIInheritableList :: Inheritable i => Name -> CodeGen [(Name, i)]-fullAPIInheritableList n = do- api <- findAPIByName n- case api of- APIInterface iface -> fullInterfaceInheritableList n iface- APIObject object -> fullObjectInheritableList n object- _ -> error $ "FullAPIInheritableList : Unexpected API : " ++ show n--fullObjectInheritableList :: Inheritable i => Name -> Object ->- CodeGen [(Name, i)]-fullObjectInheritableList n obj = do- iT <- instanceTree n- (++) <$> (concat <$> mapM apiInheritables (n : iT))- <*> (concat <$> mapM apiInheritables (objInterfaces obj))--fullInterfaceInheritableList :: Inheritable i => Name -> Interface ->- CodeGen [(Name, i)]-fullInterfaceInheritableList n iface =- (++) (map ((,) n) (ifInheritables iface))- <$> (concat <$> mapM fullAPIInheritableList (ifPrerequisites iface))---- It is sometimes the case that a property name or signal is defined--- both in an object and in one of its ancestors/implemented--- interfaces. This is harmless if the properties are isomorphic--- (there will be more than one qualified set of property--- setters/getters that we can call, but they are all isomorphic). If--- they are not isomorphic we refuse to set either, and print a--- warning in the generated code.-removeDuplicates :: forall i. (Eq i, Show i, Inheritable i) =>- Bool -> [(Name, i)] -> CodeGen [(Name, i)]-removeDuplicates verbose inheritables =- (filterTainted . M.toList) <$> foldM filterDups M.empty inheritables- where- filterDups :: M.Map Text (Bool, Name, i) -> (Name, i) ->- CodeGen (M.Map Text (Bool, Name, i))- filterDups m (name, prop) =- case M.lookup (iName prop) m of- Just (tainted, n, p)- | tainted -> return m- | (p == prop) -> return m -- Duplicated, but isomorphic property- | otherwise ->- do when verbose $ do- line "--- XXX Duplicated object with different types:"- line $ " --- " <> tshow n <> " -> " <> tshow p- line $ " --- " <> tshow name <> " -> " <> tshow prop- -- Tainted- return $ M.insert (iName prop) (True, n, p) m- Nothing -> return $ M.insert (iName prop) (False, name, prop) m- filterTainted :: [(Text, (Bool, Name, i))] -> [(Name, i)]- filterTainted xs =- [(name, prop) | (_, (tainted, name, prop)) <- xs, not tainted]---- | List all properties defined for an object, including those--- defined by its ancestors.-fullObjectPropertyList :: Name -> Object -> CodeGen [(Name, Property)]-fullObjectPropertyList n o = fullObjectInheritableList n o >>=- removeDuplicates True---- | List all properties defined for an interface, including those--- defined by its prerequisites.-fullInterfacePropertyList :: Name -> Interface -> CodeGen [(Name, Property)]-fullInterfacePropertyList n i = fullInterfaceInheritableList n i >>=- removeDuplicates True---- | List all signals defined for an object, including those--- defined by its ancestors.-fullObjectSignalList :: Name -> Object -> CodeGen [(Name, Signal)]-fullObjectSignalList n o = fullObjectInheritableList n o >>=- removeDuplicates True---- | List all signals defined for an interface, including those--- defined by its prerequisites.-fullInterfaceSignalList :: Name -> Interface -> CodeGen [(Name, Signal)]-fullInterfaceSignalList n i = fullInterfaceInheritableList n i >>=- removeDuplicates True---- | List all methods defined for an object, including those defined--- by its ancestors.-fullObjectMethodList :: Name -> Object -> CodeGen [(Name, Method)]-fullObjectMethodList n o = fullObjectInheritableList n o >>=- removeDuplicates False---- | List all methods defined for an interface, including those--- defined by its prerequisites.-fullInterfaceMethodList :: Name -> Interface -> CodeGen [(Name, Method)]-fullInterfaceMethodList n i = fullInterfaceInheritableList n i >>=- removeDuplicates False
− src/GI/LibGIRepository.hs
@@ -1,150 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | A minimal wrapper for libgirepository.-module GI.LibGIRepository- ( girRequire- , girStructSizeAndOffsets- , girUnionSizeAndOffsets- , girLoadGType- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--import Control.Monad (forM, when)-import qualified Data.Map as M-import Data.Text (Text)-import qualified Data.Text as T--import Foreign.C.Types (CInt(..), CSize(..))-import Foreign.C.String (CString)-import Foreign (nullPtr, Ptr, ForeignPtr, FunPtr, peek)--import Data.GI.Base.BasicConversions (withTextCString, cstringToText)-import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType)-import Data.GI.Base.GError (GError, checkGError)-import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)-import Data.GI.Base.Utils (allocMem, freeMem)---- | Wrapper for 'GIBaseInfo'-newtype BaseInfo = BaseInfo (ForeignPtr BaseInfo)---- | Wrapper for 'GITypelib'-newtype Typelib = Typelib (Ptr Typelib)--foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType--instance BoxedObject BaseInfo where- boxedType _ = c_g_base_info_gtype_get_type--foreign import ccall "g_irepository_require" g_irepository_require ::- Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError)- -> IO (Ptr Typelib)---- | Ensure that the given version of the namespace is loaded. If that--- is not possible we error out.-girRequire :: Text -> Text -> IO Typelib-girRequire ns version =- withTextCString ns $ \cns ->- withTextCString version $ \cversion -> do- typelib <- checkGError (g_irepository_require nullPtr cns cversion 0)- (error $ "Could not load typelib for "- ++ show ns ++ " version "- ++ show version)- return (Typelib typelib)--foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name ::- Ptr () -> CString -> CString -> IO (Ptr BaseInfo)---- | Find a given baseinfo by name, or give an error if it cannot be--- found.-girFindByName :: Text -> Text -> IO BaseInfo-girFindByName ns name =- withTextCString ns $ \cns ->- withTextCString name $ \cname -> do- ptr <- g_irepository_find_by_name nullPtr cns cname- if ptr == nullPtr- then error ("Could not find " ++ T.unpack ns ++ "::" ++ T.unpack name)- else wrapBoxed BaseInfo ptr--foreign import ccall "g_field_info_get_offset" g_field_info_get_offset ::- Ptr BaseInfo -> IO CInt-foreign import ccall "g_base_info_get_name" g_base_info_get_name ::- Ptr BaseInfo -> IO CString--foreign import ccall "g_struct_info_get_size" g_struct_info_get_size ::- Ptr BaseInfo -> IO CSize-foreign import ccall "g_struct_info_get_n_fields" g_struct_info_get_n_fields ::- Ptr BaseInfo -> IO CInt-foreign import ccall "g_struct_info_get_field" g_struct_info_get_field ::- Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)---- | Find out the size of a struct, and the map from field names to--- offsets inside the struct.-girStructSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)-girStructSizeAndOffsets ns name = do- baseinfo <- girFindByName ns name- withManagedPtr baseinfo $ \si -> do- size <- g_struct_info_get_size si- nfields <- g_struct_info_get_n_fields si- fieldOffsets <- forM [0..(nfields-1)] $ \i -> do- fieldInfo <- (g_struct_info_get_field si i- >>= wrapBoxed BaseInfo)- withManagedPtr fieldInfo $ \fi -> do- fname <- (g_base_info_get_name fi >>= cstringToText)- fOffset <- g_field_info_get_offset fi- return (fname, fromIntegral fOffset)- return (fromIntegral size, M.fromList fieldOffsets)--foreign import ccall "g_union_info_get_size" g_union_info_get_size ::- Ptr BaseInfo -> IO CSize-foreign import ccall "g_union_info_get_n_fields" g_union_info_get_n_fields ::- Ptr BaseInfo -> IO CInt-foreign import ccall "g_union_info_get_field" g_union_info_get_field ::- Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)---- | Find out the size of a union, and the map from field names to--- offsets inside the union.-girUnionSizeAndOffsets :: Text -> Text -> IO (Int, M.Map Text Int)-girUnionSizeAndOffsets ns name = do- baseinfo <- girFindByName ns name- withManagedPtr baseinfo $ \ui -> do- size <- g_union_info_get_size ui- nfields <- g_union_info_get_n_fields ui- fieldOffsets <- forM [0..(nfields-1)] $ \i -> do- fieldInfo <- (g_union_info_get_field ui i- >>= wrapBoxed BaseInfo)- withManagedPtr fieldInfo $ \fi -> do- fname <- (g_base_info_get_name fi >>= cstringToText)- fOffset <- g_field_info_get_offset fi- return (fname, fromIntegral fOffset)- return (fromIntegral size, M.fromList fieldOffsets)--foreign import ccall "g_typelib_symbol" g_typelib_symbol ::- Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt---- | Load a symbol from the dynamic library associated to the given namespace.-girSymbol :: forall a. Text -> Text -> IO (FunPtr a)-girSymbol ns symbol = do- typelib <- withTextCString ns $ \cns ->- checkGError (g_irepository_require nullPtr cns nullPtr 0)- (error $ "Could not load typelib " ++ show ns)- funPtrPtr <- allocMem :: IO (Ptr (FunPtr a))- result <- withTextCString symbol $ \csymbol ->- g_typelib_symbol typelib csymbol funPtrPtr- when (result /= 1) $- error ("Could not resolve symbol " ++ show symbol ++ " in namespace "- ++ show ns)- funPtr <- peek funPtrPtr- freeMem funPtrPtr- return funPtr--type GTypeInit = IO CGType-foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit---- | Load a GType given the namespace where it lives and the type init--- function.-girLoadGType :: Text -> Text -> IO GType-girLoadGType ns typeInit = do- funPtr <- girSymbol ns typeInit- GType <$> gtypeInit funPtr
− src/GI/OverloadedLabels.hs
@@ -1,84 +0,0 @@-module GI.OverloadedLabels- ( genOverloadedLabels- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Data.Maybe (isNothing)-import Control.Monad (forM_)-import qualified Data.Set as S-import Data.Text (Text)--import GI.API-import GI.Code-import GI.SymbolNaming-import GI.Util (lcFirst)---- | A list of all overloadable identifiers in the set of APIs (current--- properties and methods).-findOverloaded :: [(Name, API)] -> CodeGen [Text]-findOverloaded apis = S.toList <$> go apis S.empty- where- go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)- go [] set = return set- go ((_, api):apis) set =- case api of- APIInterface iface -> go apis (scanInterface iface set)- APIObject object -> go apis (scanObject object set)- APIStruct s -> go apis (scanStruct s set)- APIUnion u -> go apis (scanUnion u set)- _ -> go apis set-- scanObject :: Object -> S.Set Text -> S.Set Text- scanObject o set =- let props = (map propToLabel . objProperties) o- methods = (map methodToLabel . filterMethods . objMethods) o- in S.unions [set, S.fromList props, S.fromList methods]-- scanInterface :: Interface -> S.Set Text -> S.Set Text- scanInterface i set =- let props = (map propToLabel . ifProperties) i- methods = (map methodToLabel . filterMethods . ifMethods) i- in S.unions [set, S.fromList props, S.fromList methods]-- scanStruct :: Struct -> S.Set Text -> S.Set Text- scanStruct s set =- let methods = (map methodToLabel . filterMethods . structMethods) s- in S.unions [set, S.fromList methods]-- scanUnion :: Union -> S.Set Text -> S.Set Text- scanUnion u set =- let methods = (map methodToLabel . filterMethods . unionMethods) u- in S.unions [set, S.fromList methods]-- propToLabel :: Property -> Text- propToLabel = lcFirst . hyphensToCamelCase . propName-- methodToLabel :: Method -> Text- methodToLabel = lowerName . methodName-- filterMethods :: [Method] -> [Method]- filterMethods = filter (\m -> (isNothing . methodMovedTo) m &&- methodType m == OrdinaryMethod)--genOverloadedLabel :: Text -> CodeGen ()-genOverloadedLabel l = group $ do- line $ "_" <> l <> " :: IsLabelProxy \"" <> l <> "\" a => a"- line $ "_" <> l <> " = fromLabelProxy (Proxy :: Proxy \""- <> l <> "\")"- exportToplevel ("_" <> l)--genOverloadedLabels :: [(Name, API)] -> CodeGen ()-genOverloadedLabels allAPIs = do- setLanguagePragmas ["DataKinds", "FlexibleContexts"]- setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]-- line $ "import Data.Proxy (Proxy(..))"- line $ "import Data.GI.Base.Overloading (IsLabelProxy(..))"- blank-- labels <- findOverloaded allAPIs- forM_ labels $ \l -> do- genOverloadedLabel l- blank
− src/GI/OverloadedMethods.hs
@@ -1,106 +0,0 @@-module GI.OverloadedMethods- ( genMethodList- , genMethodInfo- , genUnsupportedMethodInfo- ) where--import Control.Monad (forM, forM_, when)-import Data.Text (Text)-import qualified Data.Text as T--import GI.API-import GI.Callable (callableSignature, fixupCallerAllocates)-import GI.Code-import GI.SymbolNaming (lowerName, upperName)-import GI.Util (ucFirst)---- | Qualified name for the info for a given method.-methodInfoName :: Name -> Method -> CodeGen Text-methodInfoName n method = do- n' <- upperName n- let mn' = (ucFirst . lowerName . methodName) method- return $ n' <> mn' <> "MethodInfo"---- | Appropriate instances so overloaded labels are properly resolved.-genMethodResolver :: Text -> CodeGen ()-genMethodResolver n = do- group $ do- line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "- <> "MethodInfo info " <> n <> " p) => IsLabelProxy t ("- <> n <> " -> p) where"- indent $ line $ "fromLabelProxy _ = overloadedMethod (MethodProxy :: MethodProxy info)"- group $ do- line $ "#if MIN_VERSION_base(4,9,0)"- line $ "instance (info ~ Resolve" <> n <> "Method t " <> n <> ", "- <> "MethodInfo info " <> n <> " p) => IsLabel t ("- <> n <> " -> p) where"- indent $ line $ "fromLabel _ = overloadedMethod (MethodProxy :: MethodProxy info)"- line $ "#endif"---- | Generate the `MethodList` instance given the list of methods for--- the given named type.-genMethodList :: Name -> [(Name, Method)] -> CodeGen ()-genMethodList n methods = do- name <- upperName n- let filteredMethods = filter isOrdinaryMethod methods- gets = filter isGet filteredMethods- sets = filter isSet filteredMethods- others = filter (\m -> not (isSet m || isGet m)) filteredMethods- orderedMethods = others ++ gets ++ sets- infos <- forM orderedMethods $ \(owner, method) ->- do mi <- methodInfoName owner method- return ((lowerName . methodName) method, mi)- group $ do- let resolver = "Resolve" <> name <> "Method"- line $ "type family " <> resolver <> " (t :: Symbol) (o :: *) :: * where"- indent $ forM_ infos $ \(label, info) -> do- line $ resolver <> " \"" <> label <> "\" o = " <> info- indent $ line $ resolver <> " l o = MethodResolutionFailed l o"-- genMethodResolver name-- where isOrdinaryMethod :: (Name, Method) -> Bool- isOrdinaryMethod (_, m) = methodType m == OrdinaryMethod-- isGet :: (Name, Method) -> Bool- isGet (_, m) = "get_" `T.isPrefixOf` (name . methodName) m-- isSet :: (Name, Method) -> Bool- isSet (_, m) = "set_" `T.isPrefixOf` (name . methodName) m---- | Generate the `MethodInfo` type and instance for the given method.-genMethodInfo :: Name -> Method -> ExcCodeGen ()-genMethodInfo n m =- when (methodType m == OrdinaryMethod) $- group $ do- infoName <- methodInfoName n m- let callable = fixupCallerAllocates (methodCallable m)- (constraints, types) <- callableSignature callable (methodThrows m)- bline $ "data " <> infoName- -- This should not happen, since ordinary methods always- -- have the instance as first argument.- when (null types) $- error $ "Internal error: too few parameters! " ++ show m- let (obj:otherTypes) = map fst types- sigConstraint = "signature ~ (" <> T.intercalate " -> " otherTypes- <> ")"- line $ "instance (" <> T.intercalate ", " (sigConstraint : constraints)- <> ") => MethodInfo " <> infoName <> " " <> obj <> " signature where"- let mn = methodName m- mangled = lowerName (mn {name = name n <> "_" <> name mn})- indent $ line $ "overloadedMethod _ = " <> mangled- exportMethod mangled infoName---- | Generate a method info that is not actually callable, but rather--- gives a type error when trying to use it.-genUnsupportedMethodInfo :: Name -> Method -> CodeGen ()-genUnsupportedMethodInfo n m = do- infoName <- methodInfoName n m- line $ "-- XXX: Dummy instance, since code generation failed.\n"- <> "-- Please file a bug at http://github.com/haskell-gi/haskell-gi."- bline $ "data " <> infoName- line $ "instance (p ~ (), o ~ MethodResolutionFailed \""- <> lowerName (methodName m) <> "\" " <> name n- <> ") => MethodInfo " <> infoName <> " o p where"- indent $ line $ "overloadedMethod _ = undefined"- exportMethod "Unsupported methods" infoName
− src/GI/OverloadedSignals.hs
@@ -1,122 +0,0 @@-module GI.OverloadedSignals- ( genObjectSignals- , genInterfaceSignals- , genOverloadedSignalConnectors- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (forM_, when)-import Data.Text (Text)-import qualified Data.Text as T--import qualified Data.Set as S--import GI.API-import GI.Code-import GI.Inheritance (fullObjectSignalList, fullInterfaceSignalList)-import GI.GObject (apiIsGObject)-import GI.Signal (signalHaskellName)-import GI.SymbolNaming (upperName, hyphensToCamelCase)-import GI.Util (lcFirst, ucFirst)---- A list of distinct signal names for all GObjects appearing in the--- given list of APIs.-findSignalNames :: [(Name, API)] -> CodeGen [Text]-findSignalNames apis = S.toList <$> go apis S.empty- where- go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text)- go [] set = return set- go ((_, api):apis) set =- case api of- APIInterface iface ->- go apis $ insertSignals (ifSignals iface) set- APIObject object ->- go apis $ insertSignals (objSignals object) set- _ -> go apis set-- insertSignals :: [Signal] -> S.Set Text -> S.Set Text- insertSignals props set = foldr (S.insert . sigName) set props---- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ...-genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen ()-genOverloadedSignalConnectors allAPIs = do- setLanguagePragmas ["DataKinds", "PatternSynonyms", "CPP",- -- For ghc 7.8 support- "RankNTypes", "ScopedTypeVariables", "TypeFamilies"]- setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]-- line "import Data.GI.Base.Signals (SignalProxy(..))"- line "import Data.GI.Base.Overloading (ResolveSignal)"- blank- signalNames <- findSignalNames allAPIs- forM_ signalNames $ \sn -> group $ do- let camelName = hyphensToCamelCase sn- line $ "#if MIN_VERSION_base(4,8,0)"- line $ "pattern " <> camelName <>- " :: SignalProxy object (ResolveSignal \""- <> lcFirst camelName <> "\" object)"- line $ "pattern " <> camelName <> " = SignalProxy"- line $ "#else"- line $ "pattern " <> camelName <> " = SignalProxy :: forall info object. "- <> "info ~ ResolveSignal \"" <> lcFirst camelName- <> "\" object => SignalProxy object info"- line $ "#endif"- exportDecl $ "pattern " <> camelName---- | Qualified name for the "(sigName, info)" tag for a given signal.-signalInfoName :: Name -> Signal -> CodeGen Text-signalInfoName n signal = do- n' <- upperName n- return $ n' <> (ucFirst . signalHaskellName . sigName) signal- <> "SignalInfo"---- | Generate the given signal instance for the given API object.-genInstance :: Name -> Signal -> CodeGen ()-genInstance owner signal = group $ do- name <- upperName owner- let sn = (ucFirst . signalHaskellName . sigName) signal- si <- signalInfoName owner signal- bline $ "data " <> si- line $ "instance SignalInfo " <> si <> " where"- indent $ do- let signalConnectorName = name <> sn- cbHaskellType = signalConnectorName <> "Callback"- line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType- line $ "connectSignal _ = " <> "connect" <> name <> sn- exportSignal sn si---- | Signal instances for (GObject-derived) objects.-genObjectSignals :: Name -> Object -> CodeGen ()-genObjectSignals n o = do- name <- upperName n- isGO <- apiIsGObject n (APIObject o)- when isGO $ do- mapM_ (genInstance n) (objSignals o)- infos <- fullObjectSignalList n o >>=- mapM (\(owner, signal) -> do- si <- signalInfoName owner signal- return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal- <> "\", " <> si <> ")")- group $ do- let signalListType = name <> "SignalList"- line $ "type instance 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- mapM_ (genInstance n) (ifSignals iface)- infos <- fullInterfaceSignalList n iface >>=- mapM (\(owner, signal) -> do- si <- signalInfoName owner signal- return $ "'(\"" <> (lcFirst . hyphensToCamelCase . sigName) signal- <> "\", " <> si <> ")")- group $ do- let signalListType = name <> "SignalList"- line $ "type instance SignalList " <> name <> " = " <> signalListType- line $ "type " <> signalListType <> " = ('[ "- <> T.intercalate ", " infos <> "] :: [(Symbol, *)])"
− src/GI/Overrides.hs
@@ -1,181 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-module GI.Overrides- ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion)- , parseOverridesFile- , filterAPIsAndDeps- ) where--import Control.Monad.Except-import Control.Monad.State-import Control.Monad.Writer--import Data.Maybe (isJust)-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Text as T-import Data.Text (Text)--import GI.API--data Overrides = Overrides {- -- | Ignored elements of a given API.- ignoredElems :: M.Map Name (S.Set Text),- -- | Ignored APIs (all elements in this API will just be discarded).- ignoredAPIs :: S.Set Name,- -- | Structs for which accessors should not be auto-generated.- sealedStructs :: S.Set Name,- -- | Mapping from GObject Introspection namespaces to pkg-config- pkgConfigMap :: M.Map Text Text,- -- | Version number for the generated .cabal package.- cabalPkgVersion :: Maybe Text,- -- | Prefered version of the namespace- nsChooseVersion :: M.Map Text Text-}---- | Construct the generic config for a module.-defaultOverrides :: Overrides-defaultOverrides = Overrides {- ignoredElems = M.empty,- ignoredAPIs = S.empty,- sealedStructs = S.empty,- pkgConfigMap = M.empty,- cabalPkgVersion = Nothing,- nsChooseVersion = M.empty }---- | There is a sensible notion of zero and addition of Overridess,--- encode this so that we can view the parser as a writer monad of--- configs.-instance Monoid Overrides where- mempty = defaultOverrides- mappend a b = Overrides {- ignoredAPIs = ignoredAPIs a <> ignoredAPIs b,- sealedStructs = sealedStructs a <> sealedStructs b,- ignoredElems = M.unionWith S.union (ignoredElems a) (ignoredElems b),- pkgConfigMap = pkgConfigMap a <> pkgConfigMap b,- cabalPkgVersion = if isJust (cabalPkgVersion b)- then cabalPkgVersion b- else cabalPkgVersion a,- nsChooseVersion = nsChooseVersion a <> nsChooseVersion b- }---- | We have a bit of context (the current namespace), and can fail,--- encode this in a monad.-type Parser = WriterT Overrides (StateT (Maybe Text) (Except Text)) ()---- | Parse the given config file (as a set of lines) for a given--- introspection namespace, filling in the configuration as needed. In--- case the parsing fails we return a description of the error--- instead.-parseOverridesFile :: [Text] -> Either Text Overrides-parseOverridesFile ls = runExcept $ flip evalStateT Nothing $ execWriterT $- mapM (parseOneLine . T.strip) ls---- | Parse a single line of the config file, modifying the--- configuration as appropriate.-parseOneLine :: Text -> Parser--- Empty lines-parseOneLine line | T.null line = return ()--- Comments-parseOneLine (T.stripPrefix "#" -> Just _) = return ()-parseOneLine (T.stripPrefix "namespace " -> Just ns) = (put . Just . T.strip) ns-parseOneLine (T.stripPrefix "ignore " -> Just ign) = get >>= parseIgnore ign-parseOneLine (T.stripPrefix "seal " -> Just s) = get >>= parseSeal s-parseOneLine (T.stripPrefix "pkg-config-name" -> Just s) = parsePkgConfigName s-parseOneLine (T.stripPrefix "cabal-pkg-version" -> Just s) = parseCabalPkgVersion s-parseOneLine (T.stripPrefix "namespace-version" -> Just s) = parseNsVersion s-parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"."---- | Ignored elements.-parseIgnore :: Text -> Maybe Text -> Parser-parseIgnore _ Nothing =- throwError "'ignore' requires a namespace to be defined first."-parseIgnore (T.words -> [T.splitOn "." -> [api,elem]]) (Just ns) =- tell $ defaultOverrides {ignoredElems = M.singleton (Name ns api)- (S.singleton elem)}-parseIgnore (T.words -> [T.splitOn "." -> [api]]) (Just ns) =- tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns api)}-parseIgnore ignore _ =- throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " <> ignore <> "\" instead.")---- | Sealed structures.-parseSeal :: Text -> Maybe Text -> Parser-parseSeal _ Nothing = throwError "'seal' requires a namespace to be defined first."-parseSeal (T.words -> [s]) (Just ns) = tell $- defaultOverrides {sealedStructs = S.singleton (Name ns s)}-parseSeal seal _ =- throwError ("seal syntax is of the form \"seal name\".\nGot \"seal "- <> seal <> "\" instead.")---- | Mapping from GObject Introspection namespaces to pkg-config.-parsePkgConfigName :: Text -> Parser-parsePkgConfigName (T.words -> [gi,pc]) = tell $- defaultOverrides {pkgConfigMap =- M.singleton (T.toLower gi) pc}-parsePkgConfigName t =- throwError ("pkg-config-name syntax is of the form\n" <>- "\t\"pkg-config-name gi-namespace pk-name\"\n" <>- "Got \"pkg-config-name " <> t <> "\" instead.")---- | Choose a preferred namespace version to load.-parseNsVersion :: Text -> Parser-parseNsVersion (T.words -> [ns,version]) = tell $- defaultOverrides {nsChooseVersion =- M.singleton ns version}-parseNsVersion t =- throwError ("namespace-version syntax is of the form\n" <>- "\t\"namespace-version namespace version\"\n" <>- "Got \"namespace-version " <> t <> "\" instead.")---- | Specifying the cabal package version by hand.-parseCabalPkgVersion :: Text -> Parser-parseCabalPkgVersion (T.words -> [version]) = tell $- defaultOverrides {cabalPkgVersion = Just version}-parseCabalPkgVersion t =- throwError ("cabal-pkg-version syntax is of the form\n" <>- "\t\"cabal-pkg-version version\"\n" <>- "Got \"cabal-pkg-version " <> t <> "\" instead.")---- | Filter a set of named objects based on a lookup list of names to--- ignore.-filterMethods :: [Method] -> S.Set Text -> [Method]-filterMethods set ignores =- filter ((`S.notMember` ignores) . name . methodName) set---- | Filter one API according to the given config.-filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API)-filterOneAPI ovs (n, APIStruct s, maybeIgnores) =- (n, APIStruct s {structMethods = maybe (structMethods s)- (filterMethods (structMethods s))- maybeIgnores,- structFields = if n `S.member` sealedStructs ovs- then []- else structFields s})--- The rest only apply if there are ignores.-filterOneAPI _ (n, api, Nothing) = (n, api)-filterOneAPI _ (n, APIObject o, Just ignores) =- (n, APIObject o {objMethods = filterMethods (objMethods o) ignores,- objSignals = filter ((`S.notMember` ignores) . sigName)- (objSignals o)- })-filterOneAPI _ (n, APIInterface i, Just ignores) =- (n, APIInterface i {ifMethods = filterMethods (ifMethods i) ignores,- ifSignals = filter ((`S.notMember` ignores) . sigName)- (ifSignals i)- })-filterOneAPI _ (n, APIUnion u, Just ignores) =- (n, APIUnion u {unionMethods = filterMethods (unionMethods u) ignores})-filterOneAPI _ (n, api, _) = (n, api)---- | Given a list of APIs modify them according to the given config.-filterAPIs :: Overrides -> [(Name, API)] -> [(Name, API)]-filterAPIs ovs apis = map (filterOneAPI ovs . fetchIgnores) filtered- where filtered = filter ((`S.notMember` ignoredAPIs ovs) . fst) apis- fetchIgnores (n, api) = (n, api, M.lookup n (ignoredElems ovs))---- | Load a given API, applying filtering. Load also any necessary--- dependencies.-filterAPIsAndDeps :: Overrides -> GIRInfo -> [GIRInfo]- -> (M.Map Name API, M.Map Name API)-filterAPIsAndDeps ovs doc deps =- let toMap = M.fromList . filterAPIs ovs . girAPIs- in (toMap doc, M.unions (map toMap deps))
− src/GI/PkgConfig.hs
@@ -1,47 +0,0 @@-module GI.PkgConfig- ( pkgConfigGetVersion- ) where--import Control.Monad (when)-import Data.Monoid (First(..), (<>))-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (mconcat)-#endif-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import Data.Text (Text)-import System.Exit (ExitCode(..))-import System.Process (readProcessWithExitCode)---- | Try asking pkg-config for the version of a given module.-tryPkgConfig :: Text -> IO (Maybe (Text, Text))-tryPkgConfig pkgName = do- (exitcode, stdout, _) <-- readProcessWithExitCode "pkg-config" ["--modversion", T.unpack pkgName] ""- case exitcode of- ExitSuccess -> case lines stdout of- [v] -> return (Just (pkgName, T.pack v))- _ -> return Nothing- ExitFailure _ -> return Nothing---- | Get the pkg-config name and associated installed version of a given--- gobject-introspection namespace. Since the mapping is not--- one-to-one some guessing is involved, although in most cases the--- required information is listed in the GIR file.-pkgConfigGetVersion :: Text -- name- -> Text -- version- -> [Text] -- known package names- -> Bool -- verbose- -> M.Map Text Text -- suggested overrides- -> IO (Maybe (Text, Text))-pkgConfigGetVersion name version packages verbose overridenNames = do- let lowerName = T.toLower name- when verbose $- putStrLn $ T.unpack ("Querying pkg-config for " <> name <>- " version " <> version)- let alternatives = case M.lookup lowerName overridenNames of- Nothing -> packages ++ [lowerName <> "-" <> version,- lowerName]- Just n -> [n <> "-" <> version, n]- firstJust = getFirst . mconcat . map First- mapM tryPkgConfig alternatives >>= return . firstJust
− src/GI/ProjectInfo.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- | Project information to include in generated bindings, should be--- kept in sync with haskell-gi.cabal-module GI.ProjectInfo- ( homepage- , authors- , license- , licenseText- , maintainers- ) where--import Data.FileEmbed (embedStringFile)-import Data.Text (Text)--homepage :: Text-homepage = "https://github.com/haskell-gi/haskell-gi"--authors :: Text-authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte"--maintainers :: Text-maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)"--license :: Text-license = "LGPL-2.1"--licenseText :: Text-licenseText = $(embedStringFile "LICENSE")
− src/GI/Properties.hs
@@ -1,293 +0,0 @@-module GI.Properties- ( genInterfaceProperties- , genObjectProperties- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (forM_, when, unless)-import Data.Text (Text)-import qualified Data.Text as T--import Foreign.Storable (sizeOf)-import Foreign.C (CInt, CUInt)--import GI.API-import GI.Conversions-import GI.Code-import GI.GObject-import GI.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)-import GI.SymbolNaming (upperName, classConstraint, qualify, hyphensToCamelCase)-import GI.Type-import GI.Util--propTypeStr :: Type -> CodeGen Text-propTypeStr t = case t of- TBasicType TUTF8 -> return "String"- TBasicType TFileName -> return "String"- TBasicType TVoid -> return "Ptr"- TByteArray -> return "ByteArray"- TGHash _ _ -> return "Hash"- TVariant -> return "Variant"- TParamSpec -> return "ParamSpec"- TBasicType TInt32 -> do- -- This should work for all systems in common use, but rather- -- than leaving the assumption implicit better double checking.- when (sizeOf (0 :: CInt) /= 4) $- error "C Integers are not 4 bytes, unsupported platform."- return "CInt"- TBasicType TUInt32 -> do- when (sizeOf (0 :: CUInt) /= 4) $- error "C Integers are not 4 bytes, unsupported platform."- return "CUInt"- TBasicType TInt64 -> return "Int64"- TBasicType TUInt64 -> return "UInt64"- TBasicType TBoolean -> return "Bool"- TBasicType TFloat -> return "Float"- TBasicType TDouble -> return "Double"- TBasicType TGType -> return "GType"- TCArray True _ _ (TBasicType TUTF8) -> return "StringArray"- TCArray True _ _ (TBasicType TFileName) -> return "StringArray"- TGList (TBasicType TVoid) -> return "PtrGList"- t@(TInterface ns n) -> do- api <- findAPIByName (Name ns n)- case api of- APIEnum _ -> return "Enum"- APIFlags _ -> return "Flags"- APIStruct s -> if structIsBoxed s- then return "Boxed"- else error $ "Unboxed struct property : " ++ show t- APIUnion u -> if unionIsBoxed u- then return "Boxed"- else error $ "Unboxed union property : " ++ show t- APIObject _ -> do- isGO <- isGObject t- if isGO- then return "Object"- else error $ "Non-GObject object property : " ++ show t- APIInterface _ -> do- isGO <- isGObject t- if isGO- then return "Object"- else error $ "Non-GObject interface property : " ++ show t- _ -> error $ "Unknown interface property of type : " ++ show t- _ -> error $ "Don't know how to handle properties of type " ++ show t---- Given a property, return the set of constraints on the types, and--- the type variables for the object and its value.-attrType :: Property -> CodeGen ([Text], Text)-attrType prop = do- (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop- if T.any (== ' ') t- then return (constraints, parenthesize t)- else return (constraints, t)--genPropertySetter :: Name -> Text -> Property -> CodeGen ()-genPropertySetter n pName prop = group $ do- oName <- upperName n- (constraints, t) <- attrType prop- let constraints' = "MonadIO m":(classConstraint oName <> " o"):constraints- tStr <- propTypeStr $ propType prop- line $ "set" <> pName <> " :: (" <> T.intercalate ", " constraints'- <> ") => o -> " <> t <> " -> m ()"- line $ "set" <> pName <> " obj val = liftIO $ setObjectProperty" <> tStr- <> " obj \"" <> propName prop <> "\" val"--genPropertyGetter :: Name -> Text -> Property -> CodeGen ()-genPropertyGetter n pName prop = group $ do- oName <- upperName n- outType <- haskellType (propType prop)- let constraints = "(MonadIO m, " <> classConstraint oName <> " o)"- line $ "get" <> pName <> " :: " <> constraints <>- " => o -> " <> tshow ("m" `con` [outType])- tStr <- propTypeStr $ propType prop- line $ "get" <> pName <> " obj = liftIO $ getObjectProperty" <> tStr- <> " obj \"" <> propName prop <> "\"" <>- if tStr `elem` ["Object", "Boxed"]- then " " <> tshow outType -- These require the constructor too.- else ""--genPropertyConstructor :: Text -> Property -> CodeGen ()-genPropertyConstructor pName prop = group $ do- (constraints, t) <- attrType prop- tStr <- propTypeStr $ 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- <> " \"" <> propName prop <> "\" val"---- | The property name as a lexically valid Haskell identifier. Note--- that this is not escaped, since it is assumed that it will be used--- with a prefix, so if a property is named "class", for example, this--- will return "class".-hPropName :: Property -> Text-hPropName = lcFirst . hyphensToCamelCase . propName--genObjectProperties :: Name -> Object -> CodeGen ()-genObjectProperties n o = do- isGO <- apiIsGObject n (APIObject o)- -- We do not generate bindings for objects not descending from GObject.- when isGO $ do- allProps <- fullObjectPropertyList n o >>=- mapM (\(owner, prop) -> do- pi <- infoType owner prop- return $ "'(\"" <> hPropName prop- <> "\", " <> pi <> ")")- genProperties n (objProperties o) allProps--genInterfaceProperties :: Name -> Interface -> CodeGen ()-genInterfaceProperties n iface = do- allProps <- fullInterfacePropertyList n iface >>=- mapM (\(owner, prop) -> do- pi <- infoType owner prop- return $ "'(\"" <> hPropName prop- <> "\", " <> pi <> ")")- genProperties n (ifProperties iface) allProps---- If the given accesor is available (indicated by available == True),--- 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 =- if not available- then return "undefined"- else do- prefix <- qualify ons- return $ prefix <> accessor <> on <> cName---- | 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"--genOneProperty :: Name -> Property -> ExcCodeGen ()-genOneProperty owner prop = do- name <- upperName owner- let cName = (hyphensToCamelCase . propName) prop- pName = name <> cName- flags = propFlags prop- writable = PropertyWritable `elem` flags &&- (PropertyConstructOnly `notElem` flags)- readable = PropertyReadable `elem` flags- constructOnly = PropertyConstructOnly `elem` flags-- -- For properties the meaning of having transfer /= TransferNothing- -- is not clear (what are the right semantics for GValue setters?),- -- and the other possibilities are very uncommon, so let us just- -- assume that TransferNothing is always the case.- when (propTransfer prop /= TransferNothing) $- notImplementedError $ "Property " <> pName- <> " has unsupported transfer type "- <> tshow (propTransfer prop)-- getter <- accessorOrUndefined readable "get" owner cName- setter <- accessorOrUndefined writable "set" owner cName- constructor <- accessorOrUndefined (writable || constructOnly)- "construct" owner cName-- unless (readable || writable || constructOnly) $- notImplementedError $ "Property is not readable, writable, or constructible: "- <> tshow pName-- group $ do- line $ "-- VVV Prop \"" <> propName prop <> "\""- line $ " -- Type: " <> tshow (propType prop)- line $ " -- Flags: " <> tshow (propFlags prop)-- when readable $ genPropertyGetter owner pName prop- when writable $ genPropertySetter owner pName prop- when (writable || constructOnly) $ genPropertyConstructor pName prop-- outType <- if not readable- then return "()"- else do- sOutType <- tshow <$> haskellType (propType prop)- return $ if T.any (== ' ') sOutType- then parenthesize sOutType- 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- then ["'AttrSet", "'AttrConstruct"]- else [])- <> (if constructOnly- then ["'AttrConstruct"]- else [])- <> (if readable- then ["'AttrGet"]- 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)- bline $ "data " <> it- line $ "instance AttrInfo " <> it <> " where"- indent $ do- line $ "type AttrAllowedOps " <> it- <> " = '[ " <> T.intercalate ", " allowedOps <> "]"- line $ "type AttrSetTypeConstraint " <> it- <> " = " <> inConstraint- line $ "type AttrBaseTypeConstraint " <> it- <> " = " <> classConstraint name- line $ "type AttrGetType " <> it <> " = " <> outType- line $ "type AttrLabel " <> it <> " = \"" <> propName prop <> "\""- line $ "attrGet _ = " <> getter- line $ "attrSet _ = " <> setter- line $ "attrConstruct _ = " <> constructor---- | Generate a placeholder property for those cases in which code--- generation failed.-genPlaceholderProperty :: Name -> Property -> CodeGen ()-genPlaceholderProperty owner prop = do- line $ "-- XXX Placeholder"- it <- infoType owner prop- let cName = (hyphensToCamelCase . propName) prop- exportProperty cName it- line $ "data " <> it- line $ "instance AttrInfo " <> it <> " where"- indent $ do- line $ "type AttrAllowedOps " <> it <> " = '[]"- line $ "type AttrSetTypeConstraint " <> it <> " = (~) ()"- line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()"- line $ "type AttrGetType " <> it <> " = ()"- line $ "type AttrLabel " <> it <> " = \"\""- line $ "attrGet = undefined"- line $ "attrSet = undefined"- line $ "attrConstruct = undefined"--genProperties :: Name -> [Property] -> [Text] -> CodeGen ()-genProperties n ownedProps allProps = do- name <- upperName n-- forM_ ownedProps $ \prop -> do- handleCGExc (\err -> do- line $ "-- XXX Generation of property \""- <> propName prop <> "\" of object \""- <> name <> "\" failed: " <> describeCGError err- genPlaceholderProperty n prop)- (genOneProperty n prop)-- group $ do- let propListType = name <> "AttributeList"- line $ "type instance AttributeList " <> name <> " = " <> propListType- line $ "type " <> propListType <> " = ('[ "- <> T.intercalate ", " allProps <> "] :: [(Symbol, *)])"
− src/GI/Signal.hs
@@ -1,338 +0,0 @@-module GI.Signal- ( genSignal- , genCallback- , signalHaskellName- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (forM, forM_, when, unless)--import Data.Typeable (typeOf)-import Data.Bool (bool)-import qualified Data.Text as T-import Data.Text (Text)--import Text.Show.Pretty (ppShow)--import GI.API-import GI.Callable (hOutType, arrayLengths, wrapMaybe, fixupCallerAllocates)-import GI.Code-import GI.Conversions-import GI.SymbolNaming-import GI.Transfer (freeContainerType)-import GI.Type-import GI.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst,- prime)---- The prototype of the callback on the Haskell side (what users of--- the binding will see)-genHaskellCallbackPrototype :: Text -> Callable -> Text -> [Arg] -> [Arg] ->- ExcCodeGen ()-genHaskellCallbackPrototype subsec cb name' hInArgs hOutArgs = do- group $ do- exportSignal subsec name'- line $ "type " <> name' <> " ="- indent $ do- forM_ hInArgs $ \arg -> do- ht <- haskellType (argType arg)- wrapMaybe arg >>= bool- (line $ tshow ht <> " ->")- (line $ tshow (maybeT ht) <> " ->")- ret <- hOutType cb hOutArgs False- line $ tshow $ io ret-- -- For optional parameters, in case we want to pass Nothing.- group $ do- exportSignal subsec ("no" <> name')- line $ "no" <> name' <> " :: Maybe " <> name'- line $ "no" <> name' <> " = Nothing"---- Prototype of the callback on the C side-genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen ()-genCCallbackPrototype subsec cb name' isSignal =- group $ do- let ctypeName = name' <> "C"- exportSignal subsec ctypeName-- line $ "type " <> ctypeName <> " ="- indent $ do- when isSignal $ line $ withComment "Ptr () ->" "object"- forM_ (args cb) $ \arg -> do- ht <- foreignType $ argType arg- let ht' = if direction arg /= DirectionIn- then ptr ht- else ht- line $ tshow ht' <> " ->"- when isSignal $ line $ withComment "Ptr () ->" "user_data"- ret <- io <$> case returnType cb of- TBasicType TVoid -> return $ typeOf ()- t -> foreignType t- line $ tshow ret---- Generator for wrappers callable from C-genCallbackWrapperFactory :: Text -> Text -> CodeGen ()-genCallbackWrapperFactory subsec name' =- group $ do- let factoryName = "mk" <> name'- line "foreign import ccall \"wrapper\""- indent $ line $ factoryName <> " :: "- <> name' <> "C -> IO (FunPtr " <> name' <> "C)"- exportSignal subsec factoryName---- Generator of closures-genClosure :: Text -> Text -> Text -> Bool -> CodeGen ()-genClosure subsec callback closure isSignal = do- exportSignal subsec closure- group $ do- line $ closure <> " :: " <> callback <> " -> IO Closure"- line $ closure <> " cb = newCClosure =<< mk" <> callback <> " wrapped"- indent $- line $ "where wrapped = " <> lcFirst callback <> "Wrapper " <>- if isSignal- then "cb"- else "Nothing cb"---- Wrap a conversion of a nullable object into "Maybe" object, by--- checking whether the pointer is NULL.-convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text-convertNullable aname c = do- line $ "maybe" <> ucFirst aname <> " <-"- indent $ do- line $ "if " <> aname <> " == nullPtr"- line "then return Nothing"- line "else do"- indent $ do- unpacked <- c- line $ "return $ Just " <> unpacked- return $ "maybe" <> ucFirst aname---- Convert a non-zero terminated out array, stored in a variable--- named "aname", into the corresponding Haskell object.-convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text-convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname =- if length > -1- then wrapMaybe arg >>= bool convertAndFree- (convertNullable aname convertAndFree)- else- -- Not much we can do, we just pass the pointer along, and let- -- the callback deal with it.- return aname- where- lname = escapedArgName $ args callable !! length-- convertAndFree :: ExcCodeGen Text- convertAndFree = do- unpacked <- convert aname $ unpackCArray lname t (transfer arg)- -- Free the memory associated with the array- freeContainerType (transfer arg) t aname lname- return unpacked---- Remove the warning, this should never be reached.-convertCallbackInCArray _ t _ _ =- terror $ "convertOutCArray : unexpected " <> tshow t---- Prepare an argument for passing into the Haskell side.-prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text-prepareArgForCall cb arg = case direction arg of- DirectionIn -> prepareInArg cb arg- DirectionInout -> prepareInoutArg arg- DirectionOut -> terror "Unexpected DirectionOut!"--prepareInArg :: Callable -> Arg -> ExcCodeGen Text-prepareInArg cb arg = do- let name = escapedArgName arg- case argType arg of- t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name- _ -> do- let c = convert name $ fToH (argType arg) (transfer arg)- wrapMaybe arg >>= bool c (convertNullable name c)--prepareInoutArg :: Arg -> ExcCodeGen Text-prepareInoutArg arg = do- let name = escapedArgName arg- name' <- genConversion name $ apply $ M "peek"- convert name' $ fToH (argType arg) (transfer arg)--saveOutArg :: Arg -> ExcCodeGen ()-saveOutArg arg = do- let name = escapedArgName arg- name' = "out" <> name- when (transfer arg /= TransferEverything) $- notImplementedError $ "Unexpected transfer type for \"" <> name <> "\""- isMaybe <- wrapMaybe arg- name'' <- if isMaybe- then do- let name'' = prime name'- line $ name'' <> " <- case " <> name' <> " of"- indent $ do- line "Nothing -> return nullPtr"- line $ "Just " <> name'' <> " -> do"- indent $ do- converted <- convert name'' $ hToF (argType arg) TransferEverything- line $ "return " <> converted- return name''- else convert name' $ hToF (argType arg) TransferEverything- line $ "poke " <> name <> " " <> name''---- The wrapper itself, marshalling to and from Haskell. The first--- argument is possibly a pointer to a FunPtr to free (via--- freeHaskellFunPtr) once the callback is run once, or Nothing if the--- FunPtr will be freed by someone else (the function registering the--- callback for ScopeTypeCall, or a destroy notifier for--- ScopeTypeNotified).-genCallbackWrapper :: Text -> Callable -> Text -> [Arg] -> [Arg] -> [Arg] ->- Bool -> ExcCodeGen ()-genCallbackWrapper subsec cb name' dataptrs hInArgs hOutArgs isSignal = do- let cName arg = if arg `elem` dataptrs- then "_"- else escapedArgName arg- cArgNames = map cName (args cb)- wrapperName = lcFirst name' <> "Wrapper"-- exportSignal subsec wrapperName-- group $ do- line $ wrapperName <> " ::"- indent $ do- unless isSignal $- line $ "Maybe (Ptr (FunPtr (" <> name' <> "C))) ->"- line $ name' <> " ->"- when isSignal $ line "Ptr () ->"- forM_ (args cb) $ \arg -> do- ht <- foreignType $ argType arg- let ht' = if direction arg /= DirectionIn- then ptr ht- else ht- line $ tshow ht' <> " ->"- when isSignal $ line "Ptr () ->"- ret <- io <$> case returnType cb of- TBasicType TVoid -> return $ typeOf ()- t -> foreignType t- line $ tshow ret-- let allArgs = if isSignal- then T.unwords $ ["_cb", "_"] <> cArgNames <> ["_"]- else T.unwords $ ["funptrptr", "_cb"] <> cArgNames- line $ wrapperName <> " " <> allArgs <> " = do"- indent $ do- hInNames <- forM hInArgs (prepareArgForCall cb)-- let maybeReturn = case returnType cb of- TBasicType TVoid -> []- _ -> ["result"]- returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs- returnBind = case returnVars of- [] -> ""- [r] -> r <> " <- "- _ -> parenthesize (T.intercalate ", " returnVars) <> " <- "- line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames)-- forM_ hOutArgs saveOutArg-- unless isSignal $ line "maybeReleaseFunPtr funptrptr"-- when (returnType cb /= TBasicType TVoid) $- if returnMayBeNull cb- then do- line "maybeM nullPtr result $ \\result' -> do"- indent $ unwrapped "result'"- else unwrapped "result"- where- unwrapped rname = do- result' <- convert rname $ hToF (returnType cb) (returnTransfer cb)- line $ "return " <> result'--genCallback :: Name -> Callback -> CodeGen ()-genCallback n (Callback cb) = submodule "Callbacks" $ do- name' <- upperName n- line $ "-- callback " <> name'-- let -- user_data pointers, which we generically omit- dataptrs = map (args cb !!) . filter (/= -1) . map argClosure $ args cb- hidden = dataptrs <> arrayLengths cb-- inArgs = filter ((/= DirectionOut) . direction) $ args cb- hInArgs = filter (not . (`elem` hidden)) inArgs- outArgs = filter ((/= DirectionIn) . direction) $ args cb- hOutArgs = filter (not . (`elem` hidden)) outArgs-- if skipReturn cb- then group $ do- line $ "-- XXX Skipping callback " <> name'- line $ "-- Callbacks skipping return unsupported :\n"- <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb)- else do- let closure = lcFirst name' <> "Closure"- cb' = fixupCallerAllocates cb-- handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "- <> name' <>- "\n-- Error was : " <> describeCGError e))- (genClosure name' name' closure False >>- genCCallbackPrototype name' cb' name' False >>- genCallbackWrapperFactory name' name' >>- genHaskellCallbackPrototype name' cb' name' hInArgs hOutArgs >>- genCallbackWrapper name' cb' name' dataptrs hInArgs hOutArgs False)---- | Return the name for the signal in Haskell CamelCase conventions.-signalHaskellName :: Text -> Text-signalHaskellName sn = let (w:ws) = T.split (== '-') sn- in w <> T.concat (map ucFirst ws)--genSignal :: Signal -> Name -> ExcCodeGen ()-genSignal (Signal { sigName = sn, sigCallable = cb }) on = do- on' <- upperName on-- line $ "-- signal " <> on' <> "::" <> sn-- let inArgs = filter ((/= DirectionOut) . direction) $ args cb- hInArgs = filter (not . (`elem` arrayLengths cb)) inArgs- outArgs = filter ((/= DirectionIn) . direction) $ args cb- hOutArgs = filter (not . (`elem` arrayLengths cb)) outArgs- sn' = signalHaskellName (sn)- signalConnectorName = on' <> ucFirst sn'- cbType = signalConnectorName <> "Callback"-- genHaskellCallbackPrototype (ucFirst sn') cb cbType hInArgs hOutArgs-- genCCallbackPrototype (ucFirst sn') cb cbType True-- genCallbackWrapperFactory (ucFirst sn') cbType-- let closure = lcFirst signalConnectorName <> "Closure"- genClosure (ucFirst sn') cbType closure True-- genCallbackWrapper (ucFirst sn') cb cbType [] hInArgs hOutArgs True-- -- Wrapper for connecting functions to the signal- -- We can connect to a signal either before the default handler runs- -- ("on...") or after the default handler runs (after...). We- -- provide convenient wrappers for both cases.- group $ do- let signatureConstraints = "(GObject a, MonadIO m) =>"- signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"- signature = " :: " <> signatureConstraints <> " " <> signatureArgs- onName = "on" <> signalConnectorName- afterName = "after" <> signalConnectorName- line $ onName <> signature- line $ onName <> " obj cb = liftIO $ connect"- <> signalConnectorName <> " obj cb SignalConnectBefore"- line $ afterName <> signature- line $ afterName <> " obj cb = connect"- <> signalConnectorName <> " obj cb SignalConnectAfter"- exportSignal (ucFirst sn') onName- exportSignal (ucFirst sn') afterName-- group $ do- let fullName = "connect" <> signalConnectorName- signatureConstraints = "(GObject a, MonadIO m) =>"- signatureArgs = "a -> " <> cbType- <> " -> SignalConnectMode -> m SignalHandlerId"- line $ fullName <> " :: " <> signatureConstraints- line $ T.replicate (4 + T.length fullName) " " <> signatureArgs- line $ fullName <> " obj cb after = liftIO $ do"- indent $ do- line $ "cb' <- mk" <> cbType <> " (" <> lcFirst cbType <> "Wrapper cb)"- line $ "connectSignalFunPtr obj \"" <> sn <> "\" cb' after"
− src/GI/Struct.hs
@@ -1,129 +0,0 @@-module GI.Struct ( genStructOrUnionFields- , genZeroStruct- , genZeroUnion- , extractCallbacksInStruct- , fixAPIStructs- , ignoreStruct)- where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (forM_, unless, when)--import Data.Maybe (mapMaybe, isJust)-import Data.Text (Text)-import qualified Data.Text as T--import GI.API-import GI.Conversions-import GI.Code-import GI.SymbolNaming-import GI.Type-import GI.Util---- | Whether (not) to generate bindings for the given struct.-ignoreStruct :: Name -> Struct -> Bool-ignoreStruct (Name _ name) s = isJust (gtypeStructFor s) ||- "Private" `T.isSuffixOf` name---- | Canonical name for the type of a callback type embedded in a--- struct field.-fieldCallbackType :: Text -> Field -> Text-fieldCallbackType structName field =- structName <> (underscoresToCamelCase . fieldName) field <> "FieldCallback"---- | Fix the interface names of callback fields in the struct to--- correspond to the ones that we are going to generate.-fixCallbackStructFields :: Name -> Struct -> Struct-fixCallbackStructFields (Name ns structName) s = s {structFields = fixedFields}- where fixedFields :: [Field]- fixedFields = map fixField (structFields s)-- fixField :: Field -> Field- fixField field =- case fieldCallback field of- Nothing -> field- Just _ -> let n' = fieldCallbackType structName field- in field {fieldType = TInterface ns n'}---- | Fix the interface names of callback fields in an APIStruct to--- correspond to the ones that we are going to generate. If something--- other than an APIStruct is passed in we don't touch it.-fixAPIStructs :: (Name, API) -> (Name, API)-fixAPIStructs (n, APIStruct s) = (n, APIStruct $ fixCallbackStructFields n s)-fixAPIStructs api = api---- | Extract the callback types embedded in the fields of structs, and--- at the same time fix the type of the corresponding fields. Returns--- the list of APIs associated to this struct, not including the--- struct itself.-extractCallbacksInStruct :: (Name, API) -> [(Name, API)]-extractCallbacksInStruct (n@(Name ns structName), APIStruct s)- | ignoreStruct n s = []- | otherwise =- mapMaybe callbackInField (structFields s)- where callbackInField :: Field -> Maybe (Name, API)- callbackInField field = do- callback <- fieldCallback field- let n' = fieldCallbackType structName field- return (Name ns n', APICallback callback)-extractCallbacksInStruct _ = []--buildFieldGetter :: Name -> Field -> ExcCodeGen ()-buildFieldGetter n@(Name ns _) field = do- name' <- upperName n-- hType <- tshow <$> haskellType (fieldType field)- fType <- tshow <$> foreignType (fieldType field)- unless ("Private" `T.isSuffixOf` hType) $ do- fName <- upperName $ Name ns (fieldName field)- let getter = lcFirst name' <> "Read" <> fName- line $ getter <> " :: " <> name' <> " -> IO " <>- if T.any (== ' ') hType- then parenthesize hType- else hType- line $ getter <> " s = withManagedPtr s $ \\ptr -> do"- indent $ do- line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field)- <> ") :: IO " <> if T.any (== ' ') fType- then parenthesize fType- else fType- result <- convert "val" $ fToH (fieldType field) TransferNothing- line $ "return " <> result-- exportProperty fName getter--genStructOrUnionFields :: Name -> [Field] -> CodeGen ()-genStructOrUnionFields n fields = do- name' <- upperName n-- forM_ fields $ \field -> when (fieldVisible field) $ group $- handleCGExc (\e -> line ("-- XXX Skipped getter for \"" <> name' <>- ":" <> fieldName field <> "\" :: " <>- describeCGError e))- (buildFieldGetter n field)---- | Generate a constructor for a zero-filled struct/union of the given--- type, using the boxed (or GLib, for unboxed types) allocator.-genZeroSU :: Name -> Int -> Bool -> CodeGen ()-genZeroSU n size isBoxed =- when (size /= 0) $ group $ do- name <- upperName n- let builder = "newZero" <> name- tsize = tshow size- line $ "-- | Construct a `" <> name <> "` struct initialized to zero."- line $ builder <> " :: MonadIO m => m " <> name- line $ builder <> " = liftIO $ " <>- if isBoxed- then "callocBoxedBytes " <> tsize <> " >>= wrapBoxed " <> name- else "callocBytes " <> tsize <> " >>= wrapPtr " <> name- exportDecl builder---- | Specialization for structs of `genZeroSU`.-genZeroStruct :: Name -> Struct -> CodeGen ()-genZeroStruct n s = genZeroSU n (structSize s) (structIsBoxed s)---- | Specialization for unions of `genZeroSU`.-genZeroUnion :: Name -> Union -> CodeGen ()-genZeroUnion n u = genZeroSU n (unionSize u) (unionIsBoxed u)
− src/GI/SymbolNaming.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-module GI.SymbolNaming- ( qualify- , lowerName- , upperName- , noName- , escapedArgName- , classConstraint- , hyphensToCamelCase- , underscoresToCamelCase- ) where--import Data.Text (Text)-import qualified Data.Text as T--import GI.API-import GI.Code-import GI.Config (Config(modName))-import GI.Util (lcFirst, ucFirst)--classConstraint :: Text -> Text-classConstraint n = n <> "K"--lowerName :: Name -> Text-lowerName (Name _ s) = T.concat . rename . T.split (== '_') $ s- where- rename [w] = [lcFirst w]- rename (w:ws) = lcFirst w : map ucFirst' ws- rename [] = error "rename: empty list"-- ucFirst' "" = "_"- ucFirst' x = ucFirst x--upperNameWithSuffix :: Text -> Name -> CodeGen Text-upperNameWithSuffix suffix (Name ns s) = do- prefix <- qualifyWithSuffix suffix ns- return $ prefix <> uppered- where uppered = T.concat . map ucFirst' . T.split (== '_') $ sanitize s- -- Move leading underscores to the end (for example in- -- GObject::_Value_Data_Union -> GObject::Value_Data_Union_)- sanitize (T.uncons -> Just ('_', xs)) = sanitize xs <> "_"- sanitize xs = xs-- ucFirst' "" = "_"- ucFirst' x = ucFirst x--upperName :: Name -> CodeGen Text-upperName = upperNameWithSuffix "."---- | 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---- | Return the qualified namespace (ns ++ "." or "", depending on--- whether ns is the current namespace).-qualify :: Text -> CodeGen Text-qualify = qualifyWithSuffix "."---- | Save a bit of typing for optional arguments in the case that we--- want to pass Nothing.-noName :: Text -> CodeGen ()-noName name' = group $ do- line $ "no" <> name' <> " :: Maybe " <> name'- line $ "no" <> name' <> " = Nothing"- exportDecl ("no" <> name')---- | For a string of the form "one-sample-string" return "OneSampleString"-hyphensToCamelCase :: Text -> Text-hyphensToCamelCase = T.concat . map ucFirst . T.split (== '-')---- | Similarly, turn a name separated_by_underscores into CamelCase.-underscoresToCamelCase :: Text -> Text-underscoresToCamelCase = T.concat . map ucFirst . T.split (== '_')---- | Name for the given argument, making sure it is a valid Haskell--- argument name (and escaping it if not).-escapedArgName :: Arg -> Text-escapedArgName arg- | "_" `T.isPrefixOf` argCName arg = argCName arg- | otherwise =- escapeReserved . lcFirst . underscoresToCamelCase . argCName $ arg---- | Reserved symbols, either because they are Haskell syntax or--- because the clash with symbols in scope for the generated bindings.-escapeReserved :: Text -> Text-escapeReserved "type" = "type_"-escapeReserved "in" = "in_"-escapeReserved "data" = "data_"-escapeReserved "instance" = "instance_"-escapeReserved "where" = "where_"-escapeReserved "module" = "module_"--- Reserved because we generate code that uses these names.-escapeReserved "result" = "result_"-escapeReserved "return" = "return_"-escapeReserved "show" = "show_"-escapeReserved "fromEnum" = "fromEnum_"-escapeReserved "toEnum" = "toEnum_"-escapeReserved "undefined" = "undefined_"-escapeReserved "error" = "error_"-escapeReserved "map" = "map_"-escapeReserved "length" = "length_"-escapeReserved "mapM" = "mapM__"-escapeReserved "mapM_" = "mapM___"-escapeReserved "fromIntegral" = "fromIntegral_"-escapeReserved "realToFrac" = "realToFrac_"-escapeReserved "peek" = "peek_"-escapeReserved "poke" = "poke_"-escapeReserved "sizeOf" = "sizeOf_"-escapeReserved "when" = "when_"-escapeReserved "default" = "default_"-escapeReserved s- | "set_" `T.isPrefixOf` s = s <> "_"- | "get_" `T.isPrefixOf` s = s <> "_"- | otherwise = s
− src/GI/Transfer.hs
@@ -1,257 +0,0 @@--- Routines dealing with memory management in marshalling functions.--module GI.Transfer- ( freeInArg- , freeInArgOnError- , freeContainerType- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))-#endif--import Control.Monad (when)-import Data.Maybe (isJust)-import Data.Text (Text)--import GI.API-import GI.Code-import GI.Conversions-import GI.GObject-import GI.Type-import GI.Util---- Basic primitives for freeing the given types. Types that point to--- Haskell objects with memory managed by the GC should not be freed--- here. For containers this is only for freeing the container itself,--- freeing the elements is done separately.-basicFreeFn :: Type -> Maybe Text-basicFreeFn (TBasicType TUTF8) = Just "freeMem"-basicFreeFn (TBasicType TFileName) = Just "freeMem"-basicFreeFn (TBasicType _) = Nothing-basicFreeFn (TInterface _ _) = Nothing-basicFreeFn (TCArray False (-1) (-1) _) = Nothing -- Just passing it along-basicFreeFn (TCArray{}) = Just "freeMem"-basicFreeFn (TGArray _) = Just "unrefGArray"-basicFreeFn (TPtrArray _) = Just "unrefPtrArray"-basicFreeFn (TByteArray) = Just "unrefGByteArray"-basicFreeFn (TGList _) = Just "g_list_free"-basicFreeFn (TGSList _) = Just "g_slist_free"-basicFreeFn (TGHash _ _) = Just "unrefGHashTable"-basicFreeFn (TError) = Nothing-basicFreeFn (TVariant) = Nothing-basicFreeFn (TParamSpec) = Nothing---- Basic free primitives in the case that an error occured. This is--- run in the exception handler, so any type which we ref/allocate--- with the expectation that the called function will consume it (on--- TransferEverything) should be freed here.-basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text)-basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem"-basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem"-basicFreeFnOnError (TBasicType _) _ = return Nothing-basicFreeFnOnError TVariant transfer =- return $ if transfer == TransferEverything- then Just "unrefGVariant"- else Nothing-basicFreeFnOnError TParamSpec transfer =- return $ if transfer == TransferEverything- then Just "unrefGParamSpec"- else Nothing-basicFreeFnOnError t@(TInterface _ _) transfer = do- api <- findAPI t- case api of- Just (APIObject _) -> if transfer == TransferEverything- then do- isGO <- isGObject t- if isGO- then return $ Just "unrefObject"- else do- line "-- XXX Transfer a non-GObject object"- return Nothing- else return Nothing- Just (APIInterface _) -> if transfer == TransferEverything- then do- isGO <- isGObject t- if isGO- then return $ Just "unrefObject"- else do- line "-- XXX Transfer a non-GObject object"- return Nothing- else return Nothing- Just (APIUnion u) -> if transfer == TransferEverything- then if unionIsBoxed u- then return $ Just "freeBoxed"- else do- line "-- XXX Transfer a non-boxed union"- return Nothing- else return Nothing- Just (APIStruct s) -> if transfer == TransferEverything- then if structIsBoxed s- then return $ Just "freeBoxed"- else do- line "-- XXX Transfer a non-boxed struct"- return Nothing- else return Nothing- _ -> return Nothing--- Arrays without length info are just passed along, we do not need to--- free them.-basicFreeFnOnError (TCArray False (-1) (-1) _) _ = return Nothing-basicFreeFnOnError (TCArray{}) _ = return $ Just "freeMem"-basicFreeFnOnError (TGArray _) _ = return $ Just "unrefGArray"-basicFreeFnOnError (TPtrArray _) _ = return $ Just "unrefPtrArray"-basicFreeFnOnError (TByteArray) _ = return $ Just "unrefGByteArray"-basicFreeFnOnError (TGList _) _ = return $ Just "g_list_free"-basicFreeFnOnError (TGSList _) _ = return $ Just "g_slist_free"-basicFreeFnOnError (TGHash _ _) _ = return $ Just "unrefGHashTable"-basicFreeFnOnError (TError) _ = return Nothing---- Free just the container, but not the elements.-freeContainer :: Type -> Text -> CodeGen [Text]-freeContainer t label =- case basicFreeFn t of- Nothing -> return []- Just fn -> return [fn <> " " <> label]---- Free one element using the given free function.-freeElem :: Type -> Text -> Text -> ExcCodeGen Text-freeElem t label free =- case elementTypeAndMap t undefined of- Nothing -> return free- Just (TCArray False _ _ _, _) ->- badIntroError $ "Element type in container \"" <> label <>- "\" is an array of unknown length."- Just (innerType, mapFn) -> do- let elemFree = "freeElemOf" <> ucFirst label- fullyFree innerType (prime label) >>= \case- Nothing -> return $ free <> " e"- Just elemInnerFree -> do- line $ "let " <> elemFree <> " e = " <> mapFn <> " "- <> elemInnerFree <> " e >> " <> free <> " e"- return elemFree---- Construct a function to free the memory associated with a type, and--- recursively free any elements of this type in case that it is a--- container.-fullyFree :: Type -> Text -> ExcCodeGen (Maybe Text)-fullyFree t label = case basicFreeFn t of- Nothing -> return Nothing- Just free -> Just <$> freeElem t label free---- Like fullyFree, but free the toplevel element using basicFreeFnOnError.-fullyFreeOnError :: Type -> Text -> Transfer -> ExcCodeGen (Maybe Text)-fullyFreeOnError t label transfer =- basicFreeFnOnError t transfer >>= \case- Nothing -> return Nothing- Just free -> Just <$> freeElem t label free---- Free the elements in a container type.-freeElements :: Type -> Text -> Text -> ExcCodeGen [Text]-freeElements t label len =- case elementTypeAndMap t len of- Nothing -> return []- Just (inner, mapFn) ->- fullyFree inner label >>= \case- Nothing -> return []- Just innerFree ->- return [mapFn <> " " <> innerFree <> " " <> label]---- | Free a container and/or the contained elements, depending on the--- transfer mode.-freeContainerType :: Transfer -> Type -> Text -> Text -> ExcCodeGen ()-freeContainerType transfer (TGHash _ _) label _ = freeGHashTable transfer label-freeContainerType transfer t label len = do- when (transfer == TransferEverything) $- mapM_ line =<< freeElements t label len- when (transfer /= TransferNothing) $- mapM_ line =<< freeContainer t label--freeGHashTable :: Transfer -> Text -> ExcCodeGen ()-freeGHashTable TransferNothing _ = return ()-freeGHashTable TransferContainer label =- notImplementedError $ "Hash table argument with transfer = Container? "- <> label--- Hash tables support setting a free function for keys and elements,--- we assume that these are always properly set. The worst that can--- happen this way is a memory leak, as opposed to a double free if we--- try do free anything here.-freeGHashTable TransferEverything label =- line $ "unrefGHashTable " <> label---- Free the elements of a container type in the case an error ocurred,--- in particular args that should have been transferred did not get--- transfered.-freeElementsOnError :: Transfer -> Type -> Text -> Text ->- ExcCodeGen [Text]-freeElementsOnError transfer t label len =- case elementTypeAndMap t len of- Nothing -> return []- Just (inner, mapFn) ->- fullyFreeOnError inner label transfer >>= \case- Nothing -> return []- Just innerFree ->- return [mapFn <> " " <> innerFree <> " " <> label]--freeIn :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]-freeIn transfer (TGHash _ _) label _ =- freeInGHashTable transfer label-freeIn transfer t label len =- case transfer of- TransferNothing -> (<>) <$> freeElements t label len <*> freeContainer t label- TransferContainer -> freeElements t label len- TransferEverything -> return []--freeInOnError :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text]-freeInOnError transfer (TGHash _ _) label _ =- freeInGHashTable transfer label-freeInOnError transfer t label len =- (<>) <$> freeElementsOnError transfer t label len- <*> freeContainer t label---- See freeGHashTable above.-freeInGHashTable :: Transfer -> Text -> ExcCodeGen [Text]-freeInGHashTable TransferEverything _ = return []-freeInGHashTable TransferContainer label =- notImplementedError $ "Hash table argument with TransferContainer? "- <> label-freeInGHashTable TransferNothing label = return ["unrefGHashTable " <> label]--freeOut :: Text -> CodeGen [Text]-freeOut label = return ["freeMem " <> label]---- | Given an input argument to a C callable, and its label in the code,--- return the list of actions relevant to freeing the memory allocated--- for the argument (if appropriate, depending on the ownership--- transfer semantics of the callable).-freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text]-freeInArg arg label len = do- weAlloc <- isJust <$> requiresAlloc (argType arg)- -- Arguments that we alloc ourselves do not need to be freed, they- -- will always be soaked up by the wrapPtr constructor, or they will- -- be DirectionIn.- if not weAlloc- then case direction arg of- DirectionIn -> freeIn (transfer arg) (argType arg) label len- DirectionOut -> freeOut label- DirectionInout ->- -- Caller-allocates arguments are like "in" arguments for- -- memory management purposes.- if argCallerAllocates arg- then freeIn (transfer arg) (argType arg) label len- else freeOut label- else return []---- | Same thing as freeInArg, but called in case the call to C didn't--- succeed. We thus free everything we allocated in preparation for--- the call, including args that would have been transferred to C.-freeInArgOnError :: Arg -> Text -> Text -> ExcCodeGen [Text]-freeInArgOnError arg label len =- case direction arg of- DirectionIn -> freeInOnError (transfer arg) (argType arg) label len- DirectionOut -> freeOut label- DirectionInout ->- -- Caller-allocates arguments are like "in" arguments for- -- memory management purposes.- if argCallerAllocates arg- then freeInOnError (transfer arg) (argType arg) label len- else freeOut label
− src/GI/Type.hs
@@ -1,87 +0,0 @@--module GI.Type- ( BasicType(..)- , isBasicScalar- , Type(..)- , io- , ptr- , funptr- , con- , maybeT- ) where--import Data.Typeable-import qualified Data.Text as T-import Data.Text (Text)--data BasicType- = TVoid- | TBoolean- | TInt8- | TUInt8- | TInt16- | TUInt16- | TInt32- | TUInt32- | TInt64- | TUInt64- | TFloat- | TDouble- | TUniChar- | TGType- | TUTF8- | TFileName- | TIntPtr- | TUIntPtr- deriving (Eq, Enum, Show, Ord)---- This type represents the types found in GObject Introspection--- interfaces: the types of constants, arguments, etc.-data Type- = TBasicType BasicType- -- Zero terminated, Array Fixed Size, Array Length, Element Type- | TCArray Bool Int Int Type- | TGArray Type- | TPtrArray Type- | TByteArray- | TInterface Text Text- | TGList Type- | TGSList Type- | TGHash Type Type- | TError- | TVariant- | TParamSpec- deriving (Eq, Show, Ord)---- | Whether the given type is a basic scalar, i.e. everything that is--- not a pointer to a memory region.-isBasicScalar :: Type -> Bool-isBasicScalar (TBasicType b) = basicIsScalar b-isBasicScalar _ = False---- | Whether the given basic type is a scalar, i.e. not a pointer to a--- memory region.-basicIsScalar :: BasicType -> Bool-basicIsScalar TVoid = False-basicIsScalar TUTF8 = False-basicIsScalar TFileName = False-basicIsScalar _ = True--con :: Text -> [TypeRep] -> TypeRep-con "[]" xs = mkTyConApp listCon xs- where listCon = typeRepTyCon (typeOf [True])-con "(,)" xs = mkTyConApp tupleCon xs- where tupleCon = typeRepTyCon (typeOf (True, True))-con s xs = mkTyConApp (mkTyCon3 "GI" "GI" (T.unpack s)) xs--io :: TypeRep -> TypeRep-io t = "IO" `con` [t]--ptr :: TypeRep -> TypeRep-ptr t = "Ptr" `con` [t]--funptr :: TypeRep -> TypeRep-funptr t = "FunPtr" `con` [t]--maybeT :: TypeRep -> TypeRep-maybeT t = "Maybe" `con` [t]
− src/GI/Util.hs
@@ -1,48 +0,0 @@-module GI.Util- ( prime- , parenthesize-- , padTo- , withComment-- , ucFirst- , lcFirst-- , tshow- , terror- ) where--import Data.Monoid ((<>))-import Data.Char (toLower, toUpper)-import Data.Text (Text)-import qualified Data.Text as T--padTo :: Int -> Text -> Text-padTo n s = s <> T.replicate (n - T.length s) " "--withComment :: Text -> Text -> Text-withComment a b = padTo 40 a <> "-- " <> b--prime :: Text -> Text-prime = (<> "'")--parenthesize :: Text -> Text-parenthesize s = "(" <> s <> ")"---- | Construct the `Text` representation of a showable.-tshow :: Show a => a -> Text-tshow = T.pack . show---- | Throw an error with the given `Text`.-terror :: Text -> a-terror = error . T.unpack---- | Capitalize the first character of the given string.-ucFirst :: Text -> Text-ucFirst "" = ""-ucFirst t = T.cons (toUpper $ T.head t) (T.tail t)---- | Make the first character of the given string lowercase.-lcFirst :: Text -> Text-lcFirst "" = ""-lcFirst t = T.cons (toLower $ T.head t) (T.tail t)
− src/c/enumStorage.c
@@ -1,122 +0,0 @@-/*- Compute the number of bytes required for storage of a given enum,- assuming that the current compiler gives the same result as the- compiler used for compiling the library being introspected.-- Adapted from girepository/giroffsets.c, in the gobject-introspection- distribution. Original copyright below.-*/--/* -*- mode: C; c-file-style: "gnu"; indent-tabs-mode: nil; -*-- * GObject introspection: Compute structure offsets- *- * Copyright (C) 2008 Red Hat, Inc.- *- * This library is free software; you can redistribute it and/or- * modify it under the terms of the GNU Lesser General Public- * License as published by the Free Software Foundation; either- * version 2 of the License, or (at your option) any later version.- *- * This library is distributed in the hope that it will be useful,- * but WITHOUT ANY WARRANTY; without even the implied warranty of- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU- * Lesser General Public License for more details.- *- * You should have received a copy of the GNU Lesser General Public- * License along with this library; if not, write to the- * Free Software Foundation, Inc., 59 Temple Place - Suite 330,- * Boston, MA 02111-1307, USA.- */--/* The C standard specifies that an enumeration can be any char or any signed- * or unsigned integer type capable of representing all the values of the- * enumeration. We use test enumerations to figure out what choices the- * compiler makes. (Ignoring > 32 bit enumerations)- */--#include <glib.h>--typedef enum {- ENUM_1 = 1 /* compiler could use int8, uint8, int16, uint16, int32, uint32 */-} Enum1;--typedef enum {- ENUM_2 = 128 /* compiler could use uint8, int16, uint16, int32, uint32 */-} Enum2;--typedef enum {- ENUM_3 = 257 /* compiler could use int16, uint16, int32, uint32 */-} Enum3;--typedef enum {- ENUM_4 = G_MAXSHORT + 1 /* compiler could use uint16, int32, uint32 */-} Enum4;--typedef enum {- ENUM_5 = G_MAXUSHORT + 1 /* compiler could use int32, uint32 */-} Enum5;--typedef enum {- ENUM_6 = ((guint)G_MAXINT) + 1 /* compiler could use uint32 */-} Enum6;--typedef enum {- ENUM_7 = -1 /* compiler could use int8, int16, int32 */-} Enum7;--typedef enum {- ENUM_8 = -129 /* compiler could use int16, int32 */-} Enum8;--typedef enum {- ENUM_9 = G_MINSHORT - 1 /* compiler could use int32 */-} Enum9;--int-_gi_get_enum_storage_bytes (gint64 min_value, gint64 max_value)-{- int width;-- if (min_value < 0)- {- if (min_value > -128 && max_value <= 127)- width = sizeof(Enum7);- else if (min_value >= G_MINSHORT && max_value <= G_MAXSHORT)- width = sizeof(Enum8);- else- width = sizeof(Enum9);- }- else- {- if (max_value <= 127)- {- width = sizeof (Enum1);- }- else if (max_value <= 255)- {- width = sizeof (Enum2);- }- else if (max_value <= G_MAXSHORT)- {- width = sizeof (Enum3);- }- else if (max_value <= G_MAXUSHORT)- {- width = sizeof (Enum4);- }- else if (max_value <= G_MAXINT)- {- width = sizeof (Enum5);- }- else- {- width = sizeof (Enum6);- }- }-- if (width == 1 || width == 2 || width == 4 || width == 8) {- return width;- } else {- g_error("Unexpected enum width %d", width);- }-}
− src/haskell-gi.hs
@@ -1,217 +0,0 @@-module Main where--#if !MIN_VERSION_base(4,8,0)-import Data.Traversable (traverse)-#endif-import Control.Monad (forM_, when, (>=>))-import Control.Exception (handle)--import Data.Char (toLower)-import Data.Bool (bool)-import Data.Monoid ((<>))-import Data.Text (Text)--import System.Directory (doesFileExist)-import System.Console.GetOpt-import System.Exit-import System.IO (hPutStr, hPutStrLn, stderr)-import System.Environment (getArgs)--import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import qualified Data.Set as S--import Data.GI.Base.GError-import Text.Show.Pretty (ppShow)--import GI.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API)-import GI.Cabal (cabalConfig, setupHs, genCabalProject)-import GI.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText, minBaseVersion)-import GI.Config (Config(..))-import GI.CodeGen (genModule)-import GI.OverloadedLabels (genOverloadedLabels)-import GI.OverloadedSignals (genOverloadedSignalConnectors)-import GI.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps)-import GI.ProjectInfo (licenseText)-import GI.Util (ucFirst)--data Mode = GenerateCode | Dump | Labels | Signals | Help--data Options = Options {- optMode :: Mode,- optOutputDir :: Maybe String,- optOverridesFiles :: [String],- optSearchPaths :: [String],- optVerbose :: Bool,- optCabal :: Bool}--defaultOptions = Options {- optMode = GenerateCode,- optOutputDir = Nothing,- optOverridesFiles = [],- optSearchPaths = [],- optVerbose = False,- optCabal = True}--parseKeyValue s =- let (a, '=':b) = break (=='=') s- in (a, b)--optDescrs :: [OptDescr (Options -> Options)]-optDescrs = [- Option "h" ["help"] (NoArg $ \opt -> opt { optMode = Help })- "\tprint this gentle help text",- Option "c" ["connectors"] (NoArg $ \opt -> opt {optMode = Signals})- "generate generic signal connectors",- Option "d" ["dump"] (NoArg $ \opt -> opt { optMode = Dump })- "\tdump internal representation",- Option "l" ["labels"] (NoArg $ \opt -> opt {optMode = Labels})- "generate overloaded labels",- Option "n" ["no-cabal"] (NoArg $ \opt -> opt {optCabal = False})- "\tdo not generate .cabal file",- Option "o" ["overrides"] (ReqArg- (\arg opt -> opt {optOverridesFiles =- arg : optOverridesFiles opt})- "OVERRIDES")- "specify a file with overrides info",- Option "O" ["output"] (ReqArg- (\arg opt -> opt {optOutputDir = Just arg}) "DIR")- "\tset the output directory",- Option "s" ["search"] (ReqArg- (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH")- "\tprepend a directory to the typelib search path",- Option "v" ["verbose"] (NoArg $ \opt -> opt { optVerbose = True })- "\tprint extra info while processing"]--showHelp = concatMap optAsLine optDescrs- where optAsLine (Option flag (long:_) _ desc) =- " -" ++ flag ++ "|--" ++ long ++ "\t" ++ desc ++ "\n"- optAsLine _ = error "showHelp"--printGError = handle (gerrorMessage >=> putStrLn . T.unpack)---- | Load a dependency without further postprocessing.-loadRawAPIs :: Bool -> Overrides -> [FilePath] -> Text -> IO [(Name, API)]-loadRawAPIs verbose ovs extraPaths name = do- let version = M.lookup name (nsChooseVersion ovs)- gir <- loadRawGIRInfo verbose name version extraPaths- return (girAPIs gir)---- | Generate overloaded labels ("_label", for example).-genLabels :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()-genLabels options ovs modules extraPaths = do- apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules- let allAPIs = M.unions (map M.fromList apis)- cfg = Config {modName = Nothing,- verbose = optVerbose options,- overrides = ovs}- putStrLn $ "\t* Generating GI.OverloadedLabels"- m <- genCode cfg allAPIs ["GI", "OverloadedLabels"]- (genOverloadedLabels (M.toList allAPIs))- _ <- writeModuleCode (optVerbose options) (optOutputDir options) m- return ()---- Generate generic signal connectors ("Clicked", "Activate", ...)-genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO ()-genGenericConnectors options ovs modules extraPaths = do- apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules- let allAPIs = M.unions (map M.fromList apis)- cfg = Config {modName = Nothing,- verbose = optVerbose options,- overrides = ovs}- putStrLn $ "\t* Generating GI.Signals"- m <- genCode cfg allAPIs ["GI", "Signals"] (genOverloadedSignalConnectors (M.toList allAPIs))- _ <- writeModuleCode (optVerbose options) (optOutputDir options) m- return ()---- Generate the code for the given module, and return the dependencies--- for this module.-processMod :: Options -> Overrides -> [FilePath] -> Text -> IO ()-processMod options ovs extraPaths name = do- let version = M.lookup name (nsChooseVersion ovs)- (gir, girDeps) <- loadGIRInfo (optVerbose options) name version extraPaths- let (apis, deps) = filterAPIsAndDeps ovs gir girDeps- allAPIs = M.union apis deps-- let cfg = Config {modName = Just name,- verbose = optVerbose options,- overrides = ovs}- nm = ucFirst name- mp = T.unpack . ("GI." <>)-- putStrLn $ "\t* Generating " ++ mp nm- m <- genCode cfg allAPIs ["GI", nm] (genModule apis)- let modDeps = transitiveModuleDeps m- moduleList <- writeModuleTree (optVerbose options) (optOutputDir options) m-- when (optCabal options) $ do- let cabal = "gi-" ++ map toLower (T.unpack nm) ++ ".cabal"- fname <- doesFileExist cabal >>=- bool (return cabal)- (putStrLn (cabal ++ " exists, writing "- ++ cabal ++ ".new instead") >>- return (cabal ++ ".new"))- putStrLn $ "\t\t+ " ++ fname- -- The module is not a dep of itself- let usedDeps = S.delete name modDeps- -- We only list as dependencies in the cabal file the- -- dependencies that we use, disregarding what the .gir file says.- actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps- baseVersion = minBaseVersion m- (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList baseVersion)- case err of- Nothing -> do- TIO.writeFile fname (codeToText (moduleCode m))- putStrLn "\t\t+ cabal.config"- TIO.writeFile "cabal.config" cabalConfig- putStrLn "\t\t+ Setup.hs"- TIO.writeFile "Setup.hs" setupHs- putStrLn "\t\t+ LICENSE"- TIO.writeFile "LICENSE" licenseText- Just msg -> putStrLn $ "ERROR: could not generate " ++ fname- ++ "\nError was: " ++ T.unpack msg--dump :: Options -> Overrides -> Text -> IO ()-dump options ovs name = do- let version = M.lookup name (nsChooseVersion ovs)- (doc, _) <- loadGIRInfo (optVerbose options) name version (optSearchPaths options)- mapM_ (putStrLn . ppShow) (girAPIs doc)--process :: Options -> [Text] -> IO ()-process options names = do- let extraPaths = optSearchPaths options- configs <- traverse TIO.readFile (optOverridesFiles options)- case parseOverridesFile (concatMap T.lines configs) of- Left errorMsg -> do- hPutStr stderr "Error when parsing the config file(s):\n"- hPutStr stderr (T.unpack errorMsg)- exitFailure- Right ovs ->- case optMode options of- GenerateCode -> forM_ names (processMod options ovs extraPaths)- Labels -> genLabels options ovs names extraPaths- Signals -> genGenericConnectors options ovs names extraPaths- Dump -> forM_ names (dump options ovs)- Help -> putStr showHelp--main :: IO ()-main = printGError $ do- args <- getArgs- let (actions, nonOptions, errors) = getOpt RequireOrder optDescrs args- options = foldl (.) id actions defaultOptions-- case errors of- [] -> return ()- _ -> do- mapM_ (hPutStr stderr) errors- exitFailure-- case nonOptions of- [] -> failWithUsage- names -> process options (map T.pack names)- where- failWithUsage = do- hPutStrLn stderr "usage: haskell-gi [options] module1 [module2 [...]]"- hPutStr stderr showHelp- exitFailure