{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}

module Data.GI.CodeGen.API
    ( API(..)
    , GIRInfo(..)
    , loadGIRInfo
    , loadRawGIRInfo

    , GIRRule(..)
    , GIRPath
    , GIRNodeSpec(..)
    , GIRNameTag(..)

    -- Reexported from Data.GI.GIR.BasicTypes
    , Name(..)
    , Transfer(..)

    -- Reexported from Data.GI.GIR.Allocation
    , AllocationInfo(..)
    , AllocationOp(..)
    , unknownAllocationInfo

    -- Reexported from Data.GI.GIR.Arg
    , Direction(..)
    , Scope(..)

    -- Reexported from Data.GI.GIR.Deprecation
    , DeprecationInfo

    -- Reexported from Data.GI.GIR.Enumeration
    , EnumerationMember(..)

    -- 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 ((>=>), foldM, forM, when)
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (mapMaybe, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif

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 Text.Regex.TDFA ((=~))

import Data.GI.GIR.Alias (documentListAliases)
import Data.GI.GIR.Allocation (AllocationInfo(..), AllocationOp(..), unknownAllocationInfo)
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)
import Data.GI.GIR.Enum (Enumeration(..), EnumerationMember(..), 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, Typelib, FieldInfo(..),
                                        girStructFieldInfo, girUnionFieldInfo,
                                        girLoadGType, girIsSymbolResolvable)
import Data.GI.CodeGen.GType (gtypeIsBoxed)
import Data.GI.CodeGen.Type (Type)
import Data.GI.CodeGen.Util (printWarning, terror, tshow)

data GIRInfo = GIRInfo {
      GIRInfo -> [Text]
girPCPackages      :: [Text],
      GIRInfo -> Text
girNSName          :: Text,
      GIRInfo -> Text
girNSVersion       :: Text,
      GIRInfo -> [(Name, API)]
girAPIs            :: [(Name, API)],
      GIRInfo -> Map Text Name
girCTypes          :: M.Map Text Name
    } deriving Int -> GIRInfo -> ShowS
[GIRInfo] -> ShowS
GIRInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GIRInfo] -> ShowS
$cshowList :: [GIRInfo] -> ShowS
show :: GIRInfo -> String
$cshow :: GIRInfo -> String
showsPrec :: Int -> GIRInfo -> ShowS
$cshowsPrec :: Int -> GIRInfo -> ShowS
Show

data GIRNamespace = GIRNamespace {
      GIRNamespace -> Text
nsName      :: Text,
      GIRNamespace -> Text
nsVersion   :: Text,
      GIRNamespace -> [(Name, API)]
nsAPIs      :: [(Name, API)],
      GIRNamespace -> [(Text, Name)]
nsCTypes    :: [(Text, Name)]
    } deriving (Int -> GIRNamespace -> ShowS
[GIRNamespace] -> ShowS
GIRNamespace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GIRNamespace] -> ShowS
$cshowList :: [GIRNamespace] -> ShowS
show :: GIRNamespace -> String
$cshow :: GIRNamespace -> String
showsPrec :: Int -> GIRNamespace -> ShowS
$cshowsPrec :: Int -> GIRNamespace -> ShowS
Show)

data GIRInfoParse = GIRInfoParse {
    GIRInfoParse -> [Maybe Text]
girIPPackage    :: [Maybe Text],
    GIRInfoParse -> [Maybe (Text, Text)]
girIPIncludes   :: [Maybe (Text, Text)],
    GIRInfoParse -> [Maybe GIRNamespace]
girIPNamespaces :: [Maybe GIRNamespace]
} deriving (Int -> GIRInfoParse -> ShowS
[GIRInfoParse] -> ShowS
GIRInfoParse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GIRInfoParse] -> ShowS
$cshowList :: [GIRInfoParse] -> ShowS
show :: GIRInfoParse -> String
$cshow :: GIRInfoParse -> String
showsPrec :: Int -> GIRInfoParse -> ShowS
$cshowsPrec :: Int -> GIRInfoParse -> ShowS
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 GIRNameTag  -- ^ Node with the given "name" attr.
                 | GIRType Text         -- ^ Node of the given type.
                 | GIRTypedName Text GIRNameTag -- ^ Combination of the above.
                   deriving (Int -> GIRNodeSpec -> ShowS
[GIRNodeSpec] -> ShowS
GIRNodeSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GIRNodeSpec] -> ShowS
$cshowList :: [GIRNodeSpec] -> ShowS
show :: GIRNodeSpec -> String
$cshow :: GIRNodeSpec -> String
showsPrec :: Int -> GIRNodeSpec -> ShowS
$cshowsPrec :: Int -> GIRNodeSpec -> ShowS
Show)

-- | A name tag, which is either a name or a regular expression.
data GIRNameTag = GIRPlainName Text
                | GIRRegex Text
                  deriving (Int -> GIRNameTag -> ShowS
[GIRNameTag] -> ShowS
GIRNameTag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GIRNameTag] -> ShowS
$cshowList :: [GIRNameTag] -> ShowS
show :: GIRNameTag -> String
$cshow :: GIRNameTag -> String
showsPrec :: Int -> GIRNameTag -> ShowS
$cshowsPrec :: Int -> GIRNameTag -> ShowS
Show)

-- | A rule for modifying the GIR file.
data GIRRule = GIRSetAttr (GIRPath, XML.Name) Text -- ^ (Path to element,
                                                   -- attrName), newValue.
             | GIRDeleteAttr GIRPath XML.Name
             -- ^ Delete the given attribute
             | GIRAddNode GIRPath XML.Name -- ^ Add a child node at
                                           -- the given selector.
             | GIRDeleteNode GIRPath -- ^ Delete any nodes matching
                                     -- the given selector.
             deriving (Int -> GIRRule -> ShowS
[GIRRule] -> ShowS
GIRRule -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GIRRule] -> ShowS
$cshowList :: [GIRRule] -> ShowS
show :: GIRRule -> String
$cshow :: GIRRule -> String
showsPrec :: Int -> GIRRule -> ShowS
$cshowsPrec :: Int -> GIRRule -> ShowS
Show)

-- | An element in the exposed API
data API
    = APIConst Constant
    | APIFunction Function
    | APICallback Callback
    | APIEnum Enumeration
    | APIFlags Flags
    | APIInterface Interface
    | APIObject Object
    | APIStruct Struct
    | APIUnion Union
    deriving Int -> API -> ShowS
