diff --git a/cmdline/haskell-gi.hs b/cmdline/haskell-gi.hs new file mode 100644 --- /dev/null +++ b/cmdline/haskell-gi.hs @@ -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 diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.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 diff --git a/lib/Data/GI/CodeGen/API.hs b/lib/Data/GI/CodeGen/API.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/API.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Cabal.hs b/lib/Data/GI/CodeGen/Cabal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Cabal.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/CabalHooks.hs b/lib/Data/GI/CodeGen/CabalHooks.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/CabalHooks.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Callable.hs b/lib/Data/GI/CodeGen/Callable.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Callable.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Code.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/CodeGen.hs b/lib/Data/GI/CodeGen/CodeGen.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/CodeGen.hs @@ -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)) diff --git a/lib/Data/GI/CodeGen/Config.hs b/lib/Data/GI/CodeGen/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Config.hs @@ -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 + } diff --git a/lib/Data/GI/CodeGen/Constant.hs b/lib/Data/GI/CodeGen/Constant.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Constant.hs @@ -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" diff --git a/lib/Data/GI/CodeGen/Conversions.hs b/lib/Data/GI/CodeGen/Conversions.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Conversions.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Fixups.hs b/lib/Data/GI/CodeGen/Fixups.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Fixups.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/GObject.hs b/lib/Data/GI/CodeGen/GObject.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/GObject.hs @@ -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" diff --git a/lib/Data/GI/CodeGen/GType.hsc b/lib/Data/GI/CodeGen/GType.hsc new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/GType.hsc @@ -0,0 +1,24 @@ +module Data.GI.CodeGen.GType + ( GType -- Reexport from Data.GI.Base.BasicTypes for convenience + , gtypeIsA + , gtypeIsBoxed + ) where + +#include + +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 diff --git a/lib/Data/GI/CodeGen/Inheritance.hs b/lib/Data/GI/CodeGen/Inheritance.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Inheritance.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/LibGIRepository.hs b/lib/Data/GI/CodeGen/LibGIRepository.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/LibGIRepository.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedLabels.hs b/lib/Data/GI/CodeGen/OverloadedLabels.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/OverloadedLabels.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedMethods.hs b/lib/Data/GI/CodeGen/OverloadedMethods.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/OverloadedMethods.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/OverloadedSignals.hs b/lib/Data/GI/CodeGen/OverloadedSignals.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/OverloadedSignals.hs @@ -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, *)])" diff --git a/lib/Data/GI/CodeGen/Overrides.hs b/lib/Data/GI/CodeGen/Overrides.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Overrides.hs @@ -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)) diff --git a/lib/Data/GI/CodeGen/PkgConfig.hs b/lib/Data/GI/CodeGen/PkgConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/PkgConfig.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/ProjectInfo.hs b/lib/Data/GI/CodeGen/ProjectInfo.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/ProjectInfo.hs @@ -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") diff --git a/lib/Data/GI/CodeGen/Properties.hs b/lib/Data/GI/CodeGen/Properties.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Properties.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Signal.hs b/lib/Data/GI/CodeGen/Signal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Signal.hs @@ -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" diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -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) diff --git a/lib/Data/GI/CodeGen/SymbolNaming.hs b/lib/Data/GI/CodeGen/SymbolNaming.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/SymbolNaming.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Transfer.hs b/lib/Data/GI/CodeGen/Transfer.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Transfer.hs @@ -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 diff --git a/lib/Data/GI/CodeGen/Type.hs b/lib/Data/GI/CodeGen/Type.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Type.hs @@ -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] diff --git a/lib/Data/GI/CodeGen/Util.hs b/lib/Data/GI/CodeGen/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/Util.hs @@ -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) diff --git a/lib/Data/GI/GIR/Alias.hs b/lib/Data/GI/GIR/Alias.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Alias.hs @@ -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) diff --git a/lib/Data/GI/GIR/Arg.hs b/lib/Data/GI/GIR/Arg.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Arg.hs @@ -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 + } diff --git a/lib/Data/GI/GIR/BasicTypes.hs b/lib/Data/GI/GIR/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/BasicTypes.hs @@ -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) diff --git a/lib/Data/GI/GIR/Callable.hs b/lib/Data/GI/GIR/Callable.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Callable.hs @@ -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 + } diff --git a/lib/Data/GI/GIR/Callback.hs b/lib/Data/GI/GIR/Callback.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Callback.hs @@ -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) diff --git a/lib/Data/GI/GIR/Constant.hs b/lib/Data/GI/GIR/Constant.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Constant.hs @@ -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) diff --git a/lib/Data/GI/GIR/Deprecation.hs b/lib/Data/GI/GIR/Deprecation.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Deprecation.hs @@ -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 diff --git a/lib/Data/GI/GIR/Documentation.hs b/lib/Data/GI/GIR/Documentation.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Documentation.hs @@ -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) diff --git a/lib/Data/GI/GIR/Enum.hs b/lib/Data/GI/GIR/Enum.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Enum.hs @@ -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 + }) diff --git a/lib/Data/GI/GIR/Field.hs b/lib/Data/GI/GIR/Field.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Field.hs @@ -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 diff --git a/lib/Data/GI/GIR/Flags.hs b/lib/Data/GI/GIR/Flags.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Flags.hs @@ -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) diff --git a/lib/Data/GI/GIR/Function.hs b/lib/Data/GI/GIR/Function.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Function.hs @@ -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 + }) diff --git a/lib/Data/GI/GIR/Interface.hs b/lib/Data/GI/GIR/Interface.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Interface.hs @@ -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 + }) diff --git a/lib/Data/GI/GIR/Method.hs b/lib/Data/GI/GIR/Method.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Method.hs @@ -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 + } diff --git a/lib/Data/GI/GIR/Object.hs b/lib/Data/GI/GIR/Object.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Object.hs @@ -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 + }) + diff --git a/lib/Data/GI/GIR/Parser.hs b/lib/Data/GI/GIR/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Parser.hs @@ -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 + } diff --git a/lib/Data/GI/GIR/Property.hs b/lib/Data/GI/GIR/Property.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Property.hs @@ -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 + } diff --git a/lib/Data/GI/GIR/Repository.hs b/lib/Data/GI/GIR/Repository.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Repository.hs @@ -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 diff --git a/lib/Data/GI/GIR/Signal.hs b/lib/Data/GI/GIR/Signal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Signal.hs @@ -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 + } diff --git a/lib/Data/GI/GIR/Struct.hs b/lib/Data/GI/GIR/Struct.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Struct.hs @@ -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 + }) diff --git a/lib/Data/GI/GIR/Type.hs b/lib/Data/GI/GIR/Type.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Type.hs @@ -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." diff --git a/lib/Data/GI/GIR/Union.hs b/lib/Data/GI/GIR/Union.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/Union.hs @@ -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 + }) + diff --git a/lib/Data/GI/GIR/XMLUtils.hs b/lib/Data/GI/GIR/XMLUtils.hs new file mode 100644 --- /dev/null +++ b/lib/Data/GI/GIR/XMLUtils.hs @@ -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 } diff --git a/lib/c/enumStorage.c b/lib/c/enumStorage.c new file mode 100644 --- /dev/null +++ b/lib/c/enumStorage.c @@ -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 + +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); + } +} diff --git a/src/GI/API.hs b/src/GI/API.hs deleted file mode 100644 --- a/src/GI/API.hs +++ /dev/null @@ -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)) diff --git a/src/GI/Cabal.hs b/src/GI/Cabal.hs deleted file mode 100644 --- a/src/GI/Cabal.hs +++ /dev/null @@ -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 diff --git a/src/GI/Callable.hs b/src/GI/Callable.hs deleted file mode 100644 --- a/src/GI/Callable.hs +++ /dev/null @@ -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 diff --git a/src/GI/Code.hs b/src/GI/Code.hs deleted file mode 100644 --- a/src/GI/Code.hs +++ /dev/null @@ -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 diff --git a/src/GI/CodeGen.hs b/src/GI/CodeGen.hs deleted file mode 100644 --- a/src/GI/CodeGen.hs +++ /dev/null @@ -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)) diff --git a/src/GI/Config.hs b/src/GI/Config.hs deleted file mode 100644 --- a/src/GI/Config.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/Constant.hs b/src/GI/Constant.hs deleted file mode 100644 --- a/src/GI/Constant.hs +++ /dev/null @@ -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" diff --git a/src/GI/Conversions.hs b/src/GI/Conversions.hs deleted file mode 100644 --- a/src/GI/Conversions.hs +++ /dev/null @@ -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 diff --git a/src/GI/GIR/Alias.hs b/src/GI/GIR/Alias.hs deleted file mode 100644 --- a/src/GI/GIR/Alias.hs +++ /dev/null @@ -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) diff --git a/src/GI/GIR/Arg.hs b/src/GI/GIR/Arg.hs deleted file mode 100644 --- a/src/GI/GIR/Arg.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/GIR/BasicTypes.hs b/src/GI/GIR/BasicTypes.hs deleted file mode 100644 --- a/src/GI/GIR/BasicTypes.hs +++ /dev/null @@ -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) diff --git a/src/GI/GIR/Callable.hs b/src/GI/GIR/Callable.hs deleted file mode 100644 --- a/src/GI/GIR/Callable.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/GIR/Callback.hs b/src/GI/GIR/Callback.hs deleted file mode 100644 --- a/src/GI/GIR/Callback.hs +++ /dev/null @@ -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) diff --git a/src/GI/GIR/Constant.hs b/src/GI/GIR/Constant.hs deleted file mode 100644 --- a/src/GI/GIR/Constant.hs +++ /dev/null @@ -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) diff --git a/src/GI/GIR/Deprecation.hs b/src/GI/GIR/Deprecation.hs deleted file mode 100644 --- a/src/GI/GIR/Deprecation.hs +++ /dev/null @@ -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 diff --git a/src/GI/GIR/Documentation.hs b/src/GI/GIR/Documentation.hs deleted file mode 100644 --- a/src/GI/GIR/Documentation.hs +++ /dev/null @@ -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) diff --git a/src/GI/GIR/Enum.hs b/src/GI/GIR/Enum.hs deleted file mode 100644 --- a/src/GI/GIR/Enum.hs +++ /dev/null @@ -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 - }) diff --git a/src/GI/GIR/Field.hs b/src/GI/GIR/Field.hs deleted file mode 100644 --- a/src/GI/GIR/Field.hs +++ /dev/null @@ -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 diff --git a/src/GI/GIR/Flags.hs b/src/GI/GIR/Flags.hs deleted file mode 100644 --- a/src/GI/GIR/Flags.hs +++ /dev/null @@ -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) diff --git a/src/GI/GIR/Function.hs b/src/GI/GIR/Function.hs deleted file mode 100644 --- a/src/GI/GIR/Function.hs +++ /dev/null @@ -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 - }) diff --git a/src/GI/GIR/Interface.hs b/src/GI/GIR/Interface.hs deleted file mode 100644 --- a/src/GI/GIR/Interface.hs +++ /dev/null @@ -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 - }) diff --git a/src/GI/GIR/Method.hs b/src/GI/GIR/Method.hs deleted file mode 100644 --- a/src/GI/GIR/Method.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/GIR/Object.hs b/src/GI/GIR/Object.hs deleted file mode 100644 --- a/src/GI/GIR/Object.hs +++ /dev/null @@ -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 - }) - diff --git a/src/GI/GIR/Parser.hs b/src/GI/GIR/Parser.hs deleted file mode 100644 --- a/src/GI/GIR/Parser.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/GIR/Property.hs b/src/GI/GIR/Property.hs deleted file mode 100644 --- a/src/GI/GIR/Property.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/GIR/Repository.hs b/src/GI/GIR/Repository.hs deleted file mode 100644 --- a/src/GI/GIR/Repository.hs +++ /dev/null @@ -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 diff --git a/src/GI/GIR/Signal.hs b/src/GI/GIR/Signal.hs deleted file mode 100644 --- a/src/GI/GIR/Signal.hs +++ /dev/null @@ -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 - } diff --git a/src/GI/GIR/Struct.hs b/src/GI/GIR/Struct.hs deleted file mode 100644 --- a/src/GI/GIR/Struct.hs +++ /dev/null @@ -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 - }) diff --git a/src/GI/GIR/Type.hs b/src/GI/GIR/Type.hs deleted file mode 100644 --- a/src/GI/GIR/Type.hs +++ /dev/null @@ -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." diff --git a/src/GI/GIR/Union.hs b/src/GI/GIR/Union.hs deleted file mode 100644 --- a/src/GI/GIR/Union.hs +++ /dev/null @@ -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 - }) - diff --git a/src/GI/GIR/XMLUtils.hs b/src/GI/GIR/XMLUtils.hs deleted file mode 100644 --- a/src/GI/GIR/XMLUtils.hs +++ /dev/null @@ -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) diff --git a/src/GI/GObject.hs b/src/GI/GObject.hs deleted file mode 100644 --- a/src/GI/GObject.hs +++ /dev/null @@ -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" diff --git a/src/GI/GType.hsc b/src/GI/GType.hsc deleted file mode 100644 --- a/src/GI/GType.hsc +++ /dev/null @@ -1,24 +0,0 @@ -module GI.GType - ( GType -- Reexport from Data.GI.Base.BasicTypes for convenience - , gtypeIsA - , gtypeIsBoxed - ) where - -#include - -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 diff --git a/src/GI/Inheritance.hs b/src/GI/Inheritance.hs deleted file mode 100644 --- a/src/GI/Inheritance.hs +++ /dev/null @@ -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 diff --git a/src/GI/LibGIRepository.hs b/src/GI/LibGIRepository.hs deleted file mode 100644 --- a/src/GI/LibGIRepository.hs +++ /dev/null @@ -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 diff --git a/src/GI/OverloadedLabels.hs b/src/GI/OverloadedLabels.hs deleted file mode 100644 --- a/src/GI/OverloadedLabels.hs +++ /dev/null @@ -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 diff --git a/src/GI/OverloadedMethods.hs b/src/GI/OverloadedMethods.hs deleted file mode 100644 --- a/src/GI/OverloadedMethods.hs +++ /dev/null @@ -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 diff --git a/src/GI/OverloadedSignals.hs b/src/GI/OverloadedSignals.hs deleted file mode 100644 --- a/src/GI/OverloadedSignals.hs +++ /dev/null @@ -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, *)])" diff --git a/src/GI/Overrides.hs b/src/GI/Overrides.hs deleted file mode 100644 --- a/src/GI/Overrides.hs +++ /dev/null @@ -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)) diff --git a/src/GI/PkgConfig.hs b/src/GI/PkgConfig.hs deleted file mode 100644 --- a/src/GI/PkgConfig.hs +++ /dev/null @@ -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 diff --git a/src/GI/ProjectInfo.hs b/src/GI/ProjectInfo.hs deleted file mode 100644 --- a/src/GI/ProjectInfo.hs +++ /dev/null @@ -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") diff --git a/src/GI/Properties.hs b/src/GI/Properties.hs deleted file mode 100644 --- a/src/GI/Properties.hs +++ /dev/null @@ -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, *)])" diff --git a/src/GI/Signal.hs b/src/GI/Signal.hs deleted file mode 100644 --- a/src/GI/Signal.hs +++ /dev/null @@ -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" diff --git a/src/GI/Struct.hs b/src/GI/Struct.hs deleted file mode 100644 --- a/src/GI/Struct.hs +++ /dev/null @@ -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) diff --git a/src/GI/SymbolNaming.hs b/src/GI/SymbolNaming.hs deleted file mode 100644 --- a/src/GI/SymbolNaming.hs +++ /dev/null @@ -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 diff --git a/src/GI/Transfer.hs b/src/GI/Transfer.hs deleted file mode 100644 --- a/src/GI/Transfer.hs +++ /dev/null @@ -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 diff --git a/src/GI/Type.hs b/src/GI/Type.hs deleted file mode 100644 --- a/src/GI/Type.hs +++ /dev/null @@ -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] diff --git a/src/GI/Util.hs b/src/GI/Util.hs deleted file mode 100644 --- a/src/GI/Util.hs +++ /dev/null @@ -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) diff --git a/src/c/enumStorage.c b/src/c/enumStorage.c deleted file mode 100644 --- a/src/c/enumStorage.c +++ /dev/null @@ -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 - -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); - } -} diff --git a/src/haskell-gi.hs b/src/haskell-gi.hs deleted file mode 100644 --- a/src/haskell-gi.hs +++ /dev/null @@ -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