module Data.GI.CodeGen.Signal
( genSignal
, genSignalConnector
, genCallback
, signalHaskellName
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM, forM_, when, unless)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Bool (bool)
import qualified Data.Text as T
import Data.Text (Text)
import Text.Show.Pretty (ppShow)
import Data.GI.CodeGen.API
import Data.GI.CodeGen.Callable (hOutType, wrapMaybe,
fixupCallerAllocates,
genDynamicCallableWrapper, ExposeClosures(..),
callableHInArgs, callableHOutArgs)
import Data.GI.CodeGen.Code
import Data.GI.CodeGen.Conversions
import Data.GI.CodeGen.Haddock (deprecatedPragma)
import Data.GI.CodeGen.SymbolNaming
import Data.GI.CodeGen.Transfer (freeContainerType)
import Data.GI.CodeGen.Type
import Data.GI.CodeGen.Util (parenthesize, withComment, tshow, terror,
lcFirst, ucFirst, prime)
genHaskellCallbackPrototype :: Text -> Callable -> Text -> ExposeClosures ->
ExcCodeGen ()
genHaskellCallbackPrototype subsec cb htype expose = group $ do
let name' = case expose of
WithClosures -> callbackHTypeWithClosures htype
WithoutClosures -> htype
(hInArgs, _) = callableHInArgs cb expose
hOutArgs = callableHOutArgs cb
exportSignal subsec name'
line $ "type " <> name' <> " ="
indent $ do
forM_ hInArgs $ \arg -> do
ht <- haskellType (argType arg)
wrapMaybe arg >>= bool
(line $ typeShow ht <> " ->")
(line $ typeShow (maybeT ht) <> " ->")
ret <- hOutType cb hOutArgs
line $ typeShow $ io ret
blank
exportSignal subsec ("no" <> name')
line $ "no" <> name' <> " :: Maybe " <> name'
line $ "no" <> name' <> " = Nothing"
genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen Text
genCCallbackPrototype subsec cb name' isSignal = group $ do
let ctypeName = callbackCType name'
exportSignal subsec ctypeName
line $ "type " <> ctypeName <> " ="
indent $ do
when isSignal $ line $ withComment "Ptr () ->" "object"
forM_ (args cb) $ \arg -> do
ht <- foreignType $ argType arg
let ht' = if direction arg /= DirectionIn
then ptr ht
else ht
line $ typeShow ht' <> " ->"
when (callableThrows cb) $
line "Ptr (Ptr GError) ->"
when isSignal $ line $ withComment "Ptr () ->" "user_data"
ret <- io <$> case returnType cb of
Nothing -> return $ con0 "()"
Just t -> foreignType t
line $ typeShow ret
return ctypeName
genCallbackWrapperFactory :: Text -> Text -> CodeGen ()
genCallbackWrapperFactory subsec name' = group $ do
let factoryName = callbackWrapperAllocator name'
line "foreign import ccall \"wrapper\""
indent $ line $ factoryName <> " :: " <> callbackCType name'
<> " -> IO (FunPtr " <> callbackCType name' <> ")"
exportSignal subsec factoryName
genWrappedCallback :: Callable -> Text -> Text -> Bool -> CodeGen Text
genWrappedCallback cb cbArg callback isSignal = do
drop <- if callableHasClosures cb
then do
let arg' = prime cbArg
line $ "let " <> arg' <> " = "
<> callbackDropClosures callback <> " " <> cbArg
return arg'
else return cbArg
line $ "let " <> prime drop <> " = " <> callbackHaskellToForeign callback <>
if isSignal
then " " <> drop
else " Nothing " <> drop
return (prime drop)
genClosure :: Text -> Callable -> Text -> Text -> Bool -> CodeGen ()
genClosure subsec cb callback name isSignal = group $ do
let closure = callbackClosureGenerator name
exportSignal subsec closure
group $ do
line $ closure <> " :: " <> callback <> " -> IO Closure"
line $ closure <> " cb = do"
indent $ do
wrapped <- genWrappedCallback cb "cb" callback isSignal
line $ callbackWrapperAllocator callback <> " " <> wrapped
<> " >>= newCClosure"
convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text
convertNullable aname c = do
line $ "maybe" <> ucFirst aname <> " <-"
indent $ do
line $ "if " <> aname <> " == nullPtr"
line "then return Nothing"
line "else do"
indent $ do
unpacked <- c
line $ "return $ Just " <> unpacked
return $ "maybe" <> ucFirst aname
convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text
convertCallbackInCArray callable arg t@(TCArray False (1) length _) aname =
if length > 1
then wrapMaybe arg >>= bool convertAndFree
(convertNullable aname convertAndFree)
else
return aname
where
lname = escapedArgName $ args callable !! length
convertAndFree :: ExcCodeGen Text
convertAndFree = do
unpacked <- convert aname $ unpackCArray lname t (transfer arg)
freeContainerType (transfer arg) t aname lname
return unpacked
convertCallbackInCArray _ t _ _ =
terror $ "convertOutCArray : unexpected " <> tshow t
prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text
prepareArgForCall cb arg = case direction arg of
DirectionIn -> prepareInArg cb arg
DirectionInout -> prepareInoutArg arg
DirectionOut -> terror "Unexpected DirectionOut!"
prepareInArg :: Callable -> Arg -> ExcCodeGen Text
prepareInArg cb arg = do
let name = escapedArgName arg
case argType arg of
t@(TCArray False _ _ _) -> convertCallbackInCArray cb arg t name
_ -> do
let c = convert name $ fToH (argType arg) (transfer arg)
wrapMaybe arg >>= bool c (convertNullable name c)
prepareInoutArg :: Arg -> ExcCodeGen Text
prepareInoutArg arg = do
let name = escapedArgName arg
name' <- genConversion name $ apply $ M "peek"
convert name' $ fToH (argType arg) (transfer arg)
saveOutArg :: Arg -> ExcCodeGen ()
saveOutArg arg = do
let name = escapedArgName arg
name' = "out" <> name
when (transfer arg /= TransferEverything) $
notImplementedError $ "Unexpected transfer type for \"" <> name <> "\""
isMaybe <- wrapMaybe arg
name'' <- if isMaybe
then do
let name'' = prime name'
line $ name'' <> " <- case " <> name' <> " of"
indent $ do
line "Nothing -> return nullPtr"
line $ "Just " <> name'' <> " -> do"
indent $ do
converted <- convert name'' $ hToF (argType arg) TransferEverything
line $ "return " <> converted
return name''
else convert name' $ hToF (argType arg) TransferEverything
line $ "poke " <> name <> " " <> name''
genDropClosures :: Text -> Callable -> Text -> CodeGen ()
genDropClosures subsec cb name' = group $ do
let dropper = callbackDropClosures name'
(inWithClosures, _) = callableHInArgs cb WithClosures
(inWithoutClosures, _) = callableHInArgs cb WithoutClosures
passOrIgnore = \arg -> if arg `elem` inWithoutClosures
then Just (escapedArgName arg)
else Nothing
argNames = map (maybe "_" id . passOrIgnore) inWithClosures
exportSignal subsec dropper
line $ dropper <> " :: " <> name' <> " -> " <> callbackHTypeWithClosures name'
line $ dropper <> " _f " <> T.unwords argNames <> " = _f "
<> T.unwords (catMaybes (map passOrIgnore inWithClosures))
genCallbackWrapper :: Text -> Callable -> Text -> Bool -> ExcCodeGen ()
genCallbackWrapper subsec cb name' isSignal = group $ do
let wrapperName = callbackHaskellToForeign name'
(hInArgs, _) = callableHInArgs cb WithClosures
hOutArgs = callableHOutArgs cb
exportSignal subsec wrapperName
group $ do
line $ wrapperName <> " ::"
indent $ do
if isSignal
then do
line $ name' <> " ->"
line "Ptr () ->"
else do
line $ "Maybe (Ptr (FunPtr " <> callbackCType name' <> ")) ->"
let hType = if callableHasClosures cb
then callbackHTypeWithClosures name'
else name'
line $ hType <> " ->"
forM_ (args cb) $ \arg -> do
ht <- foreignType $ argType arg
let ht' = if direction arg /= DirectionIn
then ptr ht
else ht
line $ typeShow ht' <> " ->"
when (callableThrows cb) $
line "Ptr (Ptr GError) ->"
when isSignal $ line "Ptr () ->"
ret <- io <$> case returnType cb of
Nothing -> return $ con0 "()"
Just t -> foreignType t
line $ typeShow ret
let cArgNames = map escapedArgName (args cb)
allArgs = if isSignal
then T.unwords $ ["_cb", "_"] <> cArgNames <> ["_"]
else T.unwords $ ["funptrptr", "_cb"] <> cArgNames
line $ wrapperName <> " " <> allArgs <> " = do"
indent $ do
hInNames <- forM hInArgs (prepareArgForCall cb)
let maybeReturn = case returnType cb of
Nothing -> []
_ -> ["result"]
returnVars = maybeReturn <> map (("out"<>) . escapedArgName) hOutArgs
mkTuple = parenthesize . T.intercalate ", "
returnBind = case returnVars of
[] -> ""
[r] -> r <> " <- "
_ -> mkTuple returnVars <> " <- "
line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames)
forM_ hOutArgs saveOutArg
unless isSignal $ line "maybeReleaseFunPtr funptrptr"
case returnType cb of
Nothing -> return ()
Just r -> do
nullableReturnType <- typeIsNullable r
if returnMayBeNull cb && nullableReturnType
then do
line "maybeM nullPtr result $ \\result' -> do"
indent $ unwrapped "result'"
else unwrapped "result"
where
unwrapped rname = do
result' <- convert rname $ hToF r (returnTransfer cb)
line $ "return " <> result'
genCallback :: Name -> Callback -> CodeGen ()
genCallback n (Callback {cbCallable = cb}) = do
let name' = upperName n
line $ "-- callback " <> name'
line $ "-- -> " <> tshow (fixupCallerAllocates cb)
if skipReturn cb
then group $ do
line $ "-- XXX Skipping callback " <> name'
line $ "-- Callbacks skipping return unsupported :\n"
<> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb)
else do
let cb' = fixupCallerAllocates cb
handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "
<> name' <>
"\n-- Error was : " <> describeCGError e)) $ do
typeSynonym <- genCCallbackPrototype name' cb' name' False
dynamic <- genDynamicCallableWrapper n typeSynonym cb
exportSignal name' dynamic
genCallbackWrapperFactory name' name'
deprecatedPragma name' (callableDeprecated cb')
genHaskellCallbackPrototype name' cb' name' WithoutClosures
when (callableHasClosures cb') $ do
genHaskellCallbackPrototype name' cb' name' WithClosures
genDropClosures name' cb' name'
if callableThrows cb'
then do
line $ "-- No Haskell->C wrapper generated since the function throws."
blank
else do
genClosure name' cb' name' name' False
genCallbackWrapper name' cb' name' False
signalHaskellName :: Text -> Text
signalHaskellName sn = let (w:ws) = T.split (== '-') sn
in w <> T.concat (map ucFirst ws)
genSignal :: Signal -> Name -> ExcCodeGen ()
genSignal s@(Signal { sigName = sn, sigCallable = cb }) on = do
let on' = upperName on
line $ "-- signal " <> on' <> "::" <> sn
let sn' = signalHaskellName sn
signalConnectorName = on' <> ucFirst sn'
cbType = signalConnectorName <> "Callback"
deprecatedPragma cbType (callableDeprecated cb)
genHaskellCallbackPrototype (lcFirst sn') cb cbType WithoutClosures
_ <- genCCallbackPrototype (lcFirst sn') cb cbType True
genCallbackWrapperFactory (lcFirst sn') cbType
if callableThrows cb
then do
line $ "-- No Haskell->C wrapper generated since the function throws."
blank
else do
genClosure (lcFirst sn') cb cbType signalConnectorName True
genCallbackWrapper (lcFirst sn') cb cbType True
group $ do
klass <- classConstraint on
let signatureConstraints = "(" <> klass <> " a, MonadIO m) =>"
signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"
signature = " :: " <> signatureConstraints <> " " <> signatureArgs
onName = "on" <> signalConnectorName
afterName = "after" <> signalConnectorName
group $ do
line $ onName <> signature
line $ onName <> " obj cb = liftIO $ do"
indent $ genSignalConnector s cbType "SignalConnectBefore"
exportSignal (lcFirst sn') onName
group $ do
line $ afterName <> signature
line $ afterName <> " obj cb = liftIO $ do"
indent $ genSignalConnector s cbType "SignalConnectAfter"
exportSignal (lcFirst sn') afterName
genSignalConnector :: Signal
-> Text
-> Text
-> CodeGen ()
genSignalConnector (Signal {sigName = sn, sigCallable = cb}) cbType when = do
cb' <- genWrappedCallback cb "cb" cbType True
let cb'' = prime cb'
line $ cb'' <> " <- " <> callbackWrapperAllocator cbType <> " " <> cb'
line $ "connectSignalFunPtr obj \"" <> sn <> "\" " <> cb'' <> " " <> when