module Data.GI.CodeGen.Conversions
( convert
, genConversion
, unpackCArray
, computeArrayLength
, callableHasClosures
, hToF
, fToH
, haskellType
, isoHaskellType
, foreignType
, argumentType
, elementType
, elementMap
, elementTypeAndMap
, isManaged
, typeIsNullable
, typeIsPtr
, maybeNullConvert
, nullPtrForType
, getIsScalar
, typeAllocInfo
, TypeAllocInfo(..)
, apply
, mapC
, literal
, Constructor(..)
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>), pure, Applicative)
#endif
import Control.Monad (when)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.Int
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf)
import Data.Word
import GHC.Exts (IsString(..))
import Foreign.C.Types (CInt, CUInt, CLong, CULong)
import Foreign.Storable (sizeOf)
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.GObject
import Data.GI.CodeGen.SymbolNaming
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util
data Free f r = Free (f (Free f r)) | Pure r
instance Functor f => Functor (Free f) where
fmap f = go where
go (Pure a) = Pure (f a)
go (Free fa) = Free (go <$> fa)
instance (Functor f) => Applicative (Free f) where
pure = Pure
Pure a <*> Pure b = Pure $ a b
Pure a <*> Free mb = Free $ fmap a <$> mb
Free ma <*> b = Free $ (<*> b) <$> ma
instance (Functor f) => Monad (Free f) where
return = Pure
(Free x) >>= f = Free (fmap (>>= f) x)
(Pure r) >>= f = f r
liftF :: (Functor f) => f r -> Free f r
liftF command = Free (fmap Pure command)
data Constructor = P Text | M Text | Id
deriving (Eq,Show)
instance IsString Constructor where
fromString = P . T.pack
data FExpr next = Apply Constructor next
| MapC Map Constructor next
| Literal Constructor next
deriving (Show, Functor)
type Converter = Free FExpr ()
data Map = Map | MapFirst | MapSecond
deriving (Show)
mapName :: Map -> Text
mapName Map = "map"
mapName MapFirst = "mapFirst"
mapName MapSecond = "mapSecond"
monadicMapName :: Map -> Text
monadicMapName Map = "mapM"
monadicMapName MapFirst = "mapFirstA"
monadicMapName MapSecond = "mapSecondA"
apply :: Constructor -> Converter
apply f = liftF $ Apply f ()
mapC :: Constructor -> Converter
mapC f = liftF $ MapC Map f ()
mapFirst :: Constructor -> Converter
mapFirst f = liftF $ MapC MapFirst f ()
mapSecond :: Constructor -> Converter
mapSecond f = liftF $ MapC MapSecond f ()
literal :: Constructor -> Converter
literal f = liftF $ Literal f ()
genConversion :: Text -> Converter -> CodeGen Text
genConversion l (Pure ()) = return l
genConversion l (Free k) = do
let l' = prime l
case k of
Apply (P f) next ->
do line $ "let " <> l' <> " = " <> f <> " " <> l
genConversion l' next
Apply (M f) next ->
do line $ l' <> " <- " <> f <> " " <> l
genConversion l' next
Apply Id next -> genConversion l next
MapC m (P f) next ->
do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l
genConversion l' next
MapC m (M f) next ->
do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l
genConversion l' next
MapC _ Id next -> genConversion l next
Literal (P f) next ->
do line $ "let " <> l <> " = " <> f
genConversion l next
Literal (M f) next ->
do line $ l <> " <- " <> f
genConversion l next
Literal Id next -> genConversion l next
computeArrayLength :: Text -> Type -> ExcCodeGen Text
computeArrayLength array (TCArray _ _ _ t) = do
reader <- findReader
return $ "fromIntegral $ " <> reader <> " " <> array
where findReader = case t of
TBasicType TUInt8 -> return "B.length"
TBasicType _ -> return "length"
TInterface _ -> return "length"
TCArray{} -> return "length"
_ -> notImplementedError $
"Don't know how to compute length of " <> tshow t
computeArrayLength _ t =
notImplementedError $ "computeArrayLength called on non-CArray type "
<> tshow t
convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text
convert l c = do
c' <- c
genConversion l c'
hObjectToF :: Type -> Transfer -> ExcCodeGen Constructor
hObjectToF t transfer =
if transfer == TransferEverything
then do
isGO <- isGObject t
if isGO
then return $ M "B.ManagedPtr.disownObject"
else badIntroError "Transferring a non-GObject object"
else return $ M "unsafeManagedPtrCastPtr"
hVariantToF :: Transfer -> CodeGen Constructor
hVariantToF transfer =
if transfer == TransferEverything
then return $ M "B.GVariant.disownGVariant"
else return $ M "unsafeManagedPtrGetPtr"
hParamSpecToF :: Transfer -> CodeGen Constructor
hParamSpecToF transfer =
if transfer == TransferEverything
then return $ M "B.GParamSpec.disownGParamSpec"
else return $ M "unsafeManagedPtrGetPtr"
hBoxedToF :: Transfer -> CodeGen Constructor
hBoxedToF transfer =
if transfer == TransferEverything
then return $ M "B.ManagedPtr.disownBoxed"
else return $ M "unsafeManagedPtrGetPtr"
hStructToF :: Struct -> Transfer -> ExcCodeGen Constructor
hStructToF s transfer =
if transfer /= TransferEverything || structIsBoxed s then
hBoxedToF transfer
else do
when (structSize s == 0) $
badIntroError "Transferring a non-boxed struct with unknown size!"
return $ M "unsafeManagedPtrGetPtr"
hUnionToF :: Union -> Transfer -> ExcCodeGen Constructor
hUnionToF u transfer =
if transfer /= TransferEverything || unionIsBoxed u then
hBoxedToF transfer
else do
when (unionSize u == 0) $
badIntroError "Transferring a non-boxed union with unknown size!"
return $ M "unsafeManagedPtrGetPtr"
hToF' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer
-> ExcCodeGen Constructor
hToF' t a hType fType transfer
| ( hType == fType ) = return Id
| TError <- t = hBoxedToF transfer
| TVariant <- t = hVariantToF transfer
| TParamSpec <- t = hParamSpecToF transfer
| Just (APIEnum _) <- a = return "(fromIntegral . fromEnum)"
| Just (APIFlags _) <- a = return "gflagsToWord"
| Just (APIObject _) <- a = hObjectToF t transfer
| Just (APIInterface _) <- a = hObjectToF t transfer
| Just (APIStruct s) <- a = hStructToF s transfer
| Just (APIUnion u) <- a = hUnionToF u transfer
| Just (APICallback _) <- a = error "Cannot handle callback type here!! "
| TByteArray <- t = return $ M "packGByteArray"
| TCArray True _ _ (TBasicType TUTF8) <- t =
return $ M "packZeroTerminatedUTF8CArray"
| TCArray True _ _ (TBasicType TFileName) <- t =
return $ M "packZeroTerminatedFileNameArray"
| TCArray True _ _ (TBasicType TPtr) <- t =
return $ M "packZeroTerminatedPtrArray"
| TCArray True _ _ (TBasicType TUInt8) <- t =
return $ M "packZeroTerminatedByteString"
| TCArray True _ _ (TBasicType TBoolean) <- t =
return $ M "(packMapZeroTerminatedStorableArray (fromIntegral . fromEnum))"
| TCArray True _ _ (TBasicType TGType) <- t =
return $ M "(packMapZeroTerminatedStorableArray gtypeToCGtype)"
| TCArray True _ _ (TBasicType _) <- t =
return $ M "packZeroTerminatedStorableArray"
| TCArray False _ _ (TBasicType TUTF8) <- t =
return $ M "packUTF8CArray"
| TCArray False _ _ (TBasicType TFileName) <- t =
return $ M "packFileNameArray"
| TCArray False _ _ (TBasicType TPtr) <- t =
return $ M "packPtrArray"
| TCArray False _ _ (TBasicType TUInt8) <- t =
return $ M "packByteString"
| TCArray False _ _ (TBasicType TBoolean) <- t =
return $ M "(packMapStorableArray (fromIntegral . fromEnum))"
| TCArray False _ _ (TBasicType TGType) <- t =
return $ M "(packMapStorableArray gtypeToCGType)"
| TCArray False _ _ (TBasicType TFloat) <- t =
return $ M "(packMapStorableArray realToFrac)"
| TCArray False _ _ (TBasicType TDouble) <- t =
return $ M "(packMapStorableArray realToFrac)"
| TCArray False _ _ (TBasicType _) <- t =
return $ M "packStorableArray"
| TCArray{} <- t = notImplementedError $
"Don't know how to pack C array of type " <> tshow t
| otherwise = case (tshow hType, tshow fType) of
("T.Text", "CString") -> return $ M "textToCString"
("[Char]", "CString") -> return $ M "stringToCString"
("Char", "CInt") -> return "(fromIntegral . ord)"
("Bool", "CInt") -> return "(fromIntegral . fromEnum)"
("Float", "CFloat") -> return "realToFrac"
("Double", "CDouble") -> return "realToFrac"
("GType", "CGType") -> return "gtypeToCGType"
_ -> notImplementedError $
"Don't know how to convert "
<> tshow hType <> " into "
<> tshow fType <> ".\n"
<> "Internal type: "
<> tshow t
getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor
getForeignConstructor t transfer = do
a <- findAPI t
hType <- haskellType t
fType <- foreignType t
hToF' t a hType fType transfer
hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter
hToF_PackedType t packer transfer = do
innerConstructor <- getForeignConstructor t transfer
return $ do
mapC innerConstructor
apply (M packer)
hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text)
hashTableKeyMappings (TBasicType TPtr) = return ("gDirectHash", "gDirectEqual")
hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual")
hashTableKeyMappings t =
notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported."
hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text)
hashTablePtrPackers (TBasicType TPtr) =
return ("Nothing", "ptrPackPtr", "ptrUnpackPtr")
hashTablePtrPackers (TBasicType TUTF8) =
return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr")
hashTablePtrPackers t =
notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported."
hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter
hToF_PackGHashTable keys elems = do
keysConstructor <- getForeignConstructor keys TransferEverything
elemsConstructor <- getForeignConstructor elems TransferEverything
(keyHash, keyEqual) <- hashTableKeyMappings keys
(keyDestroy, keyPack, _) <- hashTablePtrPackers keys
(elemDestroy, elemPack, _) <- hashTablePtrPackers elems
return $ do
apply (P "Map.toList")
mapFirst keysConstructor
mapSecond elemsConstructor
mapFirst (P keyPack)
mapSecond (P elemPack)
apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual,
keyDestroy, elemDestroy]))
hToF :: Type -> Transfer -> ExcCodeGen Converter
hToF (TGList t) transfer = do
isPtr <- typeIsPtr t
when (not isPtr) $
badIntroError ("'" <> tshow t <>
"' is not a pointer type, cannot pack into a GList.")
hToF_PackedType t "packGList" transfer
hToF (TGSList t) transfer = do
isPtr <- typeIsPtr t
when (not isPtr) $
badIntroError ("'" <> tshow t <>
"' is not a pointer type, cannot pack into a GSList.")
hToF_PackedType t "packGSList" transfer
hToF (TGArray t) transfer = hToF_PackedType t "packGArray" transfer
hToF (TPtrArray t) transfer = hToF_PackedType t "packGPtrArray" transfer
hToF (TGHash ta tb) _ = hToF_PackGHashTable ta tb
hToF (TCArray False (1) (1) _) _ = return $ Pure ()
hToF (TCArray zt _ _ t@(TCArray{})) transfer = do
let packer = if zt
then "packZeroTerminated"
else "pack"
hToF_PackedType t (packer <> "PtrArray") transfer
hToF (TCArray zt _ _ t@(TInterface _)) transfer = do
isScalar <- getIsScalar t
let packer = if zt
then "packZeroTerminated"
else "pack"
if isScalar
then hToF_PackedType t (packer <> "StorableArray") transfer
else do
api <- findAPI t
let size = case api of
Just (APIStruct s) -> structSize s
Just (APIUnion u) -> unionSize u
_ -> 0
if size == 0 || zt
then hToF_PackedType t (packer <> "PtrArray") transfer
else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer
hToF t transfer = do
a <- findAPI t
hType <- haskellType t
fType <- foreignType t
constructor <- hToF' t a hType fType transfer
return $ apply constructor
boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor
boxedForeignPtr constructor transfer = return $
case transfer of
TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor
_ -> M $ parenthesize $ "newBoxed " <> constructor
suForeignPtr :: Bool -> TypeRep -> Transfer -> CodeGen Constructor
suForeignPtr isBoxed hType transfer = do
let constructor = T.pack . tyConName . typeRepTyCon $ hType
if isBoxed then
boxedForeignPtr constructor transfer
else return $ M $ parenthesize $
case transfer of
TransferEverything -> "wrapPtr " <> constructor
_ -> "newPtr " <> constructor
structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor
structForeignPtr s =
suForeignPtr (structIsBoxed s)
unionForeignPtr :: Union -> TypeRep -> Transfer -> CodeGen Constructor
unionForeignPtr u =
suForeignPtr (unionIsBoxed u)
fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor
fObjectToH t hType transfer = do
let constructor = T.pack . tyConName . typeRepTyCon $ hType
isGO <- isGObject t
return $ M $ parenthesize $
case transfer of
TransferEverything ->
if isGO
then "wrapObject " <> constructor
else "wrapPtr " <> constructor
_ ->
if isGO
then "newObject " <> constructor
else "newPtr " <> constructor
fCallbackToH :: TypeRep -> Transfer -> ExcCodeGen Constructor
fCallbackToH hType TransferNothing = do
let constructor = T.pack . tyConName . typeRepTyCon $ hType
return (P (callbackDynamicWrapper constructor))
fCallbackToH _ transfer =
notImplementedError ("ForeignCallback with unsupported transfer type `"
<> tshow transfer <> "'")
fVariantToH :: Transfer -> CodeGen Constructor
fVariantToH transfer =
return $ M $ case transfer of
TransferEverything -> "wrapGVariantPtr"
_ -> "newGVariantFromPtr"
fParamSpecToH :: Transfer -> CodeGen Constructor
fParamSpecToH transfer =
return $ M $ case transfer of
TransferEverything -> "wrapGParamSpecPtr"
_ -> "newGParamSpecFromPtr"
fToH' :: Type -> Maybe API -> TypeRep -> TypeRep -> Transfer
-> ExcCodeGen Constructor
fToH' t a hType fType transfer
| ( hType == fType ) = return Id
| Just (APIEnum _) <- a = return "(toEnum . fromIntegral)"
| Just (APIFlags _) <- a = return "wordToGFlags"
| TError <- t = boxedForeignPtr "GError" transfer
| TVariant <- t = fVariantToH transfer
| TParamSpec <- t = fParamSpecToH transfer
| Just (APIStruct s) <- a = structForeignPtr s hType transfer
| Just (APIUnion u) <- a = unionForeignPtr u hType transfer
| Just (APIObject _) <- a = fObjectToH t hType transfer
| Just (APIInterface _) <- a = fObjectToH t hType transfer
| Just (APICallback _) <- a = fCallbackToH hType transfer
| TCArray True _ _ (TBasicType TUTF8) <- t =
return $ M "unpackZeroTerminatedUTF8CArray"
| TCArray True _ _ (TBasicType TFileName) <- t =
return $ M "unpackZeroTerminatedFileNameArray"
| TCArray True _ _ (TBasicType TUInt8) <- t =
return $ M "unpackZeroTerminatedByteString"
| TCArray True _ _ (TBasicType TPtr) <- t =
return $ M "unpackZeroTerminatedPtrArray"
| TCArray True _ _ (TBasicType TBoolean) <- t =
return $ M "(unpackMapZeroTerminatedStorableArray (/= 0))"
| TCArray True _ _ (TBasicType TGType) <- t =
return $ M "(unpackMapZeroTerminatedStorableArray GType)"
| TCArray True _ _ (TBasicType TFloat) <- t =
return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"
| TCArray True _ _ (TBasicType TDouble) <- t =
return $ M "(unpackMapZeroTerminatedStorableArray realToFrac)"
| TCArray True _ _ (TBasicType _) <- t =
return $ M "unpackZeroTerminatedStorableArray"
| TCArray{} <- t = notImplementedError $
"Don't know how to unpack C array of type " <> tshow t
| TByteArray <- t = return $ M "unpackGByteArray"
| TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet"
| otherwise = case (tshow fType, tshow hType) of
("CString", "T.Text") -> return $ M "cstringToText"
("CString", "[Char]") -> return $ M "cstringToString"
("CInt", "Char") -> return "(chr . fromIntegral)"
("CInt", "Bool") -> return "(/= 0)"
("CFloat", "Float") -> return "realToFrac"
("CDouble", "Double") -> return "realToFrac"
("CGType", "GType") -> return "GType"
_ ->
notImplementedError $ "Don't know how to convert "
<> tshow fType <> " into "
<> tshow hType <> ".\n"
<> "Internal type: "
<> tshow t
getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor
getHaskellConstructor t transfer = do
a <- findAPI t
hType <- haskellType t
fType <- foreignType t
fToH' t a hType fType transfer
fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter
fToH_PackedType t unpacker transfer = do
innerConstructor <- getHaskellConstructor t transfer
return $ do
apply (M unpacker)
mapC innerConstructor
fToH_UnpackGHashTable :: Type -> Type -> Transfer -> ExcCodeGen Converter
fToH_UnpackGHashTable keys elems transfer = do
keysConstructor <- getHaskellConstructor keys transfer
(_,_,keysUnpack) <- hashTablePtrPackers keys
elemsConstructor <- getHaskellConstructor elems transfer
(_,_,elemsUnpack) <- hashTablePtrPackers elems
return $ do
apply (M "unpackGHashTable")
mapFirst (P keysUnpack)
mapFirst keysConstructor
mapSecond (P elemsUnpack)
mapSecond elemsConstructor
apply (P "Map.fromList")
fToH :: Type -> Transfer -> ExcCodeGen Converter
fToH (TGList t) transfer = do
isPtr <- typeIsPtr t
when (not isPtr) $
badIntroError ("'" <> tshow t <>
"' is not a pointer type, cannot unpack from a GList.")
fToH_PackedType t "unpackGList" transfer
fToH (TGSList t) transfer = do
isPtr <- typeIsPtr t
when (not isPtr) $
badIntroError ("'" <> tshow t <>
"' is not a pointer type, cannot unpack from a GSList.")
fToH_PackedType t "unpackGSList" transfer
fToH (TGArray t) transfer = fToH_PackedType t "unpackGArray" transfer
fToH (TPtrArray t) transfer = fToH_PackedType t "unpackGPtrArray" transfer
fToH (TGHash a b) transfer = fToH_UnpackGHashTable a b transfer
fToH (TCArray False (1) (1) _) _ = return $ Pure ()
fToH (TCArray True _ _ t@(TCArray{})) transfer =
fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer
fToH (TCArray True _ _ t@(TInterface _)) transfer = do
isScalar <- getIsScalar t
if isScalar
then fToH_PackedType t "unpackZeroTerminatedStorableArray" transfer
else fToH_PackedType t "unpackZeroTerminatedPtrArray" transfer
fToH t transfer = do
a <- findAPI t
hType <- haskellType t
fType <- foreignType t
constructor <- fToH' t a hType fType transfer
return $ apply constructor
unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter
unpackCArray length (TCArray False _ _ t) transfer =
case t of
TBasicType TUTF8 -> return $ apply $ M $ parenthesize $
"unpackUTF8CArrayWithLength " <> length
TBasicType TFileName -> return $ apply $ M $ parenthesize $
"unpackFileNameArrayWithLength " <> length
TBasicType TUInt8 -> return $ apply $ M $ parenthesize $
"unpackByteStringWithLength " <> length
TBasicType TPtr -> return $ apply $ M $ parenthesize $
"unpackPtrArrayWithLength " <> length
TBasicType TBoolean -> return $ apply $ M $ parenthesize $
"unpackMapStorableArrayWithLength (/= 0) " <> length
TBasicType TGType -> return $ apply $ M $ parenthesize $
"unpackMapStorableArrayWithLength GType " <> length
TBasicType TFloat -> return $ apply $ M $ parenthesize $
"unpackMapStorableArrayWithLength realToFrac " <> length
TBasicType TDouble -> return $ apply $ M $ parenthesize $
"unpackMapStorableArrayWithLength realToFrac " <> length
TBasicType _ -> return $ apply $ M $ parenthesize $
"unpackStorableArrayWithLength " <> length
TInterface _ -> do
a <- findAPI t
isScalar <- getIsScalar t
hType <- haskellType t
fType <- foreignType t
innerConstructor <- fToH' t a hType fType transfer
let (boxed, size) = case a of
Just (APIStruct s) -> (structIsBoxed s, structSize s)
Just (APIUnion u) -> (unionIsBoxed u, unionSize u)
_ -> (False, 0)
let unpacker | isScalar = "unpackStorableArrayWithLength"
| (size == 0) = "unpackPtrArrayWithLength"
| boxed = "unpackBoxedArrayWithLength " <> tshow size
| otherwise = "unpackBlockArrayWithLength " <> tshow size
return $ do
apply $ M $ parenthesize $ unpacker <> " " <> length
mapC innerConstructor
_ -> notImplementedError $
"unpackCArray : Don't know how to unpack C Array of type " <> tshow t
unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type."
argumentType :: [Char] -> Type -> CodeGen ([Char], Text, [Text])
argumentType [] _ = error "out of letters"
argumentType letters (TGList a) = do
(ls, name, constraints) <- argumentType letters a
return (ls, "[" <> name <> "]", constraints)
argumentType letters (TGSList a) = do
(ls, name, constraints) <- argumentType letters a
return (ls, "[" <> name <> "]", constraints)
argumentType letters@(l:ls) t = do
api <- findAPI t
s <- tshow <$> haskellType t
case api of
Just (APIInterface _) -> do
cls <- typeConstraint t
return (ls, T.singleton l, [cls <> " " <> T.singleton l])
Just (APIObject _) -> do
isGO <- isGObject t
if isGO
then do cls <- typeConstraint t
return (ls, T.singleton l, [cls <> " " <> T.singleton l])
else return (letters, s, [])
Just (APICallback cb) ->
if callableThrows (cbCallable cb)
then do
ft <- tshow <$> foreignType t
return (letters, ft, [])
else
return (letters, s, [])
_ -> return (letters, s, [])
haskellBasicType TPtr = ptr $ typeOf ()
haskellBasicType TBoolean = typeOf True
haskellBasicType TInt = case sizeOf (0 :: CInt) of
4 -> typeOf (0 :: Int32)
n -> error ("Unsupported `gint' length: " ++
show n)
haskellBasicType TUInt = case sizeOf (0 :: CUInt) of
4 -> typeOf (0 :: Word32)
n -> error ("Unsupported `guint' length: " ++
show n)
haskellBasicType TLong = typeOf (0 :: CLong)
haskellBasicType TULong = typeOf (0 :: CULong)
haskellBasicType TInt8 = typeOf (0 :: Int8)
haskellBasicType TUInt8 = typeOf (0 :: Word8)
haskellBasicType TInt16 = typeOf (0 :: Int16)
haskellBasicType TUInt16 = typeOf (0 :: Word16)
haskellBasicType TInt32 = typeOf (0 :: Int32)
haskellBasicType TUInt32 = typeOf (0 :: Word32)
haskellBasicType TInt64 = typeOf (0 :: Int64)
haskellBasicType TUInt64 = typeOf (0 :: Word64)
haskellBasicType TGType = "GType" `con` []
haskellBasicType TUTF8 = "T.Text" `con` []
haskellBasicType TFloat = typeOf (0 :: Float)
haskellBasicType TDouble = typeOf (0 :: Double)
haskellBasicType TUniChar = typeOf ('\0' :: Char)
haskellBasicType TFileName = "[Char]" `con` []
haskellBasicType TIntPtr = "CIntPtr" `con` []
haskellBasicType TUIntPtr = "CUIntPtr" `con` []
haskellType :: Type -> CodeGen TypeRep
haskellType (TBasicType bt) = return $ haskellBasicType bt
haskellType (TCArray False (1) (1) t) =
ptr <$> foreignType t
haskellType (TCArray _ _ _ (TBasicType TUInt8)) =
return $ "ByteString" `con` []
haskellType (TCArray _ _ _ a) = do
inner <- haskellType a
return $ "[]" `con` [inner]
haskellType (TGArray a) = do
inner <- haskellType a
return $ "[]" `con` [inner]
haskellType (TPtrArray a) = do
inner <- haskellType a
return $ "[]" `con` [inner]
haskellType (TByteArray) = return $ "ByteString" `con` []
haskellType (TGList a) = do
inner <- haskellType a
return $ "[]" `con` [inner]
haskellType (TGSList a) = do
inner <- haskellType a
return $ "[]" `con` [inner]
haskellType (TGHash a b) = do
innerA <- haskellType a
innerB <- haskellType b
return $ "Map.Map" `con` [innerA, innerB]
haskellType TError = return $ "GError" `con` []
haskellType TVariant = return $ "GVariant" `con` []
haskellType TParamSpec = return $ "GParamSpec" `con` []
haskellType (TInterface (Name "GObject" "Value")) = return $ "GValue" `con` []
haskellType (TInterface (Name "GObject" "Closure")) = return $ "Closure" `con` []
haskellType t@(TInterface n) = do
api <- getAPI t
tname <- qualifiedAPI n
return $ case api of
(APIFlags _) -> "[]" `con` [tname `con` []]
_ -> tname `con` []
callableHasClosures :: Callable -> Bool
callableHasClosures = any (/= 1) . map argClosure . args
isoHaskellType :: Type -> CodeGen TypeRep
isoHaskellType t@(TInterface n) = do
api <- findAPI t
case api of
Just (APICallback cb) -> do
tname <- qualifiedAPI n
if callableHasClosures (cbCallable cb)
then return ((callbackHTypeWithClosures tname) `con` [])
else return (tname `con` [])
_ -> haskellType t
isoHaskellType t = haskellType t
foreignBasicType TBoolean = "CInt" `con` []
foreignBasicType TUTF8 = "CString" `con` []
foreignBasicType TFileName = "CString" `con` []
foreignBasicType TUniChar = "CInt" `con` []
foreignBasicType TFloat = "CFloat" `con` []
foreignBasicType TDouble = "CDouble" `con` []
foreignBasicType TGType = "CGType" `con` []
foreignBasicType t = haskellBasicType t
foreignType :: Type -> CodeGen TypeRep
foreignType (TBasicType t) = return $ foreignBasicType t
foreignType (TCArray False (1) (1) t) =
ptr <$> foreignType t
foreignType (TCArray zt _ _ t) = do
api <- findAPI t
let size = case api of
Just (APIStruct s) -> structSize s
Just (APIUnion u) -> unionSize u
_ -> 0
if size == 0 || zt
then ptr <$> foreignType t
else foreignType t
foreignType (TGArray a) = do
inner <- foreignType a
return $ ptr ("GArray" `con` [inner])
foreignType (TPtrArray a) = do
inner <- foreignType a
return $ ptr ("GPtrArray" `con` [inner])
foreignType (TByteArray) = return $ ptr ("GByteArray" `con` [])
foreignType (TGList a) = do
inner <- foreignType a
return $ ptr ("GList" `con` [inner])
foreignType (TGSList a) = do
inner <- foreignType a
return $ ptr ("GSList" `con` [inner])
foreignType (TGHash a b) = do
innerA <- foreignType a
innerB <- foreignType b
return $ ptr ("GHashTable" `con` [innerA, innerB])
foreignType t@TError = ptr <$> haskellType t
foreignType t@TVariant = ptr <$> haskellType t
foreignType t@TParamSpec = ptr <$> haskellType t
foreignType (TInterface (Name "GObject" "Value")) = return $ ptr $ "GValue" `con` []
foreignType (TInterface (Name "GObject" "Closure")) =
return $ ptr $ "Closure" `con` []
foreignType t@(TInterface n) = do
isScalar <- getIsScalar t
if isScalar
then return $ "CUInt" `con` []
else do
api <- getAPI t
case api of
APICallback _ -> do
tname <- qualifiedSymbol (callbackCType $ name n) n
return (funptr $ tname `con` [])
_ -> do
tname <- qualifiedAPI n
return (ptr $ tname `con` [])
getIsScalar :: Type -> CodeGen Bool
getIsScalar t = do
a <- findAPI t
case a of
Nothing -> return False
(Just (APIEnum _)) -> return True
(Just (APIFlags _)) -> return True
_ -> return False
data TypeAllocInfo = TypeAllocInfo {
typeAllocInfoIsBoxed :: Bool
, typeAllocInfoSize :: Int
}
typeAllocInfo :: Type -> CodeGen (Maybe TypeAllocInfo)
typeAllocInfo t = do
api <- findAPI t
case api of
Just (APIStruct s) -> case structSize s of
0 -> return Nothing
n -> let info = TypeAllocInfo {
typeAllocInfoIsBoxed = structIsBoxed s
, typeAllocInfoSize = n
}
in return (Just info)
_ -> return Nothing
isManaged :: Type -> CodeGen Bool
isManaged TError = return True
isManaged TVariant = return True
isManaged TParamSpec = return True
isManaged t@(TInterface _) = do
a <- findAPI t
case a of
Just (APIObject _) -> return True
Just (APIInterface _) -> return True
Just (APIStruct _) -> return True
Just (APIUnion _) -> return True
_ -> return False
isManaged _ = return False
typeIsPtr :: Type -> CodeGen Bool
typeIsPtr t = isJust <$> typePtrType t
data FFIPtrType = FFIPtr
| FFIFunPtr
typePtrType :: Type -> CodeGen (Maybe FFIPtrType)
typePtrType (TBasicType TPtr) = return (Just FFIPtr)
typePtrType (TBasicType TUTF8) = return (Just FFIPtr)
typePtrType (TBasicType TFileName) = return (Just FFIPtr)
typePtrType t = do
ft <- foreignType t
case tyConName (typeRepTyCon ft) of
"Ptr" -> return (Just FFIPtr)
"FunPtr" -> return (Just FFIFunPtr)
_ -> return Nothing
maybeNullConvert :: Type -> CodeGen (Maybe Text)
maybeNullConvert (TBasicType TPtr) = return Nothing
maybeNullConvert (TGList _) = return Nothing
maybeNullConvert (TGSList _) = return Nothing
maybeNullConvert t = do
pt <- typePtrType t
case pt of
Just FFIPtr -> return (Just "SP.convertIfNonNull")
Just FFIFunPtr -> return (Just "SP.convertFunPtrIfNonNull")
Nothing -> return Nothing
nullPtrForType :: Type -> CodeGen (Maybe Text)
nullPtrForType t = do
pt <- typePtrType t
case pt of
Just FFIPtr -> return (Just "FP.nullPtr")
Just FFIFunPtr -> return (Just "FP.nullFunPtr")
Nothing -> return Nothing
typeIsNullable :: Type -> CodeGen Bool
typeIsNullable t = isJust <$> maybeNullConvert t
elementTypeAndMap :: Type -> Text -> Maybe (Type, Text)
elementTypeAndMap (TCArray False (1) (1) _) _ = Nothing
elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing
elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray")
elementTypeAndMap (TCArray False (1) _ t) len =
Just (t, parenthesize $ "mapCArrayWithLength " <> len)
elementTypeAndMap (TCArray False fixed _ t) _ =
Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed)
elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray")
elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray")
elementTypeAndMap (TGList t) _ = Just (t, "mapGList")
elementTypeAndMap (TGSList t) _ = Just (t, "mapGSList")
elementTypeAndMap _ _ = Nothing
elementType :: Type -> Maybe Type
elementType t = fst <$> elementTypeAndMap t undefined
elementMap :: Type -> Text -> Maybe Text
elementMap t len = snd <$> elementTypeAndMap t len