{-# 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
$cshowsPrec :: Int -> GIRInfo -> ShowS
showsPrec :: Int -> GIRInfo -> ShowS
$cshow :: GIRInfo -> String
show :: GIRInfo -> String
$cshowList :: [GIRInfo] -> ShowS
showList :: [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
$cshowsPrec :: Int -> GIRNamespace -> ShowS
showsPrec :: Int -> GIRNamespace -> ShowS
$cshow :: GIRNamespace -> String
show :: GIRNamespace -> String
$cshowList :: [GIRNamespace] -> ShowS
showList :: [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
$cshowsPrec :: Int -> GIRInfoParse -> ShowS
showsPrec :: Int -> GIRInfoParse -> ShowS
$cshow :: GIRInfoParse -> String
show :: GIRInfoParse -> String
$cshowList :: [GIRInfoParse] -> ShowS
showList :: [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
$cshowsPrec :: Int -> GIRNodeSpec -> ShowS
showsPrec :: Int -> GIRNodeSpec -> ShowS
$cshow :: GIRNodeSpec -> String
show :: GIRNodeSpec -> String
$cshowList :: [GIRNodeSpec] -> ShowS
showList :: [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
$cshowsPrec :: Int -> GIRNameTag -> ShowS
showsPrec :: Int -> GIRNameTag -> ShowS
$cshow :: GIRNameTag -> String
show :: GIRNameTag -> String
$cshowList :: [GIRNameTag] -> ShowS
showList :: [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
$cshowsPrec :: Int -> GIRRule -> ShowS
showsPrec :: Int -> GIRRule -> ShowS
$cshow :: GIRRule -> String
show :: GIRRule -> String
$cshowList :: [GIRRule] -> ShowS
showList :: [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
$cshowsPrec :: Int -> API -> ShowS
showsPrec :: Int -> API -> ShowS
$cshow :: API -> String
show :: API -> String
$cshowList :: [API] -> ShowS
showList :: [API] -> ShowS
Show

parseAPI :: Text -> M.Map Alias Type -> Element -> (a -> API)
         -> Parser (Name, a) -> (Name, API)
parseAPI :: forall a.
Text
-> Map Alias Type
-> Element
-> (a -> API)
-> Parser (Name, a)
-> (Name, API)
parseAPI Text
ns Map Alias Type
aliases Element
element a -> API
wrapper Parser (Name, a)
parser =
    case 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
nsName :: GIRNamespace -> Text
nsVersion :: GIRNamespace -> Text
nsAPIs :: GIRNamespace -> [(Name, API)]
nsCTypes :: GIRNamespace -> [(Text, Name)]
nsName :: Text
nsVersion :: Text
nsAPIs :: [(Name, API)]
nsCTypes :: [(Text, Name)]
..} 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
"docsection" -> GIRNamespace
ns -- Ignored for now, see https://github.com/haskell-gi/haskell-gi/issues/318
          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 :: forall a. (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 = (n, api) : nsAPIs,
                      nsCTypes = case 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
  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
  version <- M.lookup "version" attrs
  let ns = GIRNamespace {
             nsName :: Text
nsName         = Text
name,
             nsVersion :: Text
nsVersion      = Text
version,
             nsAPIs :: [(Name, API)]
nsAPIs         = [],
             nsCTypes :: [(Text, Name)]
nsCTypes       = []
           }
  return (L.foldl' (parseNSElement aliases) ns (subelements element))

parseInclude :: Element -> Maybe (Text, Text)
parseInclude :: Element -> Maybe (Text, Text)
parseInclude Element
element = do
  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
  version <- M.lookup "version" attrs
  return (name, 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]
girIPPackage :: GIRInfoParse -> [Maybe Text]
girIPIncludes :: GIRInfoParse -> [Maybe (Text, Text)]
girIPNamespaces :: GIRInfoParse -> [Maybe GIRNamespace]
girIPPackage :: [Maybe Text]
girIPIncludes :: [Maybe (Text, Text)]
girIPNamespaces :: [Maybe GIRNamespace]
..} Element
element =
    case Name -> Text
nameLocalName (Element -> Name
elementName Element
element) of
      Text
"include" -> GIRInfoParse
info {girIPIncludes = parseInclude element : girIPIncludes}
      Text
"package" -> GIRInfoParse
info {girIPPackage = parsePackage element : girIPPackage}
      Text
"namespace" -> GIRInfoParse
info {girIPNamespaces = parseNamespace element aliases : girIPNamespaces}
      Text
_ -> GIRInfoParse
info

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

parseGIRDocument :: M.Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument :: Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument Map Alias Type
aliases Document
doc = (GIRInfoParse -> Element -> GIRInfoParse)
-> GIRInfoParse -> [Element] -> GIRInfoParse
forall b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> IO a
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
  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 = (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 = [(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) -> 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) -> 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
  loadDependencies verbose notYetLoaded newLoaded extraPaths rules

-- | Load a given GIR file and recursively its dependencies
loadGIRFile :: Bool             -- ^ verbose
            -> Text             -- ^ name
            -> Maybe Text       -- ^ version
            -> [FilePath]       -- ^ extra paths to search
            -> [GIRRule]        -- ^ 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
  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
  deps <- loadDependencies verbose (documentListIncludes doc) M.empty
          extraPaths rules
  return (doc, deps)

-- | Turn a GIRInfoParse into a proper GIRInfo, doing some sanity
-- checking along the way.
toGIRInfo :: GIRInfoParse -> Either Text GIRInfo
toGIRInfo :: 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 {
                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
  doc <- Bool -> Text -> Maybe Text -> [String] -> IO Document
readGiRepository Bool
verbose Text
name Maybe Text
version [String]
extraPaths
  case toGIRInfo (parseGIRDocument M.empty 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 a. a -> IO a
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
          fixedDoc <- ((Name, API) -> IO (Name, API)) -> GIRInfo -> IO GIRInfo
fixAPIs (Name, API) -> IO (Name, API)
fixer GIRInfo
doc
          fixedDeps <- mapM (fixAPIs fixer) deps
          return (fixedDoc, 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
          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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, API) -> IO (Name, API)
fixer (GIRInfo -> [(Name, API)]
girAPIs GIRInfo
info)
          return $ info {girAPIs = 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
  nprereqsPtr <- IO (Ptr CUInt)
forall a. Storable a => IO (Ptr a)
allocMem :: IO (Ptr CUInt)
  ps <- g_type_interface_prerequisites cgtype nprereqsPtr
  nprereqs <- peek nprereqsPtr
  psCGTypes <- unpackStorableArrayWithLength nprereqs ps
  freeMem ps
  freeMem nprereqsPtr
  mapM (fmap T.pack . gtypeName . GType) psCGTypes

-- | The list of prerequisites in GIR files is not always
-- accurate. Instead of relying on this, we instantiate the 'GType'
-- associated to the interface, and listing the interfaces from there.
fixupInterface :: M.Map Text 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
  prereqs <- case Interface -> Maybe Text
ifTypeInit Interface
iface of
               Maybe Text
Nothing -> [Name] -> IO [Name]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
               Just Text
ti -> do
                 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."
                 prereqGTypes <- gtypeInterfaceListPrereqs gtype
                 forM prereqGTypes $ \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 a. a -> IO a
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
  return (n, APIInterface (iface {ifPrerequisites = prereqs}))
fixupInterface Map Text Typelib
_ Map Text Name
_ (Name
n, API
api) = (Name, API) -> IO (Name, API)
forall a. a -> IO a
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
  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
  return (n, APIStruct fixed)
fixupStruct Map Text Typelib
_ (Name, API)
api = (Name, API) -> IO (Name, API)
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Struct
s {structIsBoxed = False})
fixupStructIsBoxed Map Text Typelib
typelibMap (Name Text
ns Text
_) Struct
s = do
  isBoxed <- case Struct -> Maybe Text
structTypeInit Struct
s of
               Maybe Text
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Just Text
ti -> do
                 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."

                 return (gtypeIsBoxed gtype)
  return (s {structIsBoxed = isBoxed})

-- | Fix the size and alignment of fields. This is much easier to do
-- by using libgirepository than reading the GIR file directly.
fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct
fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct
fixupStructSizeAndOffsets (Name Text
ns Text
n) Struct
s = do
  (size, infoMap) <- Text -> Text -> IO (Int, Map Text FieldInfo)
girStructFieldInfo Text
ns Text
n
  return (s { structSize = size
            , structFields = map (fixupField infoMap) (structFields s)})

-- | Same thing for unions.
fixupUnion :: (Name, API) -> IO (Name, API)
fixupUnion :: (Name, API) -> IO (Name, API)
fixupUnion (Name
n, APIUnion Union
u) = do
  fixed <- (Name -> Union -> IO Union
fixupUnionSizeAndOffsets Name
n) Union
u
  return (n, APIUnion fixed)
fixupUnion (Name, API)
api = (Name, API) -> IO (Name, API)
forall a. a -> IO a
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
  (size, infoMap) <- Text -> Text -> IO (Int, Map Text FieldInfo)
girUnionFieldInfo Text
ns Text
n
  return (u { unionSize = size
            , unionFields = map (fixupField infoMap) (unionFields 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 = case M.lookup (fieldName f) 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
  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
  return (n, APIStruct (s {structMethods = fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIUnion Union
u) = do
  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
  return (n, APIUnion (u {unionMethods = fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIObject Object
o) = do
  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
  return (n, APIObject (o {objMethods = fixedMethods}))
fixupMissingSymbols Bool
verbose Map Text Typelib
typelibMap (Name
n, APIInterface Interface
i) = do
  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
  return (n, APIInterface (i {ifMethods = 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 a. a -> IO a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
          resolvable <- Typelib -> Text -> IO Bool
girIsSymbolResolvable Typelib
typelib (Method -> Text
methodSymbol Method
method)
          when (verbose && not resolvable) $
            printWarning $ "Could not resolve the callable “"
                           <> methodSymbol method
                           <> "” in the “" <> tshow typelib
                           <> "” typelib, ignoring."
          let callable' = Callable
callable{callableResolvable = Just resolvable}
          return $ method{methodCallable = 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
  resolvable <- Typelib -> Text -> IO Bool
girIsSymbolResolvable Typelib
typelib (Function -> Text
fnSymbol Function
f)
  when (verbose && not resolvable) $
    printWarning $ "Could not resolve the function “" <> fnSymbol f
                    <> "” in the “" <> tshow typelib <> "” typelib, ignoring."
  let callable' = (Function -> Callable
fnCallable Function
f){callableResolvable = Just resolvable}
  return (n, APIFunction (f {fnCallable = 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
  (doc, 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] -> 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 = GIRInfoParse -> Either Text GIRInfo
toGIRInfo (Map Alias Type -> Document -> GIRInfoParse
parseGIRDocument Map Alias Type
aliases Document
doc)
      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 combineErrors parsedDoc 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
        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 <- Text -> Text -> IO Typelib
girRequire (GIRInfo -> Text
girNSName GIRInfo
info) (GIRInfo -> Text
girNSVersion GIRInfo
info)
             return (girNSName info, typelib))
        (fixedDoc, fixedDeps) <- fixupGIRInfos verbose typelibMap docGIR depsGIR
        return (fixedDoc, 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
          doc <- Either Text GIRInfo
parsedDoc
          deps <- sequence parsedDeps
          return (doc, 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 {XML.documentRoot = overrideGIR rules (XML.documentRoot doc)}

-- | Looks for the given path in the given subelements of the given
-- element. If the path is empty apply the corresponding rule,
-- otherwise return the element ummodified.
overrideGIR :: [GIRRule] -> XML.Element -> XML.Element
overrideGIR :: [GIRRule] -> Element -> Element
overrideGIR [GIRRule]
rules Element
elem =
    Element
elem {XML.elementNodes =
          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) (XML.elementNodes 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 {XML.elementAttributes =
                                        M.insert attr newVal
                                        (XML.elementAttributes elem)})
           -- Still some selectors to apply
           [GIRNodeSpec]
_ -> Element -> Node
XML.NodeElement (Element
elem {XML.elementNodes =
                                       map (girSetAttr (rest, attr) newVal)
                                       (XML.elementNodes 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 {XML.elementAttributes =
                                        M.delete attr
                                        (XML.elementAttributes elem)})
           -- Still some selectors to apply
           [GIRNodeSpec]
_ -> Element -> Node
XML.NodeElement (Element
elem {XML.elementNodes =
                                       map (girDeleteAttr rest attr)
                                       (XML.elementNodes elem)})
    else Node
n
girDeleteAttr [GIRNodeSpec]
_ Name
_ Node
n = Node
n

-- | Add the given subnode to any nodes matching the given path
girAddNode :: GIRPath -> XML.Name -> XML.Node -> XML.Node
girAddNode :: [GIRNodeSpec] -> Name -> Node -> Node
girAddNode (GIRNodeSpec
spec:[GIRNodeSpec]
rest) Name
newNode n :: Node
n@(XML.NodeElement Element
element) =
  if GIRNodeSpec -> Node -> Bool
specMatch GIRNodeSpec
spec Node
n
  then case [GIRNodeSpec]
rest of
    -- Matched the full path, add the new child node.
    [] -> let newElement :: Element
newElement = XML.Element { elementName :: Name
elementName = Name
newNode
                                       , elementAttributes :: Map Name Text
elementAttributes = 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 a. Eq a => a -> [a] -> 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 {XML.elementNodes =
                                    XML.elementNodes element <>
                                     [XML.NodeElement newElement]})
    -- Still some selectors to apply.
    [GIRNodeSpec]
_ -> Element -> Node
XML.NodeElement (Element
element {XML.elementNodes =
                                map (girAddNode rest newNode)
                                 (XML.elementNodes 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 {XML.elementNodes =
                                            mapMaybe (girDeleteNodes rest)
                                            (XML.elementNodes 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