{-# 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
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 -> String
show Typelib
t = Text -> String
T.unpack (Typelib -> Text
typelibNamespace Typelib
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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 :: String -> IO ()
girPrependSearchPath String
fp = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
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 :: [String] -> IO ()
setupTypelibSearchPath [] = do
Maybe String
env <- String -> IO (Maybe String)
lookupEnv String
"HASKELL_GI_TYPELIB_SEARCH_PATH"
case Maybe String
env of
Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just String
paths -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
girPrependSearchPath (Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
searchPathSeparator String
paths)
setupTypelibSearchPath [String]
paths = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
girPrependSearchPath [String]
paths
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
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 CInt
0)
(\GError
gerror -> String -> IO (Ptr Typelib)
forall a. HasCallStack => String -> a
error (String -> IO (Ptr Typelib)) -> String -> IO (Ptr Typelib)
forall a b. (a -> b) -> a -> b
$ String
"Could not load 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
" version "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
version String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Error was: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GError -> String
forall a. Show a => a -> String
show GError
gerror)
Typelib -> IO Typelib
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 =
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 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 String -> IO BaseInfo
forall a. HasCallStack => String -> a
error (String
"Could not find " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"::" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
name)
else (ManagedPtr BaseInfo -> BaseInfo) -> Ptr BaseInfo -> IO BaseInfo
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 = 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
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)
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
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
$ \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 [CInt
0..(CInt
nfieldsCInt -> CInt -> CInt
forall a. Num a => a -> a -> a
-CInt
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, GBoxed 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)
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
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
$ \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 [CInt
0..(CInt
nfieldsCInt -> CInt -> CInt
forall a. Num a => a -> a -> a
-CInt
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, GBoxed 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
girLookupSymbol :: forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol :: Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol (Typelib Text
_ Text
_ Ptr Typelib
typelib) Text
symbol = do
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
$ \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 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
if CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1
then Maybe (FunPtr a) -> IO (Maybe (FunPtr a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FunPtr a)
forall a. Maybe a
Nothing
else Maybe (FunPtr a) -> IO (Maybe (FunPtr a))
forall (m :: * -> *) a. Monad m => a -> m a
return (FunPtr a -> Maybe (FunPtr a)
forall a. a -> Maybe a
Just FunPtr a
funPtr)
girSymbol :: Typelib -> Text -> IO (FunPtr a)
girSymbol :: Typelib -> Text -> IO (FunPtr a)
girSymbol typelib :: Typelib
typelib@(Typelib Text
ns Text
version Ptr Typelib
_) Text
symbol = do
Maybe (FunPtr a)
maybeSymbol <- Typelib -> Text -> IO (Maybe (FunPtr a))
forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol Typelib
typelib Text
symbol
case Maybe (FunPtr a)
maybeSymbol of
Just FunPtr a
funPtr -> FunPtr a -> IO (FunPtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
funPtr
Maybe (FunPtr a)
Nothing -> String -> IO (FunPtr a)
forall a. HasCallStack => String -> a
error (String
"Could not resolve symbol " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
symbol String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in namespace "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
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
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 (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 <- Typelib -> Text -> IO (Maybe (FunPtr Any))
forall a. Typelib -> Text -> IO (Maybe (FunPtr a))
girLookupSymbol Typelib
typelib Text
symbol
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FunPtr Any) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (FunPtr Any)
maybeSymbol)