{-# 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
(Int -> GIRInfo -> ShowS)
-> (GIRInfo -> String) -> ([GIRInfo] -> ShowS) -> Show GIRInfo
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
(Int -> GIRNamespace -> ShowS)
-> (GIRNamespace -> String)
-> ([GIRNamespace] -> ShowS)
-> Show GIRNamespace
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
(Int -> GIRInfoParse -> ShowS)
-> (GIRInfoParse -> String)
-> ([GIRInfoParse] -> ShowS)
-> Show GIRInfoParse
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
(Int -> GIRNodeSpec -> ShowS)
-> (GIRNodeSpec -> String)
-> ([GIRNodeSpec] -> ShowS)
-> Show GIRNodeSpec
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
(Int -> GIRNameTag -> ShowS)
-> (GIRNameTag -> String)
-> ([GIRNameTag] -> ShowS)
-> Show GIRNameTag
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
(Int -> GIRRule -> ShowS)
-> (GIRRule -> String) -> ([GIRRule] -> ShowS) -> Show GIRRule
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
(Int -> API -> ShowS)
-> (API -> String) -> ([API] -> ShowS) -> Show API
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 :: 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 Text
-> Map Alias Type
-> Element
-> Parser (Name, a)
-> Either Text (Name, a)
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 -> String -> (Name, API)
forall a. HasCallStack => String -> a
error (String -> (Name, API)) -> String -> (Name, API)
forall a b. (a -> b) -> a -> b
$ String
"Parse error: " String -> ShowS
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 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
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" -> (Constant -> API) -> Parser (Name, Constant) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Constant -> API
APIConst Parser (Name, Constant)
parseConstant
          Text
"enumeration" -> (Enumeration -> API) -> Parser (Name, Enumeration) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Enumeration -> API
APIEnum Parser (Name, Enumeration)
parseEnum
          Text
"bitfield" -> (Flags -> API) -> Parser (Name, Flags) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Flags -> API
APIFlags Parser (Name, Flags)
parseFlags
          Text
"function" -> (Function -> API) -> Parser (Name, Function) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Function -> API
APIFunction Parser (Name, Function)
parseFunction
          Text
"callback" -> (Callback -> API) -> Parser (Name, Callback) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Callback -> API
APICallback Parser (Name, Callback)
parseCallback
          Text
"record" -> (Struct -> API) -> Parser (Name, Struct) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Struct -> API
APIStruct Parser (Name, Struct)
parseStruct
          Text
"union" -> (Union -> API) -> Parser (Name, Union) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Union -> API
APIUnion Parser (Name, Union)
parseUnion
          Text
"class" -> (Object -> API) -> Parser (Name, Object) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Object -> API
APIObject Parser (Name, Object)
parseObject
          Text
"interface" -> (Interface -> API) -> Parser (Name, Interface) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Interface -> API
APIInterface Parser (Name, Interface)
parseInterface
          Text
"boxed" -> GIRNamespace
ns -- Unsupported
          Text
n -> String -> GIRNamespace
forall a. HasCallStack => String -> a
error (String -> GIRNamespace)
-> (Text -> String) -> Text -> GIRNamespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> GIRNamespace) -> Text -> GIRNamespace
forall a b. (a -> b) -> a -> b
$ Text
"Unknown GIR element \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" when processing namespace \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nsName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\", aborting."
    where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace
          parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace
