{-# LANGUAGE ScopedTypeVariables #-}
-- | A minimal wrapper for libgirepository.
module Data.GI.CodeGen.LibGIRepository
    ( girRequire
    , setupTypelibSearchPath
    , FieldInfo(..)
    , girStructFieldInfo
    , girUnionFieldInfo
    , girLoadGType
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif

import Control.Monad (forM, when, (>=>))
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T

import Foreign.C.Types (CInt(..), CSize(..))
import Foreign.C.String (CString, withCString)
import Foreign (nullPtr, Ptr, FunPtr, peek)

import System.Environment (lookupEnv)
import System.FilePath (searchPathSeparator)

import Data.GI.Base.BasicConversions (withTextCString, cstringToText)
import Data.GI.Base.BasicTypes (BoxedObject(..), GType(..), CGType, ManagedPtr)
import Data.GI.Base.GError (GError, checkGError)
import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)
import Data.GI.Base.Utils (allocMem, freeMem)
import Data.GI.CodeGen.Util (splitOn)

-- | Wrapper for 'GIBaseInfo'
newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo)

-- | Wrapper for 'GITypelib'
newtype Typelib = Typelib (Ptr Typelib)

-- | Extra info about a field in a struct or union which is not easily
-- determined from the GIR file. (And which we determine by using
-- libgirepository.)
data FieldInfo = FieldInfo {
      FieldInfo -> Int
fieldInfoOffset    :: Int
    }

foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType

instance BoxedObject BaseInfo where
    boxedType :: BaseInfo -> IO GType
boxedType _ = IO GType
c_g_base_info_gtype_get_type

foreign import ccall "g_irepository_prepend_search_path" g_irepository_prepend_search_path :: CString -> IO ()

-- | Add the given directory to the typelib search path, this is a
-- thin wrapper over `g_irepository_prepend_search_path`.
girPrependSearchPath :: FilePath -> IO ()
girPrependSearchPath :: FilePath -> IO ()
girPrependSearchPath fp :: FilePath
fp = FilePath -> (CString -> IO ()) -> IO ()
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
fp CString -> IO ()
g_irepository_prepend_search_path

foreign import ccall "g_irepository_require" g_irepository_require ::
    Ptr () -> CString -> CString -> CInt -> Ptr (Ptr GError)
    -> IO (Ptr Typelib)

-- | A convenience function for setting up the typelib search path
-- from the environment. Note that for efficiency reasons this should
-- only be called once per program run. If the list of paths passed in
-- is empty, the environment variable @HASKELL_GI_TYPELIB_SEARCH_PATH@
-- will be checked. In either case the system directories will be
-- searched after the passed in directories.
setupTypelibSearchPath :: [FilePath] -> IO ()
setupTypelibSearchPath :: [FilePath] -> IO ()
setupTypelibSearchPath [] = do
  Maybe FilePath
env <- FilePath -> IO (Maybe FilePath)
lookupEnv "HASKELL_GI_TYPELIB_SEARCH_PATH"
  case Maybe FilePath
env of
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just paths :: FilePath
paths -> (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
girPrependSearchPath (Char -> FilePath -> [FilePath]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
searchPathSeparator FilePath
paths)
setupTypelibSearchPath paths :: [FilePath]
paths = (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
girPrependSearchPath [FilePath]
paths

-- | Ensure that the given version of the namespace is loaded. If that
-- is not possible we error out.
girRequire :: Text -> Text -> IO Typelib
girRequire :: Text -> Text -> IO Typelib
girRequire ns :: Text
ns version :: Text
version =
    Text -> (CString -> IO Typelib) -> IO Typelib
forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
ns ((CString -> IO Typelib) -> IO Typelib)
-> (CString -> IO Typelib) -> IO Typelib
forall a b. (a -> b) -> a -> b
$ \cns :: CString
cns ->
    Text -> (CString -> IO Typelib) -> IO Typelib
forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
version ((CString -> IO Typelib) -> IO Typelib)
-> (CString -> IO Typelib) -> IO Typelib
forall a b. (a -> b) -> a -> b
$ \cversion :: CString
cversion -> do
        Ptr Typelib
typelib <- (Ptr (Ptr GError) -> IO (Ptr Typelib))
-> (GError -> IO (Ptr Typelib)) -> IO (Ptr Typelib)
forall a. (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError (Ptr ()
-> CString
-> CString
-> CInt
-> Ptr (Ptr GError)
-> IO (Ptr Typelib)
g_irepository_require Ptr ()
forall a. Ptr a
nullPtr CString
cns CString
cversion 0)
                               (\gerror :: GError
gerror -> FilePath -> IO (Ptr Typelib)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Ptr Typelib)) -> FilePath -> IO (Ptr Typelib)
forall a b. (a -> b) -> a -> b
$ "Could not load typelib for "
                                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
ns FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " version "
                                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
version FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".\n"
                                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "Error was: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ GError -> FilePath
forall a. Show a => a -> FilePath
show GError
gerror)
        Typelib -> IO Typelib
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Typelib -> Typelib
Typelib Ptr Typelib
typelib)

