{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, DataKinds #-}
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)
newtype BaseInfo = BaseInfo (ManagedPtr BaseInfo)
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)
data FieldInfo = FieldInfo {
FieldInfo -> Int
fieldInfoOffset :: Int
}
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
instance GBoxed BaseInfo
foreign import ccall "g_irepository_prepend_search_path" g_irepository_prepend_search_path :: CString -> IO ()
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)
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
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)
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
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)
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)
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
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)
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
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)
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)