parse a -> API
wrapper Parser (Name, a)
parser =
              let (Name
n, API
api) = Text
-> Map Alias Type
-> Element
-> (a -> API)
-> Parser (Name, a)
-> (Name, 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) (Name, API) -> [(Name, API)] -> [(Name, 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) (Text, Name) -> [(Text, Name)] -> [(Text, Name)]
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 <- Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"name" Map Name Text
attrs
  Text
version <- Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"version" Map Name Text
attrs
  let ns :: GIRNamespace
ns = GIRNamespace :: Text -> Text -> [(Name, API)] -> [(Text, Name)] -> GIRNamespace
GIRNamespace {
             nsName :: Text
nsName         = Text
name,
             nsVersion :: Text
nsVersion      = Text
version,
             nsAPIs :: [(Name, API)]
nsAPIs         = [],
             nsCTypes :: [(Text, Name)]
nsCTypes       = []
           }
  GIRNamespace -> Maybe GIRNamespace
forall (m :: * -> *) a. Monad m => a -> m a
return ((GIRNamespace -> Element -> GIRNamespace)
-> GIRNamespace -> [Element] -> GIRNamespace
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 <- Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"name" Map Name Text
attrs
  Text
version <- Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"version" Map Name Text
attrs
  (Text, Text) -> Maybe (Text, Text)
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 = Name -> Map Name Text -> Maybe Text
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 Maybe (Text, Text) -> [Maybe (Text, Text)] -> [Maybe (Text, Text)]
forall a. a -> [a] -> [a]
: [Maybe (Text, Text)]
girIPIncludes}
      Text
"package" -> GIRInfoParse
info {girIPPackage :: [Maybe Text]
girIPPackage = Element -> Maybe Text
parsePackage Element
element Maybe Text -> [Maybe Text] -> [Maybe Text]
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 Maybe GIRNamespace -> [Maybe GIRNamespace] -> [Maybe GIRNamespace]
forall a. a -> [a] -> [a]
: [Maybe GIRNamespace]
girIPNamespaces}
      Text
_ -> GIRInfoParse
info

emptyGIRInfoParse :: GIRInfoParse
emptyGIRInfoParse :: GIRInfoParse
emptyGIRInfoParse = GIRInfoParse :: [Maybe Text]
-> [Maybe (Text, Text)] -> [Maybe GIRNamespace] -> GIRInfoParse
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 = (GIRInfoParse -> Element -> GIRInfoParse)
-> GIRInfoParse -> [Element] -> GIRInfoParse
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 = [(Text, Text)] -> Set (Text, Text)
forall a. Ord a => [a] -> Set a
S.fromList ((Element -> Maybe (Text, Text)) -> [Element] -> [(Text, Text)]
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
        | Set (Text, Text) -> Bool
forall a. Set a -> Bool
S.null Set (Text, Text)
requested = Map (Text, Text) Document -> IO (Map (Text, Text) Document)
forall (m :: * -> *) a. Monad m => a -> m a
return Map (Text, Text) Document
loaded
        | Bool
otherwise = do
  let (Text
name, Text
version) = Int -> Set (Text, Text) -> (Text, Text)
forall a. Int -> Set a -> a
S.elemAt Int
0 Set (Text, Text)
requested
  Document
doc <- [GIRRule] -> Document -> Document
overrideGIRDocument [GIRRule]
rules (Document -> Document) -> IO Document -> IO Document
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         Bool -> Text -> Maybe Text -> [String] -> IO Document
readGiRepository Bool
verbose Text
name (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version) [String]
extraPaths
  let newLoaded :: Map (Text, Text) Document
newLoaded = (Text, Text)
-> Document
-> Map (Text, Text) Document
-> Map (Text, Text) Document
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 = [(Text, Text)] -> Set (Text, Text)
forall a. Ord a => [a] -> Set a
S.fromList (Map (Text, Text) Document -> [(Text, Text)]
forall k a. Map k a -> [k]
M.keys Map (Text, Text) Document
newLoaded)
      newRequested :: Set (Text, Text)
newRequested = Set (Text, Text) -> Set (Text, Text) -> Set (Text, Text)
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 = Set (Text, Text) -> Set (Text, Text) -> Set (Text, Text)
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 (Document -> Document) -> IO Document -> IO Document
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) Map (Text, Text) Document
forall k a. Map k a
M.empty
          [String]
extraPaths [GIRRule]
rules
  (Document, Map (Text, Text) Document)
-> IO (Document, Map (Text, Text) Document)
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 [Maybe GIRNamespace] -> [GIRNamespace]
forall a. [Maybe a] -> [a]
catMaybes (GIRInfoParse -> [Maybe GIRNamespace]
girIPNamespaces GIRInfoParse
info) of
      [GIRNamespace
ns] -> GIRInfo -> Either Text GIRInfo
forall a b. b -> Either a b
Right GIRInfo :: [Text] -> Text -> Text -> [(Name, API)] -> Map Text Name -> GIRInfo
GIRInfo {
                girPCPackages :: [Text]
girPCPackages = ([Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> (GIRInfoParse -> [Text]) -> GIRInfoParse -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> (GIRInfoParse -> [Maybe Text]) -> GIRInfoParse -> [Text]
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 = [(Name, API)] -> [(Name, API)]
forall a. [a] -> [a]
reverse (GIRNamespace -> [(Name, API)]
nsAPIs GIRNamespace
ns)
              , girCTypes :: Map Text Name
girCTypes = [(Text, Name)] -> Map Text Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (GIRNamespace -> [(Text, Name)]
nsCTypes GIRNamespace
ns)
              }
      [] -> Text -> Either Text GIRInfo
forall a b. a -> Either a b
Left Text
"Found no valid namespace."
      [GIRNamespace]
_  -> Text -> Either Text GIRInfo
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 Map Alias Type
forall k a. Map k a
M.empty Document
doc) of
    Left Text
err -> String -> IO GIRInfo
forall a. HasCallStack => String -> a
error (String -> IO GIRInfo) -> (Text -> String) -> Text -> IO GIRInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO GIRInfo) -> Text -> IO GIRInfo
forall a b. (a -> b) -> a -> b
$ Text
"Error when raw parsing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
    Right GIRInfo
docGIR -> GIRInfo -> IO GIRInfo
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) ((GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]))
-> ((GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]))
-> (GIRInfo, [GIRInfo])
-> IO (GIRInfo, [GIRInfo])
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) ((GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]))
-> ((GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]))
-> (GIRInfo, [GIRInfo])
-> IO (GIRInfo, [GIRInfo])
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 ((GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]))
-> ((GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo]))
-> (GIRInfo, [GIRInfo])
-> IO (GIRInfo, [GIRInfo])
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 <- (GIRInfo -> IO GIRInfo) -> [GIRInfo] -> IO [GIRInfo]
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
          (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
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 <- ((Name, API) -> IO (Name, API))
-> [(Name, API)] -> IO [(Name, API)]
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)
          GIRInfo -> IO GIRInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (GIRInfo -> IO GIRInfo) -> GIRInfo -> IO GIRInfo
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 = [Map Text Name] -> Map Text Name
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ((GIRInfo -> Map Text Name) -> [GIRInfo] -> [Map Text Name]
forall a b. (a -> b) -> [a] -> [b]
map GIRInfo -> Map Text Name
girCTypes (GIRInfo
docGIRInfo -> [GIRInfo] -> [GIRInfo]
forall 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 <- IO (Ptr CUInt)
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 <- Ptr CUInt -> IO CUInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CUInt
nprereqsPtr
  [CGType]
psCGTypes <- CUInt -> Ptr CGType -> IO [CGType]
forall a b. (Integral a, Storable b) => a -> Ptr b -> IO [b]
unpackStorableArrayWithLength CUInt
nprereqs Ptr CGType
ps
  Ptr CGType -> IO ()
forall a. Ptr a -> IO ()
freeMem Ptr CGType
ps
  Ptr CUInt -> IO ()
forall a. Ptr a -> IO ()
freeMem Ptr CUInt
nprereqsPtr
  (CGType -> IO Text) -> [CGType] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack (IO String -> IO Text)
-> (CGType -> IO String) -> CGType -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GType -> IO String
gtypeName (GType -> IO String) -> (CGType -> GType) -> CGType -> IO String
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 -> [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return []
               Just Text
ti -> do
                 GType
gtype <- case Text -> Map Text Typelib -> Maybe Typelib
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 -> String -> IO GType
forall a. HasCallStack => String -> a
error (String -> IO GType) -> String -> IO GType
forall a b. (a -> b) -> a -> b
$ String
"fi: Typelib for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not loaded."
                 [Text]
prereqGTypes <- GType -> IO [Text]
gtypeInterfaceListPrereqs GType
gtype
                 [Text] -> (Text -> IO Name) -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
prereqGTypes ((Text -> IO Name) -> IO [Name]) -> (Text -> IO Name) -> IO [Name]
forall a b. (a -> b) -> a -> b
$ \Text
p -> do
                   case Text -> Map Text Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
p Map Text Name
csymbolMap of
                     Just Name
pn -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
pn
                     Maybe Name
Nothing -> String -> IO Name
forall a. HasCallStack => String -> a
error (String -> IO Name) -> String -> IO Name
forall a b. (a -> b) -> a -> b
$ String
"Could not find prerequisite type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for interface " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
  (Name, API) -> IO (Name, API)
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) = (Name, API) -> IO (Name, 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 (Struct -> IO Struct)
-> (Struct -> IO Struct) -> Struct -> IO Struct
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
  (Name, API) -> IO (Name, API)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Struct -> API
APIStruct Struct
fixed)
fixupStruct Map Text Typelib
_ (Name, API)
api = (Name, API) -> IO (Name, 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 =
    Struct -> IO Struct
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 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Just Text
ti -> do
                 GType
gtype <- case Text -> Map Text Typelib -> Maybe Typelib
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 -> String -> IO GType
forall a. HasCallStack => String -> a
error (String -> IO GType) -> String -> IO GType
forall a b. (a -> b) -> a -> b
$ String
"fsib: Typelib for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not loaded."

                 Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (GType -> Bool
gtypeIsBoxed GType
gtype)
  Struct -> IO Struct
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
  Struct -> IO Struct
forall (m :: * -> *) a. Monad m => a -> m a
return (Struct
s { structSize :: Int
structSize = Int
size
            , structFields :: [Field]
structFields = (Field -> Field) -> [Field] -> [Field]
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
  (Name, API) -> IO (Name, API)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Union -> API
APIUnion Union
fixed)
fixupUnion (Name, API)
api = (Name, API) -> IO (Name, 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
  Union -> IO Union
forall (m :: * -> *) a. Monad m => a -> m a
return (Union
u { unionSize :: Int
unionSize = Int
size
            , unionFields :: [Field]
unionFields = (Field -> Field) -> [Field] -> [Field]
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 Text -> Map Text FieldInfo -> Maybe FieldInfo
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 -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"Could not find field "
                                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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
  (Name, API) -> IO (Name, API)
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
  (Name, API) -> IO (Name, API)
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
  (Name, API) -> IO (Name, API)
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
  (Name, API) -> IO (Name, API)
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) = (Name, API) -> IO (Name, 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 Text -> Map Text Typelib -> Maybe Typelib
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 -> Text -> Typelib
forall a. HasCallStack => Text -> a
terror (Text -> Typelib) -> Text -> Typelib
forall a b. (a -> b) -> a -> b
$ Text
"Could not find typelib for “" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
namespace Name
n Text -> Text -> Text
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 = (Method -> IO Method) -> [Method] -> IO [Method]
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)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
verbose Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
resolvable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> IO ()
printWarning (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Could not resolve the callable “"
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Method -> Text
methodSymbol Method
method
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"” in the “" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Typelib -> Text
forall a. Show a => a -> Text
tshow Typelib
typelib
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"” typelib, ignoring."
          let callable' :: Callable
callable' = Callable
callable{callableResolvable :: Maybe Bool
callableResolvable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
resolvable}
          Method -> IO Method
forall (m :: * -> *) a. Monad m => a -> m a
return (Method -> IO Method) -> Method -> IO Method
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)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
verbose Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
resolvable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text -> IO ()
printWarning (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Could not resolve the function “" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Function -> Text
fnSymbol Function
f
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"” in the “" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Typelib -> Text
forall a. Show a => a -> Text
tshow Typelib
typelib Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"” typelib, ignoring."
  let callable' :: Callable
callable' = (Function -> Callable
fnCallable Function
f){callableResolvable :: Maybe Bool
callableResolvable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
resolvable}
  (Name, API) -> IO (Name, API)
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 = [Map Alias Type] -> Map Alias Type
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ((Document -> Map Alias Type) -> [Document] -> [Map Alias Type]
forall a b. (a -> b) -> [a] -> [b]
map Document -> Map Alias Type
documentListAliases (Document
doc Document -> [Document] -> [Document]
forall a. a -> [a] -> [a]
: Map (Text, Text) Document -> [Document]
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 = (Document -> Either Text GIRInfo)
-> [Document] -> [Either Text GIRInfo]
forall a b. (a -> b) -> [a] -> [b]
map (GIRInfoParse -> Either Text GIRInfo
toGIRInfo (GIRInfoParse -> Either Text GIRInfo)
-> (Document -> GIRInfoParse) -> Document -> Either Text GIRInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument Map Alias Type
aliases) (Map (Text, Text) Document -> [Document]
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 -> String -> IO (GIRInfo, [GIRInfo])
forall a. HasCallStack => String -> a
error (String -> IO (GIRInfo, [GIRInfo]))
-> (Text -> String) -> Text -> IO (GIRInfo, [GIRInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO (GIRInfo, [GIRInfo]))
-> Text -> IO (GIRInfo, [GIRInfo])
forall a b. (a -> b) -> a -> b
$ Text
"Error when parsing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
    Right (GIRInfo
docGIR, [GIRInfo]
depsGIR) -> do
      if GIRInfo -> Text
girNSName GIRInfo
docGIR Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
      then do
        Map Text Typelib
typelibMap <- [(Text, Typelib)] -> Map Text Typelib
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Typelib)] -> Map Text Typelib)
-> IO [(Text, Typelib)] -> IO (Map Text Typelib)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([GIRInfo]
-> (GIRInfo -> IO (Text, Typelib)) -> IO [(Text, Typelib)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (GIRInfo
docGIR GIRInfo -> [GIRInfo] -> [GIRInfo]
forall a. a -> [a] -> [a]
: [GIRInfo]
depsGIR) ((GIRInfo -> IO (Text, Typelib)) -> IO [(Text, Typelib)])
-> (GIRInfo -> IO (Text, Typelib)) -> IO [(Text, Typelib)]
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)
             (Text, Typelib) -> IO (Text, Typelib)
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
        (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (GIRInfo
fixedDoc, [GIRInfo]
fixedDeps)
      else String -> IO (GIRInfo, [GIRInfo])
forall a. HasCallStack => String -> a
error (String -> IO (GIRInfo, [GIRInfo]))
-> (Text -> String) -> Text -> IO (GIRInfo, [GIRInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO (GIRInfo, [GIRInfo]))
-> Text -> IO (GIRInfo, [GIRInfo])
forall a b. (a -> b) -> a -> b
$ Text
"Got unexpected namespace \""
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GIRInfo -> Text
girNSName GIRInfo
docGIR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" when parsing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
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 <- [Either Text GIRInfo] -> Either Text [GIRInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either Text GIRInfo]
parsedDeps
          (GIRInfo, [GIRInfo]) -> Either Text (GIRInfo, [GIRInfo])
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 =
          (Node -> Maybe Node) -> [Node] -> [Node]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Node
e -> (Node -> GIRRule -> Maybe Node) -> Node -> [GIRRule] -> Maybe Node
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) =
            Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
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) =
            Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
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) =
            Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
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 =
                                        Name -> Text -> Map Name Text -> Map Name Text
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 =
                                       (Node -> Node) -> [Node] -> [Node]
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 =
                                        Name -> Map Name Text -> Map Name Text
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 =
                                       (Node -> Node) -> [Node] -> [Node]
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 = Element :: Name -> Map Name Text -> [Node] -> Element
XML.Element { elementName :: Name
elementName = Name
newNode
                                       , elementAttributes :: Map Name Text
elementAttributes = Map Name Text
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) =
                (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Element -> Text) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameLocalName (Name -> Text) -> (Element -> Name) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName) Element
e
              nodeElementName Node
_ = Maybe Text
forall a. Maybe a
Nothing
              nodeNames :: [Text]
nodeNames = (Node -> Maybe Text) -> [Node] -> [Text]
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 Text -> [Text] -> Bool
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 [Node] -> [Node] -> [Node]
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 =
                                (Node -> Node) -> [Node] -> [Node]
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
         [] -> Maybe Node
forall a. Maybe a
Nothing
         -- More selectors to apply
         [GIRNodeSpec]
_ -> Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Element -> Node
XML.NodeElement (Element
elem {elementNodes :: [Node]
XML.elementNodes =
                                            (Node -> Maybe Node) -> [Node] -> [Node]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([GIRNodeSpec] -> Node -> Maybe Node
girDeleteNodes [GIRNodeSpec]
rest)
                                            (Element -> [Node]
XML.elementNodes Element
elem)})
  else Node -> Maybe Node
forall a. a -> Maybe a
Just Node
n
girDeleteNodes [GIRNodeSpec]
_ Node
n = Node -> Maybe Node
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 Name -> Map Name Text -> Maybe Text
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
pn
                  GIRRegex Text
r -> Text -> String
T.unpack Text
s String -> String -> Bool
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) Text -> Text -> Bool
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) Text -> Text -> Bool
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