foreign import ccall "g_irepository_find_by_name" g_irepository_find_by_name ::
    Ptr () -> CString -> CString -> IO (Ptr BaseInfo)

-- | Find a given baseinfo by name, or give an error if it cannot be
-- found.
girFindByName :: Text -> Text -> IO BaseInfo
girFindByName :: Text -> Text -> IO BaseInfo
girFindByName ns :: Text
ns name :: Text
name =
    Text -> (CString -> IO BaseInfo) -> IO BaseInfo
forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
ns ((CString -> IO BaseInfo) -> IO BaseInfo)
-> (CString -> IO BaseInfo) -> IO BaseInfo
forall a b. (a -> b) -> a -> b
$ \cns :: CString
cns ->
    Text -> (CString -> IO BaseInfo) -> IO BaseInfo
forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
name ((CString -> IO BaseInfo) -> IO BaseInfo)
-> (CString -> IO BaseInfo) -> IO BaseInfo
forall a b. (a -> b) -> a -> b
$ \cname :: CString
cname -> do
      Ptr BaseInfo
ptr <- Ptr () -> CString -> CString -> IO (Ptr BaseInfo)
g_irepository_find_by_name Ptr ()
forall a. Ptr a
nullPtr CString
cns CString
cname
      if Ptr BaseInfo
ptr Ptr BaseInfo -> Ptr BaseInfo -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr BaseInfo
forall a. Ptr a
nullPtr
      then FilePath -> IO BaseInfo
forall a. HasCallStack => FilePath -> a
error ("Could not find " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
ns FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "::" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
name)
      else (ManagedPtr BaseInfo -> BaseInfo) -> Ptr BaseInfo -> IO BaseInfo
