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

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

import Control.Monad (forM, (>=>))
import qualified Data.Map as M
import Data.Maybe (isJust)
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 (TypedObject(..), GBoxed,
                                GType(..), CGType, ManagedPtr)
import Data.GI.Base.GError (GError, checkGError)
import Data.GI.Base.ManagedPtr (wrapBoxed, withManagedPtr)
import Data.GI.Base.Overloading (HasParentTypes, ParentTypes)
import Data.GI.Base.Utils (allocMem, freeMem)
import Data.GI.CodeGen.Util (splitOn)

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

-- | Wrapper for 'GITypelib', remembering the originating namespace
-- and version.
data Typelib = Typelib { Typelib -> Text
typelibNamespace       :: Text
                       , Typelib -> Text
typelibVersion         :: Text
                       , Typelib -> Ptr Typelib
_typelibPtr            :: Ptr Typelib
                       }

instance Show Typelib where
  show :: Typelib -> [Char]
show Typelib
t = Text -> [Char]
T.unpack (Typelib -> Text
typelibNamespace Typelib
t) forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Typelib -> Text
typelibVersion Typelib
t)

-- | 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
    }

-- | The (empty) set of parent types for `BaseInfo` visible to the
-- Haskell type system.
instance HasParentTypes BaseInfo
type instance ParentTypes BaseInfo = '[]

foreign import ccall "g_base_info_gtype_get_type" c_g_base_info_gtype_get_type :: IO GType

instance TypedObject BaseInfo where
  glibType :: IO GType
glibType = IO GType
c_g_base_info_gtype_get_type

-- | `BaseInfo`s are registered as boxed in the GLib type system.
instance GBoxed BaseInfo

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 :: [Char] -> IO ()
girPrependSearchPath [Char]
fp = forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
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 :: [[Char]] -> IO ()
setupTypelibSearchPath [] = do
  Maybe [Char]
env <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HASKELL_GI_TYPELIB_SEARCH_PATH"
  case Maybe [Char]
env of
    Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [Char]
paths -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
girPrependSearchPath (forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
searchPathSeparator [Char]
paths)
setupTypelibSearchPath [[Char]]
paths = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
girPrependSearchPath [[Char]]
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 Text
ns Text
version =
    forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
ns forall a b. (a -> b) -> a -> b
$ \CString
cns ->
    forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
version forall a b. (a -> b) -> a -> b
$ \CString
cversion -> do
        Ptr Typelib
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 forall a. Ptr a
nullPtr CString
cns CString
cversion CInt
0)
                               (\GError
gerror -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Could not load typelib for "
                                           forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
ns forall a. [a] -> [a] -> [a]
++ [Char]
" version "
                                           forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
version forall a. [a] -> [a] -> [a]
++ [Char]
".\n"
                                           forall a. [a] -> [a] -> [a]
++ [Char]
"Error was: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show GError
gerror)
        forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Ptr Typelib -> Typelib
Typelib Text
ns Text
version 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 Text
ns Text
name =
    forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
ns forall a b. (a -> b) -> a -> b
$ \CString
cns ->
    forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
name forall a b. (a -> b) -> a -> b
$ \CString
cname -> do
      Ptr BaseInfo
ptr <- Ptr () -> CString -> CString -> IO (Ptr BaseInfo)
g_irepository_find_by_name forall a. Ptr a
nullPtr CString
cns CString
cname
      if Ptr BaseInfo
ptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
      then forall a. HasCallStack => [Char] -> a
error ([Char]
"Could not find " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
ns forall a. [a] -> [a] -> [a]
++ [Char]
"::" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name)
      else forall a.