[API] -> ShowS
API -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [API] -> ShowS
$cshowList :: [API] -> ShowS
show :: API -> String
$cshow :: API -> String
showsPrec :: Int -> API -> ShowS
$cshowsPrec :: Int -> API -> ShowS
Show

parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API)
         -> Parser (Name, a) -> (Name, API)
parseAPI :: forall a.
Text
-> Map Alias Type
-> Element
-> (a -> API)
-> Parser (Name, a)
-> (Name, API)
parseAPI Text
ns Map Alias Type
aliases Element
element a -> API
wrapper Parser (Name, a)
parser =
    case forall a.
Text -> Map Alias Type -> Element -> Parser a -> Either Text a
runParser Text
ns Map Alias Type
aliases Element
element Parser (Name, a)
parser of
      Left Text
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Parse error: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
err
      Right (Name
n, a
a) -> (Name
n, a -> API
wrapper a
a)

parseNSElement :: M.Map Alias Type -> GIRNamespace -> Element -> GIRNamespace
parseNSElement :: Map Alias Type -> GIRNamespace -> Element -> GIRNamespace
parseNSElement Map Alias Type
aliases ns :: GIRNamespace
ns@GIRNamespace{[(Text, Name)]
[(Name, API)]
Text
nsCTypes :: [(Text, Name)]
nsAPIs :: [(Name, API)]
nsVersion :: Text
nsName :: Text
nsCTypes :: GIRNamespace -> [(Text, Name)]
nsAPIs :: GIRNamespace -> [(Name, API)]
nsVersion :: GIRNamespace -> Text
nsName :: GIRNamespace -> Text
..} Element
element
    | Name -> Element -> Maybe Text
lookupAttr Name
"introspectable" Element
element forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"0" = GIRNamespace
ns
    | Bool
otherwise =
        case Name -> Text
nameLocalName (Element -> Name
elementName Element
element) of
          Text
"alias" -> GIRNamespace
ns     -- Processed separately
          Text
"constant" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Constant -> API
APIConst Parser (Name, Constant)
parseConstant
          Text
"enumeration" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Enumeration -> API
APIEnum Parser (Name, Enumeration)
parseEnum
          Text
"bitfield" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Flags -> API
APIFlags Parser (Name, Flags)
parseFlags
          Text
"function" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Function -> API
APIFunction Parser (Name, Function)
parseFunction
          Text
"callback" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Callback -> API
APICallback Parser (Name, Callback)
parseCallback
          Text
"record" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Struct -> API
APIStruct Parser (Name, Struct)
parseStruct
          Text
"union" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Union -> API
APIUnion Parser (Name, Union)
parseUnion
          Text
"class" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Object -> API
APIObject Parser (Name, Object)
parseObject
          Text
"interface" -> forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Interface -> API
APIInterface Parser (Name, Interface)
parseInterface
          Text
"boxed" -> GIRNamespace
ns -- Unsupported
          Text
"docsection" -> GIRNamespace
ns -- Ignored for now, see https://github.com/haskell-gi/haskell-gi/issues/318
          Text
n -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"Unknown GIR element \"" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"\" when processing namespace \"" forall a. Semigroup a => a -> a -> a
<> Text
nsName forall a. Semigroup a => a -> a -> a
<> Text
"\", aborting."
    where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace
          parse :: forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse a -> API
wrapper Parser (Name, a)
parser =
              let (Name
n, API
api) = forall a.
Text
-> Map Alias Type
-> Element
-> (a -> API)
-> Parser (Name, a)
-> (Name, API)
parseAPI Text
nsName Map Alias Type
aliases Element
element a -> API
wrapper Parser (Name, a)
parser
                  maybeCType :: Maybe Text
maybeCType = GIRXMLNamespace -> Name -> Element -> Maybe Text
lookupAttrWithNamespace GIRXMLNamespace
CGIRNS Name
"type" Element
element
              in GIRNamespace
ns { nsAPIs :: [(Name, API)]
nsAPIs = (Name
n, API
api) forall a. a -> [a] -> [a]
: [(Name, API)]
nsAPIs,
                      nsCTypes :: [(Text, Name)]
nsCTypes = case Maybe Text
maybeCType of
                                   Just Text
ctype -> (Text
ctype, Name
n) forall a. a -> [a] -> [a]
: [(Text, Name)]
nsCTypes
                                   Maybe Text
Nothing -> [(Text, Name)]
nsCTypes
                    }

parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace
parseNamespace :: Element -> Map Alias Type -> Maybe GIRNamespace
parseNamespace Element
element Map Alias Type
aliases = do
  let attrs :: Map Name Text
attrs = Element -> Map Name Text
elementAttributes Element
element
  Text
name <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"name" Map Name Text
attrs
  Text
version <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"version" Map Name Text
attrs
  let ns :: GIRNamespace
ns = GIRNamespace {
             nsName :: Text
nsName         = Text
name,
             nsVersion :: Text
nsVersion      = Text
version,
             nsAPIs :: [(Name, API)]
nsAPIs         = [],
             nsCTypes :: [(Text, Name)]
nsCTypes       = []
           }
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (Map Alias Type -> GIRNamespace -> Element -> GIRNamespace
parseNSElement Map Alias Type
aliases) GIRNamespace
ns (Element -> [Element]
subelements Element
element))

parseInclude :: Element -> Maybe (Text, Text)
parseInclude :: Element -> Maybe (Text, Text)
parseInclude Element
element = do
  Text
name <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"name" Map Name Text
attrs
  Text
version <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"version" Map Name Text
attrs
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Text
version)
      where attrs :: Map Name Text
attrs = Element -> Map Name Text
elementAttributes Element
element

parsePackage :: Element -> Maybe Text
parsePackage :: Element -> Maybe Text
parsePackage Element
element = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"name" (Element -> Map Name Text
elementAttributes Element
element)

parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse
parseRootElement :: Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse
parseRootElement Map Alias Type
aliases info :: GIRInfoParse
info@GIRInfoParse{[Maybe (Text, Text)]
[Maybe Text]
[Maybe GIRNamespace]
girIPNamespaces :: [Maybe GIRNamespace]
girIPIncludes :: [Maybe (Text, Text)]
girIPPackage :: [Maybe Text]
girIPNamespaces :: GIRInfoParse -> [Maybe GIRNamespace]
girIPIncludes :: GIRInfoParse -> [Maybe (Text, Text)]
girIPPackage :: GIRInfoParse -> [Maybe Text]
..} Element
element =
    case Name -> Text