forall a.
(HasCallStack, BoxedObject a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr BaseInfo -> BaseInfo
BaseInfo Ptr BaseInfo
ptr

foreign import ccall "g_field_info_get_offset" g_field_info_get_offset ::
    Ptr BaseInfo -> IO CInt
foreign import ccall "g_base_info_get_name" g_base_info_get_name ::
    Ptr BaseInfo -> IO CString

-- | Get the extra information for the given field.
getFieldInfo :: BaseInfo -> IO (Text, FieldInfo)
getFieldInfo :: BaseInfo -> IO (Text, FieldInfo)
getFieldInfo field :: BaseInfo
field = BaseInfo
-> (Ptr BaseInfo -> IO (Text, FieldInfo)) -> IO (Text, FieldInfo)
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr BaseInfo
field ((Ptr BaseInfo -> IO (Text, FieldInfo)) -> IO (Text, FieldInfo))
-> (Ptr BaseInfo -> IO (Text, FieldInfo)) -> IO (Text, FieldInfo)
forall a b. (a -> b) -> a -> b
$ \fi :: Ptr BaseInfo
fi -> do
     Text
fname <- (Ptr BaseInfo -> IO CString
g_base_info_get_name Ptr BaseInfo
fi IO CString -> (CString -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
CString -> IO Text
cstringToText)
     CInt
fOffset <- Ptr BaseInfo -> IO CInt
g_field_info_get_offset Ptr BaseInfo
fi
     (Text, FieldInfo) -> IO (Text, FieldInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
fname, FieldInfo :: Int -> FieldInfo
FieldInfo { fieldInfoOffset :: Int
fieldInfoOffset = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fOffset })

foreign import ccall "g_struct_info_get_size" g_struct_info_get_size ::
    Ptr BaseInfo -> IO CSize
foreign import ccall "g_struct_info_get_n_fields" g_struct_info_get_n_fields ::
    Ptr BaseInfo -> IO CInt
foreign import ccall "g_struct_info_get_field" g_struct_info_get_field ::
    Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)

-- | Find out the size of a struct, and the map from field names to
-- offsets inside the struct.
girStructFieldInfo :: Text -> Text -> IO (Int, M.Map Text FieldInfo)
girStructFieldInfo :: Text -> Text -> IO (Int, Map Text FieldInfo)
girStructFieldInfo ns :: Text
ns name :: Text
name = do
  BaseInfo
baseinfo <- Text -> Text -> IO BaseInfo
girFindByName Text
ns Text
name
  BaseInfo
-> (Ptr BaseInfo -> IO (Int, Map Text FieldInfo))
-> IO (Int, Map Text FieldInfo)
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr BaseInfo
baseinfo ((Ptr BaseInfo -> IO (Int, Map Text FieldInfo))
 -> IO (Int, Map Text FieldInfo))
-> (Ptr BaseInfo -> IO (Int, Map Text FieldInfo))
-> IO (Int, Map Text FieldInfo)
forall a b. (a -> b) -> a -> b
$ \si :: Ptr BaseInfo
si -> do
     CSize
size <- Ptr BaseInfo -> IO CSize
g_struct_info_get_size Ptr BaseInfo
si
     CInt
nfields <- Ptr BaseInfo -> IO CInt
g_struct_info_get_n_fields Ptr BaseInfo
si
     [(Text, FieldInfo)]
fieldInfos <- [CInt] -> (CInt -> IO (Text, FieldInfo)) -> IO [(Text, FieldInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0..(CInt
nfieldsCInt -> CInt -> CInt
forall a. Num a => a -> a -> a
-1)]
           (Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)
g_struct_info_get_field Ptr BaseInfo
si (CInt -> IO (Ptr BaseInfo))
-> (Ptr BaseInfo -> IO (Text, FieldInfo))
-> CInt
-> IO (Text, FieldInfo)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ManagedPtr BaseInfo -> BaseInfo) -> Ptr BaseInfo -> IO BaseInfo
forall a.
(HasCallStack, BoxedObject a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr BaseInfo -> BaseInfo
BaseInfo (Ptr BaseInfo -> IO BaseInfo)
-> (BaseInfo -> IO (Text, FieldInfo))
-> Ptr BaseInfo
-> IO (Text, FieldInfo)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BaseInfo -> IO (Text, FieldInfo)
getFieldInfo)
     (Int, Map Text FieldInfo) -> IO (Int, Map Text FieldInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, [(Text, FieldInfo)] -> Map Text FieldInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, FieldInfo)]
fieldInfos)

foreign import ccall "g_union_info_get_size" g_union_info_get_size ::
    Ptr BaseInfo -> IO CSize
foreign import ccall "g_union_info_get_n_fields" g_union_info_get_n_fields ::
    Ptr BaseInfo -> IO CInt
foreign import ccall "g_union_info_get_field" g_union_info_get_field ::
    Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)

-- | Find out the size of a union, and the map from field names to
-- offsets inside the union.
girUnionFieldInfo :: Text -> Text -> IO (Int, M.Map Text FieldInfo)
girUnionFieldInfo :: Text -> Text -> IO (Int, Map Text FieldInfo)
girUnionFieldInfo ns :: Text
ns name :: Text
name = do
  BaseInfo
baseinfo <- Text -> Text -> IO BaseInfo
girFindByName Text
ns Text
name
  BaseInfo
-> (Ptr BaseInfo -> IO (Int, Map Text FieldInfo))
-> IO (Int, Map Text FieldInfo)
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr BaseInfo
baseinfo ((Ptr BaseInfo -> IO (Int, Map Text FieldInfo))
 -> IO (Int, Map Text FieldInfo))
-> (Ptr BaseInfo -> IO (Int, Map Text FieldInfo))
-> IO (Int, Map Text FieldInfo)
forall a b. (a -> b) -> a -> b
$ \ui :: Ptr BaseInfo
ui -> do
     CSize
size <- Ptr BaseInfo -> IO CSize
g_union_info_get_size Ptr BaseInfo
ui
     CInt
nfields <- Ptr BaseInfo -> IO CInt
g_union_info_get_n_fields Ptr BaseInfo
ui
     [(Text, FieldInfo)]