(HasCallStack, GBoxed 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 BaseInfo
field = forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr BaseInfo
field forall a b. (a -> b) -> a -> b
$ \Ptr BaseInfo
fi -> do
     Text
fname <- (Ptr BaseInfo -> IO CString
g_base_info_get_name Ptr BaseInfo
fi forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
cstringToText)
     CInt
fOffset <- Ptr BaseInfo -> IO CInt
g_field_info_get_offset Ptr BaseInfo
fi
     forall (m :: * -> *) a. Monad m => a -> m a
return (Text
fname, FieldInfo { fieldInfoOffset :: Int
fieldInfoOffset = 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 Text
ns Text
name = do
  BaseInfo
baseinfo <- Text -> Text -> IO BaseInfo
girFindByName Text
ns Text
name
  forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr BaseInfo
baseinfo forall a b. (a -> b) -> a -> b
$ \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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt
0..(CInt
nfieldsforall a. Num a => a -> a -> a
-CInt
1)]
           (Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)
g_struct_info_get_field Ptr BaseInfo
si forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr BaseInfo -> BaseInfo
BaseInfo forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BaseInfo -> IO (Text, FieldInfo)
getFieldInfo)
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, 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 Text
ns Text
name = do
  BaseInfo
baseinfo <- Text -> Text -> IO BaseInfo
girFindByName Text
ns Text
name
  forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr BaseInfo
baseinfo forall a b. (a -> b) -> a -> b
$ \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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt
0..(CInt
nfieldsforall a. Num a => a -> a -> a
-CInt
1)] (
           Ptr BaseInfo -> CInt -> IO (Ptr BaseInfo)
g_union_info_get_field Ptr BaseInfo
ui forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a.
(HasCallStack, GBoxed a) =>
(ManagedPtr a -> a) -> Ptr a -> IO a
wrapBoxed ManagedPtr BaseInfo -> BaseInfo
BaseInfo forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BaseInfo -> IO (Text, FieldInfo)
getFieldInfo)
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size, 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

-- | Try to load a symbol from the dynamic library associated to the
-- given typelib.
girLookupSymbol :: forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol :: forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol (Typelib Text
_ Text
_ Ptr Typelib
typelib) Text
symbol = do
  Ptr (FunPtr a)
funPtrPtr <- forall a. Storable a => IO (Ptr a)
allocMem :: IO (Ptr (FunPtr a))
  CInt
result <- forall a. Text -> (CString -> IO a) -> IO a
withTextCString Text
symbol forall a b. (a -> b) -> a -> b
$ \CString
csymbol ->
                      forall a. Ptr Typelib -> CString -> Ptr (FunPtr a) -> IO CInt
g_typelib_symbol Ptr Typelib
typelib CString
csymbol Ptr (FunPtr a)
funPtrPtr
  FunPtr a
funPtr <- forall a. Storable a => Ptr a -> IO a
peek Ptr (FunPtr a)
funPtrPtr
  forall a. Ptr a -> IO ()
freeMem Ptr (FunPtr a)
funPtrPtr
  if CInt
result forall a. Eq a => a -> a -> Bool
/= CInt
1
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just FunPtr a
funPtr)

-- | Load a symbol from the dynamic library associated to the given
-- typelib. If the symbol does not exist this will raise an error.
girSymbol :: Typelib -> Text -> IO (FunPtr a)
girSymbol :: forall a. Typelib -> Text -> IO (FunPtr a)
girSymbol typelib :: Typelib
typelib@(Typelib Text
ns Text
version Ptr Typelib
_) Text
symbol = do
  Maybe (FunPtr a)
maybeSymbol <- forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol Typelib
typelib Text
symbol
  case Maybe (FunPtr a)
maybeSymbol of
    Just FunPtr a
funPtr -> forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
funPtr
    Maybe (FunPtr a)
Nothing -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Could not resolve symbol " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
symbol forall a. [a] -> [a] -> [a]
++ [Char]
" in namespace "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Text
ns forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
version))

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

-- | Load a GType given the `Typelib` where it lives and the type init
-- function.
girLoadGType :: Typelib -> Text -> IO GType
girLoadGType :: Typelib -> Text -> IO GType
girLoadGType Typelib
typelib Text
typeInit =
  CGType -> GType
GType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Typelib -> Text -> IO (FunPtr a)
girSymbol Typelib
typelib Text
typeInit forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FunPtr (IO CGType) -> IO CGType
gtypeInit)

-- | Check whether a symbol is present in the dynamical liberary.
girIsSymbolResolvable :: Typelib -> Text -> IO Bool
girIsSymbolResolvable :: Typelib -> Text -> IO Bool
girIsSymbolResolvable Typelib
typelib Text
symbol = do
  Maybe (FunPtr Any)
maybeSymbol <- forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol Typelib
typelib Text
symbol
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> Bool
isJust Maybe (FunPtr Any)
maybeSymbol)