nameLocalName (Element -> Name
elementName Element
element) of
      Text
"include" -> GIRInfoParse
info {girIPIncludes :: [Maybe (Text, Text)]
girIPIncludes = Element -> Maybe (Text, Text)
parseInclude Element
element forall a. a -> [a] -> [a]
: [Maybe (Text, Text)]
girIPIncludes}
      Text
"package" -> GIRInfoParse
info {girIPPackage :: [Maybe Text]
girIPPackage = Element -> Maybe Text
parsePackage Element
element forall a. a -> [a] -> [a]
: [Maybe Text]
girIPPackage}
      Text
"namespace" -> GIRInfoParse
info {girIPNamespaces :: [Maybe GIRNamespace]
girIPNamespaces = Element -> Map Alias Type -> Maybe GIRNamespace
parseNamespace Element
element Map Alias Type
aliases forall a. a -> [a] -> [a]
: [Maybe GIRNamespace]
girIPNamespaces}
      Text
_ -> GIRInfoParse
info

emptyGIRInfoParse :: GIRInfoParse
emptyGIRInfoParse :: GIRInfoParse
emptyGIRInfoParse = GIRInfoParse {
                      girIPPackage :: [Maybe Text]
girIPPackage = [],
                      girIPIncludes :: [Maybe (Text, Text)]
girIPIncludes = [],
                      girIPNamespaces :: [Maybe GIRNamespace]
girIPNamespaces = []
                    }

parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument :: Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument Map Alias Type
aliases Document
doc = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse
parseRootElement Map Alias Type
aliases) GIRInfoParse
emptyGIRInfoParse (Element -> [Element]
subelements (Document -> Element
documentRoot Document
doc))

-- | Parse the list of includes in a given document.
documentListIncludes :: Document -> S.Set (Text, Text)
documentListIncludes :: Document -> Set (Text, Text)
documentListIncludes Document
doc = forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe (Text, Text)
parseInclude [Element]
includes)
    where includes :: [Element]
includes = Text -> Element -> [Element]
childElemsWithLocalName Text
"include" (Document -> Element
documentRoot Document
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 :: Bool
-> Set (Text, Text)
-> Map (Text, Text) Document
-> [String]
-> [GIRRule]
-> IO (Map (Text, Text) Document)
loadDependencies Bool
verbose Set (Text, Text)
requested Map (Text, Text) Document
loaded [String]
extraPaths [GIRRule]
rules
        | forall a. Set a -> Bool
S.null Set (Text, Text)
requested = forall (m :: * -> *) a. Monad m => a -> m a
return Map (Text, Text) Document
loaded
        | Bool
otherwise = do
  let (Text
name, Text
version) = forall a. Int -> Set a -> a
S.elemAt Int
0 Set (Text, Text)
requested
  Document
doc <- [GIRRule] -> Document -> Document
overrideGIRDocument [GIRRule]
rules forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Text -> Maybe Text -> [String] -> IO Document
readGiRepository Bool
verbose Text
name (forall a. a -> Maybe a
Just Text
version) [String]
extraPaths
  let newLoaded :: Map (Text, Text) Document
newLoaded = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text
name, Text
version) Document
doc Map (Text, Text) Document
loaded
      loadedSet :: Set (Text, Text)
loadedSet = forall a. Ord a => [a] -> Set a
S.fromList (forall k a. Map k a -> [k]
M.keys Map (Text, Text) Document
newLoaded)
      newRequested :: Set (Text, Text)
newRequested = forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Text, Text)
requested (Document -> Set (Text, Text)
documentListIncludes Document
doc)
      notYetLoaded :: Set (Text, Text)
notYetLoaded = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set (Text, Text)
newRequested Set (Text, Text)
loadedSet
  Bool
-> Set (Text, Text)
-> Map (Text, Text) Document
-> [String]
-> [GIRRule]
-> IO (Map (Text, Text) Document)
loadDependencies Bool
verbose Set (Text, Text)
notYetLoaded Map (Text, Text) Document
newLoaded [String]
extraPaths [GIRRule]
rules

-- | Load a given GIR file and recursively its dependencies
loadGIRFile :: Bool             -- ^ verbose
            -> Text             -- ^ name
            -> Maybe Text       -- ^ version
            -> [FilePath]       -- ^ extra paths to search
            -> [GIRRule]        -- ^ overrides
            -> IO (Document,
                   M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies)
loadGIRFile :: Bool
-> Text
-> Maybe Text
-> [String]
-> [GIRRule]
-> IO (Document, Map (Text, Text) Document)
loadGIRFile Bool
verbose Text
name Maybe Text
version [String]
extraPaths [GIRRule]
rules = do
  Document
doc <- [GIRRule] -> Document -> Document
overrideGIRDocument [GIRRule]
rules forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Text -> Maybe Text -> [String] -> IO Document
readGiRepository Bool
verbose Text
name Maybe Text
version [String]
extraPaths
  Map (Text, Text) Document
deps <- Bool
-> Set (Text, Text)
-> Map (Text, Text) Document
-> [String]
-> [GIRRule]
-> IO (Map (Text, Text) Document)
loadDependencies Bool
verbose (Document -> Set (Text, Text)
documentListIncludes Document
doc) forall k a. Map k a
M.empty
          [String]
extraPaths [GIRRule]
rules
  forall (m :: * -> *) a. Monad m => a -> m a
return (Document
doc, Map (Text, Text) Document
deps)

-- | Turn a GIRInfoParse into a proper GIRInfo, doing some sanity
-- checking along the way.
toGIRInfo :: GIRInfoParse -> Either Text GIRInfo
toGIRInfo :: GIRInfoParse -> Either Text GIRInfo
toGIRInfo GIRInfoParse
info =
    case forall a. [Maybe a] -> [a]
catMaybes (GIRInfoParse -> [Maybe GIRNamespace]
girIPNamespaces GIRInfoParse
info) of
      [GIRNamespace
ns] -> forall a b. b -> Either a b
Right GIRInfo {
                girPCPackages :: [Text]
girPCPackages = (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. GIRInfoParse -> [Maybe Text]
girIPPackage) GIRInfoParse
info
              , girNSName :: Text
girNSName = GIRNamespace -> Text
nsName GIRNamespace
ns
              , girNSVersion :: Text
girNSVersion = GIRNamespace -> Text
nsVersion GIRNamespace
ns
              , girAPIs :: [(Name, API)]
girAPIs = forall a. [a] -> [a]
reverse (GIRNamespace -> [(Name, API)]
nsAPIs GIRNamespace
ns)
              , girCTypes :: Map Text Name
girCTypes = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (GIRNamespace -> [(Text, Name)]
nsCTypes GIRNamespace
ns)
              }
      [] -> forall a b. a -> Either a b