fieldInfos <- [CInt] -> (CInt -> IO (Text, FieldInfo)) -> IO [(Text, FieldInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0..(CInt
nfieldsCInt -> CInt -> CInt
forall a. Num a => a -> a -> a
-1)] (
           Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)
g_union_info_get_field Ptr BaseInfo
ui (CInt -> IO (Ptr BaseInfo))
-> (Ptr BaseInfo -> IO (Text, FieldInfo))
-> CInt
-> IO (Text, FieldInfo)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ManagedPtr BaseInfo -> BaseInfo) -> Ptr BaseInfo -> IO BaseInfo
forall a.
(HasCallStack, BoxedObject a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr BaseInfo -> BaseInfo
BaseInfo (Ptr BaseInfo -> IO BaseInfo)
-> (BaseInfo -> IO (Text, FieldInfo))
-> Ptr BaseInfo
-> IO (Text, FieldInfo)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BaseInfo -> IO (Text, FieldInfo)
getFieldInfo)
     (Int, Map Text FieldInfo) -> IO (Int, Map Text FieldInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, [(Text, FieldInfo)] -> Map Text FieldInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, FieldInfo)]
fieldInfos)

foreign import ccall "g_typelib_symbol" g_typelib_symbol ::
    Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt

-- | Load a symbol from the dynamic library associated to the given namespace.
girSymbol :: forall a. Text -> Text -> IO (FunPtr a)
girSymbol :: Text -> Text -> IO (FunPtr a)
girSymbol ns :: Text
ns symbol :: Text
symbol = do
  Ptr Typelib
typelib <- Text -> (CString -> IO (Ptr Typelib)) -> IO (Ptr Typelib)
forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
ns ((CString -> IO (Ptr Typelib)) -> IO (Ptr Typelib))
-> (CString -> IO (Ptr Typelib)) -> IO (Ptr Typelib)
forall a b. (a -> b) -> a -> b
$ \cns :: CString
cns ->
                    (Ptr (Ptr GError) -> IO (Ptr Typelib))
-> (GError -> IO (Ptr Typelib)) -> IO (Ptr Typelib)
forall a. (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError (Ptr ()
-> CString
-> CString
-> CInt
-> Ptr (Ptr GError)
-> IO (Ptr Typelib)
g_irepository_require Ptr ()
forall a. Ptr a
nullPtr CString
cns CString
forall a. Ptr a
nullPtr 0)
                                (FilePath -> GError -> IO (Ptr Typelib)
forall a. HasCallStack => FilePath -> a
error (FilePath -> GError -> IO (Ptr Typelib))
-> FilePath -> GError -> IO (Ptr Typelib)
forall a b. (a -> b) -> a -> b
$ "Could not load typelib " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
ns)
  Ptr (FunPtr a)
funPtrPtr <- IO (Ptr (FunPtr a))
forall a. Storable a => IO (Ptr a)
allocMem :: IO (Ptr (FunPtr a))
  CInt
result <- Text -> (CString -> IO CInt) -> IO CInt
forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
symbol ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \csymbol :: CString
csymbol ->
                      Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt
forall a. Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt
g_typelib_symbol Ptr Typelib
typelib CString
csymbol Ptr (FunPtr a)
funPtrPtr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error ("Could not resolve symbol " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
symbol FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " in namespace "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
ns)
  FunPtr a
funPtr <- Ptr (FunPtr a) -> IO (FunPtr a)
forall a. Storable a => Ptr a -> IO a
peek Ptr (FunPtr a)
funPtrPtr
  Ptr (FunPtr a) -> IO ()
forall a. Ptr a -> IO ()
freeMem Ptr (FunPtr a)
funPtrPtr
  FunPtr a -> IO (FunPtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
funPtr

type GTypeInit = IO CGType
foreign import ccall "dynamic" gtypeInit :: FunPtr GTypeInit -> GTypeInit

-- | Load a GType given the namespace where it lives and the type init
-- function.
girLoadGType :: Text -> Text -> IO GType
girLoadGType :: Text -> Text -> IO GType
girLoadGType ns :: Text
ns typeInit :: Text
typeInit = do
  FunPtr GTypeInit
funPtr <- Text -> Text -> IO (FunPtr GTypeInit)
forall a. Text -> Text -> IO (FunPtr a)
girSymbol Text
ns Text
typeInit
  CGType -> GType
GType (CGType -> GType) -> GTypeInit -> IO GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FunPtr GTypeInit -> GTypeInit
gtypeInit FunPtr GTypeInit
funPtr