{-# 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) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> ShowS
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 = [Char] -> (CString -> IO ()) -> IO ()
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
  env <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HASKELL_GI_TYPELIB_SEARCH_PATH"
  case env of
    Maybe [Char]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [Char]
paths -> ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
girPrependSearchPath (Char -> [Char] -> [[Char]]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
searchPathSeparator [Char]
paths)
setupTypelibSearchPath [[Char]]
paths = ([Char] -> IO ()) -> [[Char]] -> IO ()
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 =
    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
$ \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
$ \CString
cversion -> do
        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 CInt
0)
                               (\GError
gerror -> [Char] -> IO (Ptr Typelib)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Ptr Typelib)) -> [Char] -> IO (Ptr Typelib)
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not load typelib for "
                                           [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
ns [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" version "
                                           [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
version [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".\n"
                                           [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Error was: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ GError -> [Char]
forall a. Show a => a -> [Char]
show GError
gerror)
        return (Typelib ns version 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 =
    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
$ \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
$ \CString
cname -> do
      ptr <- Ptr () -> CString -> CString -> IO (Ptr BaseInfo)
g_irepository_find_by_name Ptr ()
forall a. Ptr a
nullPtr CString
cns CString
cname
      if ptr == nullPtr
      then error ("Could not find " ++ T.unpack ns ++ "::" ++ T.unpack name)
      else wrapBoxed 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 = 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
$ \Ptr BaseInfo
fi -> do
     fname <- (Ptr BaseInfo -> IO CString
g_base_info_get_name Ptr BaseInfo
fi IO CString -> (CString -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => CString -> IO Text
CString -> IO Text
cstringToText)
     fOffset <- g_field_info_get_offset fi
     return (fname, FieldInfo { fieldInfoOffset = fromIntegral 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 <- Text -> Text -> IO BaseInfo
girFindByName Text
ns Text
name
  withManagedPtr baseinfo $ \Ptr BaseInfo
si -> do
     size <- Ptr BaseInfo -> IO CSize
g_struct_info_get_size Ptr BaseInfo
si
     nfields <- g_struct_info_get_n_fields si
     fieldInfos <- forM [0..(nfields-1)]
           (g_struct_info_get_field si >=> wrapBoxed BaseInfo >=> getFieldInfo)
     return (fromIntegral size, M.fromList 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 <- Text -> Text -> IO BaseInfo
girFindByName Text
ns Text
name
  withManagedPtr baseinfo $ \Ptr BaseInfo
ui -> do
     size <- Ptr BaseInfo -> IO CSize
g_union_info_get_size Ptr BaseInfo
ui
     nfields <- g_union_info_get_n_fields ui
     fieldInfos <- forM [0..(nfields-1)] (
           g_union_info_get_field ui >=> wrapBoxed BaseInfo >=> getFieldInfo)
     return (fromIntegral size, M.fromList 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
  funPtrPtr <- IO (Ptr (FunPtr a))
forall a. Storable a => IO (Ptr a)
allocMem :: IO (Ptr (FunPtr a))
  result <- withTextCString symbol $ \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
  funPtr <- peek funPtrPtr
  freeMem funPtrPtr
  if result /= 1
    then return Nothing
    else return (Just 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
  maybeSymbol <- Typelib -> Text -> IO (Maybe (FunPtr a))
forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol Typelib
typelib Text
symbol
  case maybeSymbol of
    Just FunPtr a
funPtr -> FunPtr a -> IO (FunPtr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
funPtr
    Maybe (FunPtr a)
Nothing -> [Char] -> IO (FunPtr a)
forall a. HasCallStack => [Char] -> a
error ([Char]
"Could not resolve symbol " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
symbol [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in namespace "
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show (Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> 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 (CGType -> GType) -> IO CGType -> IO GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typelib -> Text -> IO (FunPtr (IO CGType))
forall a. Typelib -> Text -> IO (FunPtr a)
girSymbol Typelib
typelib Text
typeInit IO (FunPtr (IO CGType))
-> (FunPtr (IO CGType) -> IO CGType) -> IO CGType
forall a b. IO a -> (a -> IO b) -> IO b
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
  maybeSymbol <- Typelib -> Text -> IO (Maybe (FunPtr Any))
forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol Typelib
typelib Text
symbol
  return (isJust maybeSymbol)