{-# 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, forM_)
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, FieldInfo(..),
                                        girStructFieldInfo, girUnionFieldInfo,
                                        girLoadGType)
import Data.GI.CodeGen.GType (gtypeIsBoxed)
import Data.GI.CodeGen.Type (Type)

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.
             | 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)

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 ns :: Text
ns aliases :: Map Alias Type
aliases element :: Element
element wrapper :: a -> API
wrapper parser :: 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 err :: Text
err -> String -> (Name, API)
forall a. HasCallStack => String -> a
error (String -> (Name, API)) -> String -> (Name, API)
forall a b. (a -> b) -> a -> b
$ "Parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
err
      Right (n :: Name
n, a :: 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 aliases :: Map Alias Type
aliases ns :: GIRNamespace
ns@GIRNamespace{..} element :: Element
element
    | Name -> Element -> Maybe Text
lookupAttr "introspectable" Element
element Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "0" = GIRNamespace
ns
    | Bool
otherwise =
        case Name -> Text
nameLocalName (Element -> Name
elementName Element
element) of
          "alias" -> GIRNamespace
ns     -- Processed separately
          "constant" -> (Constant -> API) -> Parser (Name, Constant) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Constant -> API
APIConst Parser (Name, Constant)
parseConstant
          "enumeration" -> (Enumeration -> API) -> Parser (Name, Enumeration) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Enumeration -> API
APIEnum Parser (Name, Enumeration)
parseEnum
          "bitfield" -> (Flags -> API) -> Parser (Name, Flags) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Flags -> API
APIFlags Parser (Name, Flags)
parseFlags
          "function" -> (Function -> API) -> Parser (Name, Function) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Function -> API
APIFunction Parser (Name, Function)
parseFunction
          "callback" -> (Callback -> API) -> Parser (Name, Callback) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Callback -> API
APICallback Parser (Name, Callback)
parseCallback
          "record" -> (Struct -> API) -> Parser (Name, Struct) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Struct -> API
APIStruct Parser (Name, Struct)
parseStruct
          "union" -> (Union -> API) -> Parser (Name, Union) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Union -> API
APIUnion Parser (Name, Union)
parseUnion
          "class" -> (Object -> API) -> Parser (Name, Object) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Object -> API
APIObject Parser (Name, Object)
parseObject
          "interface" -> (Interface -> API) -> Parser (Name, Interface) -> GIRNamespace
forall a. (a -> API) -> Parser (Name, a) -> GIRNamespace
parse Interface -> API
APIInterface Parser (Name, Interface)
parseInterface
          "boxed" -> GIRNamespace
ns -- Unsupported
          n :: 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
$ "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
<> "\" 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
<> "\", aborting."
    where parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace
          parse :: (a -> API) -> Parser (Name, a) -> GIRNamespace
parse wrapper :: a -> API
wrapper parser :: Parser (Name, a)
parser =
              let (n :: Name
n, api :: 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 "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 ctype :: Text
ctype -> (Text
ctype, Name
n) (Text, Name) -> [(Text, Name)] -> [(Text, Name)]
forall a. a -> [a] -> [a]
: [(Text, Name)]
nsCTypes
                                   Nothing -> [(Text, Name)]
nsCTypes
                    }

parseNamespace :: Element -> M.Map Alias Type -> Maybe GIRNamespace
parseNamespace :: Element -> Map Alias Type -> Maybe GIRNamespace
parseNamespace element :: Element
element aliases :: 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" 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 "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
element = do
  Text
name <- Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "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 "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
element = Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "name" (Element -> Map Name Text
elementAttributes Element
element)

parseRootElement :: M.Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse
parseRootElement :: Map Alias Type -> GIRInfoParse -> Element -> GIRInfoParse
parseRootElement aliases :: Map Alias Type
aliases info :: GIRInfoParse
info@GIRInfoParse{..} element :: Element
element =
    case Name -> Text
nameLocalName (Element -> Name
elementName Element
element) of
      "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}
      "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}
      "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}
      _ -> 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 aliases :: Map Alias Type
aliases doc :: 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 doc :: 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 "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 verbose :: Bool
verbose requested :: Set (Text, Text)
requested loaded :: Map (Text, Text) Document
loaded extraPaths :: [String]
extraPaths rules :: [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 (name :: Text
name, version :: Text
version) = Int -> Set (Text, Text) -> (Text, Text)
forall a. Int -> Set a -> a
S.elemAt 0 Set (Text, Text)
requested
  Document
doc <- [GIRRule] -> Document -> Document
fixupGIRDocument [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]        -- ^ fixups
            -> IO (Document,
                   M.Map (Text, Text) Document) -- ^ (loaded doc, dependencies)
loadGIRFile :: Bool
-> Text
-> Maybe Text
-> [String]
-> [GIRRule]
-> IO (Document, Map (Text, Text) Document)
loadGIRFile verbose :: Bool
verbose name :: Text
name version :: Maybe Text
version extraPaths :: [String]
extraPaths rules :: [GIRRule]
rules = do
  Document
doc <- [GIRRule] -> Document -> Document
fixupGIRDocument [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 info :: GIRInfoParse
info =
    case [Maybe GIRNamespace] -> [GIRNamespace]
forall a. [Maybe a] -> [a]
catMaybes (GIRInfoParse -> [Maybe GIRNamespace]
girIPNamespaces GIRInfoParse
info) of
      [ns :: 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 "Found no valid namespace."
      _  -> Text -> Either Text GIRInfo
forall a b. a -> Either a b
Left "Found multiple namespaces."

-- | Bare minimum loading and parsing of a single repository, without
-- loading or parsing its dependencies, resolving aliases, or fixing
-- up structs or interfaces.
loadRawGIRInfo :: Bool          -- ^ verbose
               -> Text          -- ^ name
               -> Maybe Text    -- ^ version
               -> [FilePath]    -- ^ extra paths to search
               -> IO GIRInfo    -- ^ bare parsed document
loadRawGIRInfo :: Bool -> Text -> Maybe Text -> [String] -> IO GIRInfo
loadRawGIRInfo verbose :: Bool
verbose name :: Text
name version :: Maybe Text
version extraPaths :: [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 err :: 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
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
err
    Right docGIR :: GIRInfo
docGIR -> GIRInfo -> IO GIRInfo
forall (m :: * -> *) a. Monad m => a -> m a
return GIRInfo
docGIR

-- | Load and parse a GIR file, including its dependencies.
loadGIRInfo :: Bool             -- ^ verbose
            -> Text             -- ^ name
            -> Maybe Text       -- ^ version
            -> [FilePath]       -- ^ extra paths to search
            -> [GIRRule]        -- ^ fixups
            -> IO (GIRInfo,
                   [GIRInfo])   -- ^ (parsed doc, parsed deps)
loadGIRInfo :: Bool
-> Text
-> Maybe Text
-> [String]
-> [GIRRule]
-> IO (GIRInfo, [GIRInfo])
loadGIRInfo verbose :: Bool
verbose name :: Text
name version :: Maybe Text
version extraPaths :: [String]
extraPaths rules :: [GIRRule]
rules =  do
  (doc :: Document
doc, deps :: 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 err :: 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
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
err
    Right (docGIR :: GIRInfo
docGIR, depsGIR :: [GIRInfo]
depsGIR) -> do
      if GIRInfo -> Text
girNSName GIRInfo
docGIR Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
      then do
        [GIRInfo] -> (GIRInfo -> IO Typelib) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GIRInfo
docGIR GIRInfo -> [GIRInfo] -> [GIRInfo]
forall a. a -> [a] -> [a]
: [GIRInfo]
depsGIR) ((GIRInfo -> IO Typelib) -> IO ())
-> (GIRInfo -> IO Typelib) -> IO ()
forall a b. (a -> b) -> a -> b
$ \info :: GIRInfo
info ->
            Text -> Text -> IO Typelib
girRequire (GIRInfo -> Text
girNSName GIRInfo
info) (GIRInfo -> Text
girNSVersion GIRInfo
info)
        (fixedDoc :: GIRInfo
fixedDoc, fixedDeps :: [GIRInfo]
fixedDeps) <- GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])
fixupGIRInfos 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
$ "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
<> "\" when parsing \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"."
  where combineErrors :: Either Text GIRInfo -> [Either Text GIRInfo]
                      -> Either Text (GIRInfo, [GIRInfo])
        combineErrors :: Either Text GIRInfo
-> [Either Text GIRInfo] -> Either Text (GIRInfo, [GIRInfo])
combineErrors parsedDoc :: Either Text GIRInfo
parsedDoc parsedDeps :: [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)

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
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 Name -> (Name, API) -> IO (Name, API)
fixupInterface :: Map Text Name -> (Name, API) -> IO (Name, API)
fixupInterface csymbolMap :: Map Text Name
csymbolMap (n :: Name
n@(Name ns :: Text
ns _), APIInterface iface :: Interface
iface) = do
  [Name]
prereqs <- case Interface -> Maybe Text
ifTypeInit Interface
iface of
               Nothing -> [Name] -> IO [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return []
               Just ti :: Text
ti -> do
                 GType
gtype <- Text -> Text -> IO GType
girLoadGType Text
ns Text
ti
                 [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
$ \p :: 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 pn :: Name
pn -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
pn
                     Nothing -> String -> IO Name
forall a. HasCallStack => String -> a
error (String -> IO Name) -> String -> IO Name
forall a b. (a -> b) -> a -> b
$ "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]
++ " 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 _ (n :: Name
n, api :: 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 Name -> (Name, API) -> IO (Name, API)
fixupStruct :: Map Text Name -> (Name, API) -> IO (Name, API)
fixupStruct _ (n :: Name
n, APIStruct s :: Struct
s) = do
  Struct
fixed <- (Name -> Struct -> IO Struct
fixupStructIsBoxed 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 _ api :: (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 :: Name -> Struct -> IO Struct
-- The type for "GVariant" is marked as "intern", we wrap
-- this one natively.
fixupStructIsBoxed :: Name -> Struct -> IO Struct
fixupStructIsBoxed (Name "GLib" "Variant") s :: Struct
s =
    Struct -> IO Struct
forall (m :: * -> *) a. Monad m => a -> m a
return (Struct
s {structIsBoxed :: Bool
structIsBoxed = Bool
False})
fixupStructIsBoxed (Name ns :: Text
ns _) s :: Struct
s = do
  Bool
isBoxed <- case Struct -> Maybe Text
structTypeInit Struct
s of
               Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Just ti :: Text
ti -> do
                 GType
gtype <- Text -> Text -> IO GType
girLoadGType Text
ns Text
ti
                 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 ns :: Text
ns n :: Text
n) s :: Struct
s = do
  (size :: Int
size, infoMap :: 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 :: M.Map Text Name -> (Name, API) -> IO (Name, API)
fixupUnion :: Map Text Name -> (Name, API) -> IO (Name, API)
fixupUnion _ (n :: Name
n, APIUnion u :: 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 _ api :: (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 ns :: Text
ns n :: Text
n) u :: Union
u = do
  (size :: Int
size, infoMap :: 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 offsetMap :: Map Text FieldInfo
offsetMap f :: 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
                       Nothing -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ "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 o :: FieldInfo
o -> FieldInfo -> Int
fieldInfoOffset FieldInfo
o }

-- | Fixup parsed GIRInfos: some of the required information is not
-- found in the GIR files themselves, but can be obtained by
-- instantiating the required GTypes from the installed libraries.
fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])
fixupGIRInfos :: GIRInfo -> [GIRInfo] -> IO (GIRInfo, [GIRInfo])
fixupGIRInfos doc :: GIRInfo
doc deps :: [GIRInfo]
deps = ((Map Text Name -> (Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup Map Text Name -> (Name, API) -> IO (Name, API)
fixupInterface ((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
>=>
                          (Map Text Name -> (Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup Map Text Name -> (Name, API) -> IO (Name, API)
fixupStruct ((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
>=>
                          (Map Text Name -> (Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup Map Text Name -> (Name, API) -> IO (Name, API)
fixupUnion) (GIRInfo
doc, [GIRInfo]
deps)
  where fixup :: (M.Map Text Name -> (Name, API) -> IO (Name, API))
                 -> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
        fixup :: (Map Text Name -> (Name, API) -> IO (Name, API))
-> (GIRInfo, [GIRInfo]) -> IO (GIRInfo, [GIRInfo])
fixup fixer :: Map Text Name -> (Name, API) -> IO (Name, API)
fixer (doc :: GIRInfo
doc, deps :: [GIRInfo]
deps) = do
          GIRInfo
fixedDoc <- (Map Text Name -> (Name, API) -> IO (Name, API))
-> GIRInfo -> IO GIRInfo
fixAPIs Map Text Name -> (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 ((Map Text Name -> (Name, API) -> IO (Name, API))
-> GIRInfo -> IO GIRInfo
fixAPIs Map Text Name -> (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 :: (M.Map Text Name -> (Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo
        fixAPIs :: (Map Text Name -> (Name, API) -> IO (Name, API))
-> GIRInfo -> IO GIRInfo
fixAPIs fixer :: Map Text Name -> (Name, API) -> IO (Name, API)
fixer info :: 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 (Map Text Name -> (Name, API) -> IO (Name, API)
fixer Map Text Name
ctypes) (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))

-- | Given a XML document containing GIR data, apply the given overrides.
fixupGIRDocument :: [GIRRule] -> XML.Document -> XML.Document
fixupGIRDocument :: [GIRRule] -> Document -> Document
fixupGIRDocument rules :: [GIRRule]
rules doc :: Document
doc =
    Document
doc {documentRoot :: Element
XML.documentRoot = [GIRRule] -> Element -> Element
fixupGIR [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.
fixupGIR :: [GIRRule] -> XML.Element -> XML.Element
fixupGIR :: [GIRRule] -> Element -> Element
fixupGIR rules :: [GIRRule]
rules elem :: Element
elem =
    Element
elem {elementNodes :: [Node]
XML.elementNodes =
          (Node -> Maybe Node) -> [Node] -> [Node]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\e :: 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 n :: Node
n (GIRSetAttr (path :: [GIRNodeSpec]
path, attr :: Name
attr) newVal :: 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 n :: Node
n (GIRAddNode path :: [GIRNodeSpec]
path new :: 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 n :: Node
n (GIRDeleteNode path :: [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 (spec :: GIRNodeSpec
spec:rest :: [GIRNodeSpec]
rest, attr :: Name
attr) newVal :: Text
newVal n :: Node
n@(XML.NodeElement elem :: 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
           _ -> 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 _ _ n :: 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 (spec :: GIRNodeSpec
spec:rest :: [GIRNodeSpec]
rest) newNode :: Name
newNode n :: Node
n@(XML.NodeElement element :: 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 e :: 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 _ = 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.
    _ -> 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 _ _ n :: Node
n = Node
n

-- | Delete any nodes matching the given path.
girDeleteNodes :: GIRPath -> XML.Node -> Maybe XML.Node
girDeleteNodes :: [GIRNodeSpec] -> Node -> Maybe Node
girDeleteNodes (spec :: GIRNodeSpec
spec:rest :: [GIRNodeSpec]
rest) n :: Node
n@(XML.NodeElement elem :: 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
         _ -> 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 _ n :: 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 tag :: GIRNameTag
tag attrs :: Map Name Text
attrs attr :: 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 s :: Text
s -> case GIRNameTag
tag of
                  GIRPlainName pn :: Text
pn -> Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
pn
                  GIRRegex r :: 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
      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 t :: Text
t) (XML.NodeElement elem :: 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 name :: GIRNameTag
name) (XML.NodeElement elem :: Element
elem) =
    GIRNameTag -> Map Name Text -> Name -> Bool
lookupAndMatch GIRNameTag
name  (Element -> Map Name Text
XML.elementAttributes Element
elem) (Text -> Name
xmlLocalName "name")
specMatch (GIRTypedName t :: Text
t name :: GIRNameTag
name) (XML.NodeElement elem :: 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 "name")
specMatch _ _ = Bool
False