Left Text
"Found no valid namespace."
      [GIRNamespace]
_  -> forall a b. a -> Either a b
Left Text
"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 :: Bool -> Text -> Maybe Text -> [String] -> IO GIRInfo
loadRawGIRInfo Bool
verbose Text
name Maybe Text
version [String]
extraPaths = do
  Document
doc <- Bool -> Text -> Maybe Text -> [String] -> IO Document
readGiRepository Bool
verbose Text
name Maybe Text
version [String]
extraPaths
  case GIRInfoParse -> Either Text GIRInfo
toGIRInfo (Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument forall k a. Map k a
M.empty Document
doc) of
    Left Text
err -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"Error when raw parsing \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\": " forall a. Semigroup a => a -> a -> a
<> Text
err
    Right GIRInfo
docGIR -> forall (m :: * -> *) a. Monad m => a -> m a
return GIRInfo
docGIR

-- | Fixup parsed GIRInfos: some of the required information is not
-- found in the GIR files themselves, or does not accurately reflect
-- the content in the dynamic library itself, but this can be
-- corrected by checking the typelib.
fixupGIRInfos :: Bool -> M.Map Text Typelib -> GIRInfo -> [GIRInfo]
              -> IO (GIRInfo, [GIRInfo])
fixupGIRInfos :: Bool
-> Map Text Typelib
-> GIRInfo
-> [GIRInfo]
-> IO (GIRInfo, [GIRInfo])
fixupGIRInfos Bool
verbose Map Text Typelib
typelibMap GIRInfo
doc [GIRInfo]
deps =
  (((Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup (Map Text Typelib -> Map Text Name -> (Name, API) -> IO (Name, API)
fixupInterface Map Text Typelib
typelibMap Map Text Name
ctypes) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
    ((Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup (Map Text Typelib -> (Name, API) -> IO (Name, API)
fixupStruct Map Text Typelib
typelibMap) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
    ((Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup (Name, API) -> IO (Name, API)
fixupUnion forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
    ((Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup (Bool -> Map Text Typelib -> (Name, API) -> IO (Name, API)
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap)
  ) (GIRInfo
doc, [GIRInfo]
deps)
  where fixup :: ((Name, API) -> IO (Name, API))
                 -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
        fixup :: ((Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup (Name, API) -> IO (Name, API)
fixer (GIRInfo
doc, [GIRInfo]
deps) = do
          GIRInfo
fixedDoc <- ((Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo
fixAPIs (Name, API) -> IO (Name, API)
fixer GIRInfo
doc
          [GIRInfo]
fixedDeps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo
fixAPIs (Name, API) -> IO (Name, API)
fixer) [GIRInfo]
deps
          forall (m :: * -> *) a. Monad m => a -> m a
return (GIRInfo
fixedDoc, [GIRInfo]
fixedDeps)

        fixAPIs :: ((Name, API) -> IO (Name, API))
                -> GIRInfo -> IO GIRInfo
        fixAPIs :: ((Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo
fixAPIs (Name, API) -> IO (Name, API)
fixer GIRInfo
info = do
          [(Name, API)]
fixedAPIs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, API) -> IO (Name, API)
fixer (GIRInfo -> [(Name, API)]
girAPIs GIRInfo
info)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GIRInfo
info {girAPIs :: [(Name, API)]
girAPIs = [(Name, API)]
fixedAPIs}

        ctypes :: M.Map Text Name
        ctypes :: Map Text Name
ctypes = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions (forall a b. (a -> b) -> [a] -> [b]
map GIRInfo -> Map Text Name
girCTypes (GIRInfo
docforall a. a -> [a] -> [a]
:[GIRInfo]
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 -> IO [Text]
gtypeInterfaceListPrereqs (GType CGType
cgtype) = do
  Ptr CUInt
nprereqsPtr <- forall a. Storable a => IO (Ptr a)
allocMem :: IO (Ptr CUInt)
  Ptr CGType
ps <- CGType -> Ptr CUInt -> IO (Ptr CGType)
g_type_interface_prerequisites CGType
cgtype Ptr CUInt
nprereqsPtr
  CUInt
nprereqs <- forall a. Storable a => Ptr a -> IO a
peek Ptr CUInt
nprereqsPtr
  [CGType]
psCGTypes <- forall a b. (Integral a, Storable b) => a -> Ptr b -> IO [b]
unpackStorableArrayWithLength CUInt
nprereqs Ptr CGType
ps
  forall a. Ptr a -> IO ()
freeMem Ptr CGType
ps
  forall a. Ptr a -> IO ()
freeMem Ptr CUInt
nprereqsPtr
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. GType -> IO String
gtypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGType -> GType
GType) [CGType]
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 Typelib -> M.Map Text Name -> (Name, API)
               -> IO (Name, API)
fixupInterface :: Map Text Typelib -> Map Text Name -> (Name, API) -> IO (Name, API)
fixupInterface Map Text Typelib
typelibMap Map Text Name
csymbolMap (n :: Name
n@(Name Text
ns Text
_), APIInterface Interface
iface) = do
  [Name]
prereqs <- case Interface -> Maybe Text
ifTypeInit Interface
iface of
               Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
               Just Text
ti -> do
                 GType
gtype <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ns Map Text Typelib
typelibMap of
                            Just Typelib
typelib -> Typelib -> Text -> IO GType
girLoadGType Typelib
typelib Text
ti
                            Maybe Typelib
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"fi: Typelib for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
ns forall a. [a] -> [a] -> [a]
++ String
" not loaded."
                 [Text]
prereqGTypes <- GType -> IO [Text]
gtypeInterfaceListPrereqs GType
gtype
                 forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
prereqGTypes forall a b. (a -> b) -> a -> b
$ \Text
p -> do
                   case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
p Map Text Name
csymbolMap of
                     Just Name
pn -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
pn
                     Maybe Name
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find prerequisite type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
p forall a. [a] -> [a] -> [a]
++ String
" for interface " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Interface -> API
APIInterface (Interface
iface {ifPrerequisites :: [Name]
ifPrerequisites = [Name]
prereqs}))
fixupInterface Map Text Typelib
_ Map Text Name
_ (Name
n, API
api) = forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, API
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 Typelib -> (Name, API)
            -> IO (Name, API)
fixupStruct :: Map Text Typelib -> (Name, API) -> IO (Name, API)
fixupStruct Map Text Typelib
typelibMap (Name
n, APIStruct Struct
s) = do
  Struct
fixed <- (Map Text Typelib -> Name -> Struct -> IO Struct
fixupStructIsBoxed Map Text Typelib
typelibMap Name
n forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Struct -> IO Struct
fixupStructSizeAndOffsets Name
n) Struct
s
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Struct -> API
APIStruct Struct
fixed)
fixupStruct Map Text Typelib
_ (Name, API)
api = forall (m :: * -> *) a. Monad m => a -> m a
return (Name, API)
api

-- | Find out whether the struct is boxed.
fixupStructIsBoxed :: M.Map Text Typelib -> Name -> Struct -> IO Struct
-- The type for "GVariant" is marked as "intern", we wrap
-- this one natively.
fixupStructIsBoxed :: Map Text Typelib -> Name -> Struct -> IO Struct
fixupStructIsBoxed Map Text Typelib
_ (Name Text
"GLib" Text
"Variant") Struct
s =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Struct
s {structIsBoxed :: Bool
structIsBoxed = Bool
False})
fixupStructIsBoxed Map Text Typelib
typelibMap (Name Text
ns Text
_) Struct
s = do
  Bool
isBoxed <- case Struct -> Maybe Text
structTypeInit Struct
s of
               Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Just Text
ti -> do
                 GType
gtype <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ns Map Text Typelib
typelibMap of
                   Just Typelib
typelib -> Typelib -> Text -> IO GType
girLoadGType Typelib
typelib Text
ti
                   Maybe Typelib
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"fsib: Typelib for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
ns forall a. [a] -> [a] -> [a]
++ String
" not loaded."

                 forall (m :: * -> *) a. Monad m => a -> m a
return (GType -> Bool
gtypeIsBoxed GType
gtype)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Struct
s {structIsBoxed :: Bool
structIsBoxed = Bool
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 -> Struct -> IO Struct
fixupStructSizeAndOffsets (Name Text
ns Text
n) Struct
s = do
  (Int
size, Map Text FieldInfo
infoMap) <- Text -> Text -> IO (Int, Map Text FieldInfo)
girStructFieldInfo Text
ns Text
n
  forall (m :: * -> *) a. Monad m => a -> m a
return (Struct
s { structSize :: Int
structSize = Int
size
            , structFields :: [Field]
structFields = forall a b. (a -> b) -> [a] -> [b]
map (Map Text FieldInfo -> Field -> Field
fixupField Map Text FieldInfo
infoMap) (Struct -> [Field]
structFields Struct
s)})

-- | Same thing for unions.
fixupUnion :: (Name, API) -> IO (Name, API)
fixupUnion :: (Name, API) -> IO (Name, API)
fixupUnion (Name
n, APIUnion Union
u) = do
  Union
fixed <- (Name -> Union -> IO Union
fixupUnionSizeAndOffsets Name
n) Union
u
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Union -> API
APIUnion Union
fixed)
fixupUnion (Name, API)
api = forall (m :: * -> *) a. Monad m => a -> m a
return (Name, API)
api

-- | Like 'fixupStructSizeAndOffset' above.
fixupUnionSizeAndOffsets :: Name -> Union -> IO Union
fixupUnionSizeAndOffsets :: Name -> Union -> IO Union
fixupUnionSizeAndOffsets (Name Text
ns Text
n) Union
u = do
  (Int
size, Map Text FieldInfo
infoMap) <- Text -> Text -> IO (Int, Map Text FieldInfo)
girUnionFieldInfo Text
ns Text
n
  forall (m :: * -> *) a. Monad m => a -> m a
return (Union
u { unionSize :: Int
unionSize = Int
size
            , unionFields :: [Field]
unionFields = forall a b. (a -> b) -> [a] -> [b]
map (Map Text FieldInfo -> Field -> Field
fixupField Map Text FieldInfo
infoMap) (Union -> [Field]
unionFields Union
u)})

-- | Fixup the offsets of fields using the given offset map.
fixupField :: M.Map Text FieldInfo -> Field -> Field
fixupField :: Map Text FieldInfo -> Field -> Field
fixupField Map Text FieldInfo
offsetMap Field
f =
    Field
f {fieldOffset :: Int
fieldOffset = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Field -> Text
fieldName Field
f) Map Text FieldInfo
offsetMap of
                       Maybe FieldInfo
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not find field "
                                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Field -> Text
fieldName Field
f)
                       Just FieldInfo
o -> FieldInfo -> Int
fieldInfoOffset FieldInfo
o }

-- | Some of the symbols listed in the introspection data are not
-- present in the dynamic library itself. Generating bindings for
-- these will sometimes lead to linker errors, so here we check that
-- every symbol listed in the bindings is actually present.
fixupMissingSymbols :: Bool -> M.Map Text Typelib -> (Name, API)
                    -> IO (Name, API)
fixupMissingSymbols :: Bool -> Map Text Typelib -> (Name, API) -> IO (Name, API)
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIStruct Struct
s) = do
  [Method]
fixedMethods <- Typelib -> [Method] -> Bool -> IO [Method]
fixupMethodMissingSymbols (Name -> Map Text Typelib -> Typelib
resolveTypelib Name
n Map Text Typelib
typelibMap)
                                            (Struct -> [Method]
structMethods Struct
s) Bool
verbose
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Struct -> API
APIStruct (Struct
s {structMethods :: [Method]
structMethods = [Method]
fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIUnion Union
u) = do
  [Method]
fixedMethods <- Typelib -> [Method] -> Bool -> IO [Method]
fixupMethodMissingSymbols (Name -> Map Text Typelib -> Typelib
resolveTypelib Name
n Map Text Typelib
typelibMap)
                                            (Union -> [Method]
unionMethods Union
u) Bool
verbose
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Union -> API
APIUnion (Union
u {unionMethods :: [Method]
unionMethods = [Method]
fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIObject Object
o) = do
  [Method]
fixedMethods <- Typelib -> [Method] -> Bool -> IO [Method]
fixupMethodMissingSymbols (Name -> Map Text Typelib -> Typelib
resolveTypelib Name
n Map Text Typelib
typelibMap)
                                            (Object -> [Method]
objMethods Object
o) Bool
verbose
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Object -> API
APIObject (Object
o {objMethods :: [Method]
objMethods = [Method]
fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIInterface Interface
i) = do
  [Method]
fixedMethods <- Typelib -> [Method] -> Bool -> IO [Method]
fixupMethodMissingSymbols (Name -> Map Text Typelib -> Typelib
resolveTypelib Name
n Map Text Typelib
typelibMap)
                                            (Interface -> [Method]
ifMethods Interface
i) Bool
verbose
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Interface -> API
APIInterface (Interface
i {ifMethods :: [Method]
ifMethods = [Method]
fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIFunction Function
f) =
  Map Text Typelib -> (Name, Function) -> Bool -> IO (Name, API)
fixupFunctionSymbols Map Text Typelib
typelibMap (Name
n, Function
f) Bool
verbose
fixupMissingSymbols Bool
_ Map Text Typelib
_ (Name
n, API
api) = forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, API
api)

-- | Resolve the typelib owning the given name, erroring out if the
-- typelib is not known.
resolveTypelib :: Name -> M.Map Text Typelib -> Typelib
resolveTypelib :: Name -> Map Text Typelib -> Typelib
resolveTypelib Name
n Map Text Typelib
typelibMap = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Name -> Text
namespace Name
n) Map Text Typelib
typelibMap of
  Maybe Typelib
Nothing -> forall a. HasCallStack => Text -> a
terror forall a b. (a -> b) -> a -> b
$ Text
"Could not find typelib for “" forall a. Semigroup a => a -> a -> a
<> Name -> Text
namespace Name
n forall a. Semigroup a => a -> a -> a
<> Text
"”."
  Just Typelib
typelib -> Typelib
typelib

-- | Mark whether the methods can be resolved in the given typelib.
fixupMethodMissingSymbols :: Typelib -> [Method] -> Bool -> IO [Method]
fixupMethodMissingSymbols :: Typelib -> [Method] -> Bool -> IO [Method]
fixupMethodMissingSymbols Typelib
typelib [Method]
methods Bool
verbose = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Method -> IO Method
check [Method]
methods
  where check :: Method -> IO Method
        check :: Method -> IO Method
check method :: Method
method@Method{methodCallable :: Method -> Callable
methodCallable = Callable
callable} = do
          Bool
resolvable <- Typelib -> Text -> IO Bool
girIsSymbolResolvable Typelib
typelib (Method -> Text
methodSymbol Method
method)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
verbose Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
resolvable) forall a b. (a -> b) -> a -> b
$
            Text -> IO ()
printWarning forall a b. (a -> b) -> a -> b
$ Text
"Could not resolve the callable “"
                           forall a. Semigroup a => a -> a -> a
<> Method -> Text
methodSymbol Method
method
                           forall a. Semigroup a => a -> a -> a
<> Text
"” in the “" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Typelib
typelib
                           forall a. Semigroup a => a -> a -> a
<> Text
"” typelib, ignoring."
          let callable' :: Callable
callable' = Callable
callable{callableResolvable :: Maybe Bool
callableResolvable = forall a. a -> Maybe a
Just Bool
resolvable}
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Method
method{methodCallable :: Callable
methodCallable = Callable
callable'}

-- | Check that the symbol the function refers to is actually present
-- in the dynamic library.
fixupFunctionSymbols :: M.Map Text Typelib -> (Name, Function) -> Bool
                            -> IO (Name, API)
fixupFunctionSymbols :: Map Text Typelib -> (Name, Function) -> Bool -> IO (Name, API)
fixupFunctionSymbols Map Text Typelib
typelibMap (Name
n, Function
f) Bool
verbose = do
  let typelib :: Typelib
typelib = Name -> Map Text Typelib -> Typelib
resolveTypelib Name
n Map Text Typelib
typelibMap
  Bool
resolvable <- Typelib -> Text -> IO Bool
girIsSymbolResolvable Typelib
typelib (Function -> Text
fnSymbol Function
f)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
verbose Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
resolvable) forall a b. (a -> b) -> a -> b
$
    Text -> IO ()
printWarning forall a b. (a -> b) -> a -> b
$ Text
"Could not resolve the function “" forall a. Semigroup a => a -> a -> a
<> Function -> Text
fnSymbol Function
f
                    forall a. Semigroup a => a -> a -> a
<> Text
"” in the “" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Typelib
typelib forall a. Semigroup a => a -> a -> a
<> Text
"” typelib, ignoring."
  let callable' :: Callable
callable' = (Function -> Callable
fnCallable Function
f){callableResolvable :: Maybe Bool
callableResolvable = forall a. a -> Maybe a
Just Bool
resolvable}
  forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Function -> API
APIFunction (Function
f {fnCallable :: Callable
fnCallable = Callable
callable'}))

-- | 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, [GIRInfo])
            -- ^ (parsed doc,  parsed deps)
loadGIRInfo :: Bool
-> Text
-> Maybe Text
-> [String]
-> [GIRRule]
-> IO (GIRInfo, [GIRInfo])
loadGIRInfo Bool
verbose Text
name Maybe Text
version [String]
extraPaths [GIRRule]
rules =  do
  (Document
doc, Map (Text, Text) Document
deps) <- Bool
-> Text
-> Maybe Text
-> [String]
-> [GIRRule]
-> IO (Document, Map (Text, Text) Document)
loadGIRFile Bool
verbose Text
name Maybe Text
version [String]
extraPaths [GIRRule]
rules
  let aliases :: Map Alias Type
aliases = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions (forall a b. (a -> b) -> [a] -> [b]
map Document -> Map Alias Type
documentListAliases (Document
doc forall a. a -> [a] -> [a]
: forall k a. Map k a -> [a]
M.elems Map (Text, Text) Document
deps))
      parsedDoc :: Either Text GIRInfo
parsedDoc = GIRInfoParse -> Either Text GIRInfo
toGIRInfo (Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument Map Alias Type
aliases Document
doc)
      parsedDeps :: [Either Text GIRInfo]
parsedDeps = forall a b. (a -> b) -> [a] -> [b]
map (GIRInfoParse -> Either Text GIRInfo
toGIRInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument Map Alias Type
aliases) (forall k a. Map k a -> [a]
M.elems Map (Text, Text) Document
deps)
  case Either Text GIRInfo
-> [Either Text GIRInfo] -> Either Text (GIRInfo, [GIRInfo])
combineErrors Either Text GIRInfo
parsedDoc [Either Text GIRInfo]
parsedDeps of
    Left Text
err -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"Error when parsing \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\": " forall a. Semigroup a => a -> a -> a
<> Text
err
    Right (GIRInfo
docGIR, [GIRInfo]
depsGIR) -> do
      if GIRInfo -> Text
girNSName GIRInfo
docGIR forall a. Eq a => a -> a -> Bool
== Text
name
      then do
        Map Text Typelib
typelibMap <- forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GIRInfo
docGIR forall a. a -> [a] -> [a]
: [GIRInfo]
depsGIR) forall a b. (a -> b) -> a -> b
$ \GIRInfo
info -> do
             Typelib
typelib <- Text -> Text -> IO Typelib
girRequire (GIRInfo -> Text
girNSName GIRInfo
info) (GIRInfo -> Text
girNSVersion GIRInfo
info)
             forall (m :: * -> *) a. Monad m => a -> m a
return (GIRInfo -> Text
girNSName GIRInfo
info, Typelib
typelib))
        (GIRInfo
fixedDoc, [GIRInfo]
fixedDeps) <- Bool
-> Map Text Typelib
-> GIRInfo
-> [GIRInfo]
-> IO (GIRInfo, [GIRInfo])
fixupGIRInfos Bool
verbose Map Text Typelib
typelibMap GIRInfo
docGIR [GIRInfo]
depsGIR
        forall (m :: * -> *) a. Monad m => a -> m a
return (GIRInfo
fixedDoc, [GIRInfo]
fixedDeps)
      else forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"Got unexpected namespace \""
               forall a. Semigroup a => a -> a -> a
<> GIRInfo -> Text
girNSName GIRInfo
docGIR forall a. Semigroup a => a -> a -> a
<> Text
"\" when parsing \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\"."
  where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]
                      -> Either Text (GIRInfo, [GIRInfo])
        combineErrors :: Either Text GIRInfo
-> [Either Text GIRInfo] -> Either Text (GIRInfo, [GIRInfo])
combineErrors Either Text GIRInfo
parsedDoc [Either Text GIRInfo]
parsedDeps = do
          GIRInfo
doc <- Either Text GIRInfo
parsedDoc
          [GIRInfo]
deps <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either Text GIRInfo]
parsedDeps
          forall (m :: * -> *) a. Monad m => a -> m a
return (GIRInfo
doc, [GIRInfo]
deps)

-- | Given a XML document containing GIR data, apply the given overrides.
overrideGIRDocument :: [GIRRule] -> XML.Document -> XML.Document
overrideGIRDocument :: [GIRRule] -> Document -> Document
overrideGIRDocument [GIRRule]
rules Document
doc =
    Document
doc {documentRoot :: Element
XML.documentRoot = [GIRRule] -> Element -> Element
overrideGIR [GIRRule]
rules (Document -> Element
XML.documentRoot Document
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.
overrideGIR :: [GIRRule] -> XML.Element -> XML.Element
overrideGIR :: [GIRRule] -> Element -> Element
overrideGIR [GIRRule]
rules Element
elem =
    Element
elem {elementNodes :: [Node]
XML.elementNodes =
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Node
e -> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Node -> GIRRule -> Maybe Node
applyGIRRule Node
e [GIRRule]
rules) (Element -> [Node]
XML.elementNodes Element
elem)}
    where applyGIRRule :: XML.Node -> GIRRule -> Maybe XML.Node
          applyGIRRule :: Node -> GIRRule -> Maybe Node
applyGIRRule Node
n (GIRSetAttr ([GIRNodeSpec]
path, Name
attr) Text
newVal) =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ([GIRNodeSpec], Name) -> Text -> Node -> Node
girSetAttr ([GIRNodeSpec]
path, Name
attr) Text
newVal Node
n
          applyGIRRule Node
n (GIRDeleteAttr [GIRNodeSpec]
path Name
attr) =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [GIRNodeSpec] -> Name -> Node -> Node
girDeleteAttr [GIRNodeSpec]
path Name
attr Node
n
          applyGIRRule Node
n (GIRAddNode [GIRNodeSpec]
path Name
new) =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [GIRNodeSpec] -> Name -> Node -> Node
girAddNode [GIRNodeSpec]
path Name
new Node
n
          applyGIRRule Node
n (GIRDeleteNode [GIRNodeSpec]
path) =
            [GIRNodeSpec] -> Node -> Maybe Node
girDeleteNodes [GIRNodeSpec]
path Node
n

-- | Set an attribute for the child element specified by the given
-- path.
girSetAttr :: (GIRPath, XML.Name) -> Text -> XML.Node -> XML.Node
girSetAttr :: ([GIRNodeSpec], Name) -> Text -> Node -> Node
girSetAttr (GIRNodeSpec
spec:[GIRNodeSpec]
rest, Name
attr) Text
newVal n :: Node
n@(XML.NodeElement Element
elem) =
    if GIRNodeSpec -> Node -> Bool
specMatch GIRNodeSpec
spec Node
n
    then case [GIRNodeSpec]
rest of
           -- Matched the full path, apply
           [] -> Element -> Node
XML.NodeElement (Element
elem {elementAttributes :: Map Name Text
XML.elementAttributes =
                                        forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
attr Text
newVal
                                        (Element -> Map Name Text
XML.elementAttributes Element
elem)})
           -- Still some selectors to apply
           [GIRNodeSpec]
_ -> Element -> Node
XML.NodeElement (Element
elem {elementNodes :: [Node]
XML.elementNodes =
                                       forall a b. (a -> b) -> [a] -> [b]
map (([GIRNodeSpec], Name) -> Text -> Node -> Node
girSetAttr ([GIRNodeSpec]
rest, Name
attr) Text
newVal)
                                       (Element -> [Node]
XML.elementNodes Element
elem)})
    else Node
n
girSetAttr ([GIRNodeSpec], Name)
_ Text
_ Node
n = Node
n

-- | Delete an attribute for the child element specified by the given
-- path, if the attribute exists.
girDeleteAttr :: GIRPath -> XML.Name -> XML.Node -> XML.Node
girDeleteAttr :: [GIRNodeSpec] -> Name -> Node -> Node
girDeleteAttr (GIRNodeSpec
spec:[GIRNodeSpec]
rest) Name
attr n :: Node
n@(XML.NodeElement Element
elem) =
    if GIRNodeSpec -> Node -> Bool
specMatch GIRNodeSpec
spec Node
n
    then case [GIRNodeSpec]
rest of
           -- Matched the full path, apply
           [] -> Element -> Node
XML.NodeElement (Element
elem {elementAttributes :: Map Name Text
XML.elementAttributes =
                                        forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
attr
                                        (Element -> Map Name Text
XML.elementAttributes Element
elem)})
           -- Still some selectors to apply
           [GIRNodeSpec]
_ -> Element -> Node
XML.NodeElement (Element
elem {elementNodes :: [Node]
XML.elementNodes =
                                       forall a b. (a -> b) -> [a] -> [b]
map ([GIRNodeSpec] -> Name -> Node -> Node
girDeleteAttr [GIRNodeSpec]
rest Name
attr)
                                       (Element -> [Node]
XML.elementNodes Element
elem)})
    else Node
n
girDeleteAttr [GIRNodeSpec]
_ Name
_ Node
n = Node
n

-- | Add the given subnode to any nodes matching the given path
girAddNode :: GIRPath -> XML.Name -> XML.Node -> XML.Node
girAddNode :: [GIRNodeSpec] -> Name -> Node -> Node
girAddNode (GIRNodeSpec
spec:[GIRNodeSpec]
rest) Name
newNode n :: Node
n@(XML.NodeElement Element
element) =
  if GIRNodeSpec -> Node -> Bool
specMatch GIRNodeSpec
spec Node
n
  then case [GIRNodeSpec]
rest of
    -- Matched the full path, add the new child node.
    [] -> let newElement :: Element
newElement = XML.Element { elementName :: Name
elementName = Name
newNode
                                       , elementAttributes :: Map Name Text
elementAttributes = forall k a. Map k a
M.empty
                                       , elementNodes :: [Node]
elementNodes = [] }
              -- We only insert if not present, see #171. For
              -- convenience when writing the override files, we
              -- ignore the namespace when comparing.
              nodeElementName :: Node -> Maybe Text
nodeElementName (XML.NodeElement Element
e) =
                (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameLocalName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName) Element
e
              nodeElementName Node
_ = forall a. Maybe a
Nothing
              nodeNames :: [Text]
nodeNames = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe Text
nodeElementName (Element -> [Node]
XML.elementNodes Element
element)
          in if Name -> Text
nameLocalName Name
newNode forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
nodeNames
             then Node
n
             else Element -> Node
XML.NodeElement (Element
element {elementNodes :: [Node]
XML.elementNodes =
                                    Element -> [Node]
XML.elementNodes Element
element forall a. Semigroup a => a -> a -> a
<>
                                     [Element -> Node
XML.NodeElement Element
newElement]})
    -- Still some selectors to apply.
    [GIRNodeSpec]
_ -> Element -> Node
XML.NodeElement (Element
element {elementNodes :: [Node]
XML.elementNodes =
                                forall a b. (a -> b) -> [a] -> [b]
map ([GIRNodeSpec] -> Name -> Node -> Node
girAddNode [GIRNodeSpec]
rest Name
newNode)
                                 (Element -> [Node]
XML.elementNodes Element
element)})
  else Node
n
girAddNode [GIRNodeSpec]
_ Name
_ Node
n = Node
n

-- | Delete any nodes matching the given path.
girDeleteNodes :: GIRPath -> XML.Node -> Maybe XML.Node
girDeleteNodes :: [GIRNodeSpec] -> Node -> Maybe Node
girDeleteNodes (GIRNodeSpec
spec:[GIRNodeSpec]
rest) n :: Node
n@(XML.NodeElement Element
elem) =
  if GIRNodeSpec -> Node -> Bool
specMatch GIRNodeSpec
spec Node
n
  then case [GIRNodeSpec]
rest of
         -- Matched the full path, discard the node
         [] -> forall a. Maybe a
Nothing
         -- More selectors to apply
         [GIRNodeSpec]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Element -> Node
XML.NodeElement (Element
elem {elementNodes :: [Node]
XML.elementNodes =
                                            forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([GIRNodeSpec] -> Node -> Maybe Node
girDeleteNodes [GIRNodeSpec]
rest)
                                            (Element -> [Node]
XML.elementNodes Element
elem)})
  else forall a. a -> Maybe a
Just Node
n
girDeleteNodes [GIRNodeSpec]
_ Node
n = forall a. a -> Maybe a
Just Node
n

-- | Lookup the given attribute and if present see if it matches the
-- given regex.
lookupAndMatch :: GIRNameTag -> M.Map XML.Name Text -> XML.Name -> Bool
lookupAndMatch :: GIRNameTag -> Map Name Text -> Name -> Bool
lookupAndMatch GIRNameTag
tag Map Name Text
attrs Name
attr =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
attr Map Name Text
attrs of
      Just Text
s -> case GIRNameTag
tag of
                  GIRPlainName Text
pn -> Text
s forall a. Eq a => a -> a -> Bool
== Text
pn
                  GIRRegex Text
r -> Text -> String
T.unpack Text
s forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Text -> String
T.unpack Text
r
      Maybe Text
Nothing -> Bool
False

-- | See if a given node specification applies to the given node.
specMatch :: GIRNodeSpec -> XML.Node -> Bool
specMatch :: GIRNodeSpec -> Node -> Bool
specMatch (GIRType Text
t) (XML.NodeElement Element
elem) =
    Name -> Text
XML.nameLocalName (Element -> Name
XML.elementName Element
elem) forall a. Eq a => a -> a -> Bool
== Text
t
specMatch (GIRNamed GIRNameTag
name) (XML.NodeElement Element
elem) =
    GIRNameTag -> Map Name Text -> Name -> Bool
lookupAndMatch GIRNameTag
name  (Element -> Map Name Text
XML.elementAttributes Element
elem) (Text -> Name
xmlLocalName Text
"name")
specMatch (GIRTypedName Text
t GIRNameTag
name) (XML.NodeElement Element
elem) =
    Name -> Text
XML.nameLocalName (Element -> Name
XML.elementName Element
elem) forall a. Eq a => a -> a -> Bool
== Text
t Bool -> Bool -> Bool
&&
    GIRNameTag -> Map Name Text -> Name -> Bool
lookupAndMatch GIRNameTag
name (Element -> Map Name Text
XML.elementAttributes Element
elem) (Text -> Name
xmlLocalName Text
"name")
specMatch GIRNodeSpec
_ Node
_ = Bool
False