{-# Language GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards #-}
{-|
Module      : Client.CApi
Description : Dynamically loaded extension API
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

Foreign interface to the IRC client via a simple C API
and dynamically loaded modules.

-}

module Client.CApi
  ( -- * Extension type
    ActiveExtension(..)

  -- * Extension callbacks
  , extensionSymbol
  , openExtension
  , startExtension
  , stopExtension
  , notifyExtension
  , commandExtension
  , chatExtension

  , ThreadEntry(..)
  , threadFinish

  , popTimer
  , pushTimer
  , cancelTimer

  , evalNestedIO
  , withChat
  , withRawIrcMsg
  ) where

import Client.CApi.Types
import Client.Configuration (ExtensionConfiguration, extensionPath, extensionRtldFlags, extensionArgs)
import Control.Lens (view)
import Control.Monad (guard, unless)
import Control.Monad.Codensity (Codensity(Codensity), lowerCodensity)
import Control.Monad.IO.Class (MonadIO(..))
import Data.IntPSQ (IntPSQ)
import Data.IntPSQ qualified as IntPSQ
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (UTCTime)
import Foreign.C (peekCString, withCString)
import Foreign.Marshal (withArray, withArrayLen, with)
import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr, nullFunPtr, nullPtr)
import Foreign.Storable (Storable(peek))
import Irc.Identifier (idText)
import Irc.RawIrcMsg (RawIrcMsg(..), TagEntry(..))
import Irc.UserInfo (UserInfo(userHost, userNick, userName))
import System.Posix.DynamicLinker (dlopen, dlclose, dlsym, DL)

------------------------------------------------------------------------

-- | The symbol that is loaded from an extension object.
--
-- Extensions are expected to export:
--
-- @
-- struct galua_extension extension;
-- @
extensionSymbol :: String
extensionSymbol :: FilePath
extensionSymbol = FilePath
"extension"

-- | Information about a loaded extension including the handle
-- to the loaded shared object, and state value returned by
-- the startup callback, and the loaded extension record.
data ActiveExtension = ActiveExtension
  { ActiveExtension -> FgnExtension
aeFgn     :: !FgnExtension -- ^ Struct of callback function pointers
  , ActiveExtension -> DL
aeDL      :: !DL           -- ^ Handle of dynamically linked extension
  , ActiveExtension -> Ptr ()
aeSession :: !(Ptr ())       -- ^ State value generated by start callback
  , ActiveExtension -> Text
aeName    :: !Text
  , ActiveExtension -> Int
aeMajorVersion, ActiveExtension -> Int
aeMinorVersion :: !Int
  , ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers  :: !(IntPSQ UTCTime TimerEntry)
  , ActiveExtension -> Int
aeNextTimer :: !Int
  , ActiveExtension -> Int
aeThreads :: !Int
  , ActiveExtension -> Bool
aeLive    :: !Bool
  }

data TimerEntry = TimerEntry !(FunPtr TimerCallback) !(Ptr ())

data ThreadEntry = ThreadEntry !(FunPtr ThreadFinish) !(Ptr ())

-- | Find the earliest timer ready to run if any are available.
popTimer ::
  ActiveExtension {- ^ extension -} ->
  Maybe (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
    {- ^ earlier time, callback, callback state, updated extension -}
popTimer :: ActiveExtension
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
popTimer ActiveExtension
ae =
  do let timers :: IntPSQ UTCTime TimerEntry
timers = ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae
     forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ActiveExtension -> Bool
aeLive ActiveExtension
ae)
     (Int
timerId, UTCTime
time, TimerEntry FunPtr TimerCallback
fun Ptr ()
ptr, IntPSQ UTCTime TimerEntry
timers') <- forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView IntPSQ UTCTime TimerEntry
timers
     let ae' :: ActiveExtension
ae' = ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = IntPSQ UTCTime TimerEntry
timers' }
     forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
time, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timerId, FunPtr TimerCallback
fun, Ptr ()
ptr, ActiveExtension
ae')

-- | Schedue a new timer event for the given extension.
pushTimer ::
  UTCTime              {- ^ activation time   -} ->
  FunPtr TimerCallback {- ^ callback function -} ->
  Ptr ()               {- ^ callback state    -} ->
  ActiveExtension      {- ^ extension         -} ->
  (Int,ActiveExtension)
pushTimer :: UTCTime
-> FunPtr TimerCallback
-> Ptr ()
-> ActiveExtension
-> (Int, ActiveExtension)
pushTimer UTCTime
time FunPtr TimerCallback
fun Ptr ()
ptr ActiveExtension
ae = TimerEntry
entry seq :: forall a b. a -> b -> b
`seq` ActiveExtension
ae' seq :: forall a b. a -> b -> b
`seq` (Int
i, ActiveExtension
ae')
  where
    entry :: TimerEntry
entry = FunPtr TimerCallback -> Ptr () -> TimerEntry
TimerEntry FunPtr TimerCallback
fun Ptr ()
ptr
    i :: Int
i     = ActiveExtension -> Int
aeNextTimer ActiveExtension
ae
    ae' :: ActiveExtension
ae'   = ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
IntPSQ.insert Int
i UTCTime
time TimerEntry
entry (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)
               , aeNextTimer :: Int
aeNextTimer = Int
i forall a. Num a => a -> a -> a
+ Int
1 }

-- | Remove a timer from the schedule by ID
cancelTimer ::
  Int             {- ^ timer ID  -}  ->
  ActiveExtension {- ^ extension -}  ->
  Maybe (Ptr (), ActiveExtension)
cancelTimer :: Int -> ActiveExtension -> Maybe (Ptr (), ActiveExtension)
cancelTimer Int
timerId ActiveExtension
ae =
  do (UTCTime
_, TimerEntry FunPtr TimerCallback
_ Ptr ()
ptr) <- forall p v. Int -> IntPSQ p v -> Maybe (p, v)
IntPSQ.lookup Int
timerId (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)
     forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr ()
ptr, ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v
IntPSQ.delete Int
timerId (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)})

-- | Load the extension from the given path and call the start
-- callback. The result of the start callback is saved to be
-- passed to any subsequent calls into the extension.
openExtension ::
  ExtensionConfiguration {- ^ extension configuration -} ->
  IO ActiveExtension
openExtension :: ExtensionConfiguration -> IO ActiveExtension
openExtension ExtensionConfiguration
config =
  do DL
dl   <- FilePath -> [RTLDFlags] -> IO DL
dlopen (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ExtensionConfiguration FilePath
extensionPath ExtensionConfiguration
config)
                    (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ExtensionConfiguration [RTLDFlags]
extensionRtldFlags ExtensionConfiguration
config)
     FunPtr Any
p    <- forall a. DL -> FilePath -> IO (FunPtr a)
dlsym DL
dl FilePath
extensionSymbol
     FgnExtension
fgn  <- forall a. Storable a => Ptr a -> IO a
peek (forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr Any
p)
     FilePath
name <- CString -> IO FilePath
peekCString (FgnExtension -> CString
fgnName FgnExtension
fgn)
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ActiveExtension
       { aeFgn :: FgnExtension
aeFgn          = FgnExtension
fgn
       , aeDL :: DL
aeDL           = DL
dl
       , aeSession :: Ptr ()
aeSession      = forall a. Ptr a
nullPtr
       , aeName :: Text
aeName         = FilePath -> Text
Text.pack FilePath
name
       , aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers       = forall p v. IntPSQ p v
IntPSQ.empty
       , aeMajorVersion :: Int
aeMajorVersion = forall a b. (Integral a, Num b) => a -> b
fromIntegral (FgnExtension -> CInt
fgnMajorVersion FgnExtension
fgn)
       , aeMinorVersion :: Int
aeMinorVersion = forall a b. (Integral a, Num b) => a -> b
fromIntegral (FgnExtension -> CInt
fgnMinorVersion FgnExtension
fgn)
       , aeNextTimer :: Int
aeNextTimer    = Int
1
       , aeThreads :: Int
aeThreads      = Int
0
       , aeLive :: Bool
aeLive         = Bool
True
       }

startExtension ::
  Ptr ()                 {- ^ client stable pointer   -} ->
  ExtensionConfiguration {- ^ extension configuration -} ->
  ActiveExtension        {- ^ active extension        -} ->
  IO (Ptr ())            {- ^ extension state         -}
startExtension :: Ptr () -> ExtensionConfiguration -> ActiveExtension -> IO (Ptr ())
startExtension Ptr ()
stab ExtensionConfiguration
config ActiveExtension
ae =
  do let f :: FunPtr StartExtension
f = FgnExtension -> FunPtr StartExtension
fgnStart (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     if forall a. FunPtr a
nullFunPtr forall a. Eq a => a -> a -> Bool
== FunPtr StartExtension
f
       then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Ptr a
nullPtr
       else forall a. NestedIO a -> IO a
evalNestedIO forall a b. (a -> b) -> a -> b
$
                  do CString
extPath <- forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 (forall a. FilePath -> (CString -> IO a) -> IO a
withCString (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ExtensionConfiguration FilePath
extensionPath ExtensionConfiguration
config))
                     [FgnStringLen]
args <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> NestedIO FgnStringLen
withText
                           forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ExtensionConfiguration [Text]
extensionArgs ExtensionConfiguration
config
                     Ptr FgnStringLen
argsArray <- forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 (forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [FgnStringLen]
args)
                     let len :: CSize
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [FgnStringLen]
args)
                     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Dynamic StartExtension
runStartExtension FunPtr StartExtension
f Ptr ()
stab CString
extPath Ptr FgnStringLen
argsArray CSize
len)

stopExtension :: ActiveExtension -> IO ()
stopExtension :: ActiveExtension -> IO ()
stopExtension ActiveExtension
ae =
  do let f :: FunPtr StopExtension
f = FgnExtension -> FunPtr StopExtension
fgnStop (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. FunPtr a
nullFunPtr forall a. Eq a => a -> a -> Bool
== FunPtr StopExtension
f) forall a b. (a -> b) -> a -> b
$
       Dynamic StopExtension
runStopExtension FunPtr StopExtension
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae)
     DL -> IO ()
dlclose (ActiveExtension -> DL
aeDL ActiveExtension
ae)

-- | Call all of the process chat callbacks in the list of extensions.
-- This operation marshals the IRC message once and shares that across
-- all of the callbacks.
--
-- Returns 'True' to pass message to client.  Returns 'False to drop message.
chatExtension ::
  ActiveExtension {- ^ extension               -} ->
  Ptr FgnChat     {- ^ serialized chat message -} ->
  IO Bool         {- ^ allow message           -}
chatExtension :: ActiveExtension -> Ptr FgnChat -> IO Bool
chatExtension ActiveExtension
ae Ptr FgnChat
chat =
  do let f :: FunPtr ProcessChat
f = FgnExtension -> FunPtr ProcessChat
fgnChat (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     if FunPtr ProcessChat
f forall a. Eq a => a -> a -> Bool
== forall a. FunPtr a
nullFunPtr
       then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else (ProcessResult
passMessage forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic ProcessChat
runProcessChat FunPtr ProcessChat
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnChat
chat

-- | Call all of the process message callbacks in the list of extensions.
-- This operation marshals the IRC message once and shares that across
-- all of the callbacks.
--
-- Returns 'True' to pass message to client.  Returns 'False to drop message.
notifyExtension ::
  ActiveExtension {- ^ extension                  -} ->
  Ptr FgnMsg      {- ^ serialized IRC message     -} ->
  IO Bool         {- ^ allow message              -}
notifyExtension :: ActiveExtension -> Ptr FgnMsg -> IO Bool
notifyExtension ActiveExtension
ae Ptr FgnMsg
msg =
  do let f :: FunPtr ProcessMessage
f = FgnExtension -> FunPtr ProcessMessage
fgnMessage (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     if FunPtr ProcessMessage
f forall a. Eq a => a -> a -> Bool
== forall a. FunPtr a
nullFunPtr
       then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else (ProcessResult
passMessage forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic ProcessMessage
runProcessMessage FunPtr ProcessMessage
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnMsg
msg


-- | Notify an extension of a client command with the given parameters.
commandExtension ::
  Text            {- ^ command                -} ->
  ActiveExtension {- ^ extension to command   -} ->
  IO ()
commandExtension :: Text -> ActiveExtension -> IO ()
commandExtension Text
command ActiveExtension
ae = forall a. NestedIO a -> IO a
evalNestedIO forall a b. (a -> b) -> a -> b
$
  do Ptr FgnCmd
cmd <- Text -> NestedIO (Ptr FgnCmd)
withCommand Text
command
     let f :: FunPtr ProcessCommand
f = FgnExtension -> FunPtr ProcessCommand
fgnCommand (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FunPtr ProcessCommand
f forall a. Eq a => a -> a -> Bool
== forall a. FunPtr a
nullFunPtr)
            forall a b. (a -> b) -> a -> b
$ Dynamic ProcessCommand
runProcessCommand FunPtr ProcessCommand
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnCmd
cmd

-- | Notify an extension that one of its threads has finished.
threadFinish :: ThreadEntry -> IO ()
threadFinish :: ThreadEntry -> IO ()
threadFinish (ThreadEntry FunPtr StopExtension
f Ptr ()
x) = Dynamic StopExtension
runThreadFinish FunPtr StopExtension
f Ptr ()
x

-- | Marshal a 'RawIrcMsg' into a 'FgnMsg' which will be valid for
-- the remainder of the computation.
withRawIrcMsg ::
  Text                 {- ^ network      -} ->
  RawIrcMsg            {- ^ message      -} ->
  NestedIO (Ptr FgnMsg)
withRawIrcMsg :: Text -> RawIrcMsg -> NestedIO (Ptr FgnMsg)
withRawIrcMsg Text
network RawIrcMsg{[Text]
[TagEntry]
Maybe UserInfo
Text
_msgTags :: RawIrcMsg -> [TagEntry]
_msgPrefix :: RawIrcMsg -> Maybe UserInfo
_msgCommand :: RawIrcMsg -> Text
_msgParams :: RawIrcMsg -> [Text]
_msgParams :: [Text]
_msgCommand :: Text
_msgPrefix :: Maybe UserInfo
_msgTags :: [TagEntry]
..} =
  do FgnStringLen
net     <- Text -> NestedIO FgnStringLen
withText Text
network
     FgnStringLen
pfxN    <- Text -> NestedIO FgnStringLen
withText forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty (Identifier -> Text
idTextforall b c a. (b -> c) -> (a -> b) -> a -> c
.UserInfo -> Identifier
userNick) Maybe UserInfo
_msgPrefix
     FgnStringLen
pfxU    <- Text -> NestedIO FgnStringLen
withText forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty UserInfo -> Text
userName Maybe UserInfo
_msgPrefix
     FgnStringLen
pfxH    <- Text -> NestedIO FgnStringLen
withText forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty UserInfo -> Text
userHost Maybe UserInfo
_msgPrefix
     FgnStringLen
cmd     <- Text -> NestedIO FgnStringLen
withText Text
_msgCommand
     [FgnStringLen]
prms    <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> NestedIO FgnStringLen
withText [Text]
_msgParams
     [(FgnStringLen, FgnStringLen)]
tags    <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag  [TagEntry]
_msgTags
     let ([FgnStringLen]
keys,[FgnStringLen]
vals) = forall a b. [(a, b)] -> ([a], [b])
unzip [(FgnStringLen, FgnStringLen)]
tags
     (Int
tagN,Ptr FgnStringLen
keysPtr) <- forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [FgnStringLen]
keys
     Ptr FgnStringLen
valsPtr        <- forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [FgnStringLen]
vals
     (Int
prmN,Ptr FgnStringLen
prmPtr)  <- forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [FgnStringLen]
prms
     forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with forall a b. (a -> b) -> a -> b
$ FgnStringLen
-> FgnStringLen
-> FgnStringLen
-> FgnStringLen
-> FgnStringLen
-> Ptr FgnStringLen
-> CSize
-> Ptr FgnStringLen
-> Ptr FgnStringLen
-> CSize
-> FgnMsg
FgnMsg FgnStringLen
net FgnStringLen
pfxN FgnStringLen
pfxU FgnStringLen
pfxH FgnStringLen
cmd Ptr FgnStringLen
prmPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prmN)
                                       Ptr FgnStringLen
keysPtr Ptr FgnStringLen
valsPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tagN)

withChat ::
  Text {- ^ network -} ->
  Text {- ^ target  -} ->
  Text {- ^ message -} ->
  NestedIO (Ptr FgnChat)
withChat :: Text -> Text -> Text -> NestedIO (Ptr FgnChat)
withChat Text
net Text
tgt Text
msg =
  do FgnStringLen
net' <- Text -> NestedIO FgnStringLen
withText Text
net
     FgnStringLen
tgt' <- Text -> NestedIO FgnStringLen
withText Text
tgt
     FgnStringLen
msg' <- Text -> NestedIO FgnStringLen
withText Text
msg
     forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with forall a b. (a -> b) -> a -> b
$ FgnStringLen -> FgnStringLen -> FgnStringLen -> FgnChat
FgnChat FgnStringLen
net' FgnStringLen
tgt' FgnStringLen
msg'

withCommand ::
  Text {- ^ command -} ->
  NestedIO (Ptr FgnCmd)
withCommand :: Text -> NestedIO (Ptr FgnCmd)
withCommand Text
command =
  do FgnStringLen
cmd <- Text -> NestedIO FgnStringLen
withText Text
command
     forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with forall a b. (a -> b) -> a -> b
$ FgnStringLen -> FgnCmd
FgnCmd FgnStringLen
cmd

withTag :: TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag :: TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag (TagEntry Text
k Text
v) =
  do FgnStringLen
pk <- Text -> NestedIO FgnStringLen
withText Text
k
     FgnStringLen
pv <- Text -> NestedIO FgnStringLen
withText Text
v
     forall (m :: * -> *) a. Monad m => a -> m a
return (FgnStringLen
pk,FgnStringLen
pv)

withText :: Text -> NestedIO FgnStringLen
withText :: Text -> NestedIO FgnStringLen
withText Text
txt =
  do (CString
ptr,Int
len) <- forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall a b. (a -> b) -> a -> b
$ forall a. Text -> ((CString, Int) -> IO a) -> IO a
withText0 Text
txt
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CString -> CSize -> FgnStringLen
FgnStringLen CString
ptr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len

------------------------------------------------------------------------

-- | Continuation-passing style bracked IO actions.
newtype NestedIO a = NestedIO (Codensity IO a)
  deriving (forall a b. a -> NestedIO b -> NestedIO a
forall a b. (a -> b) -> NestedIO a -> NestedIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NestedIO b -> NestedIO a
$c<$ :: forall a b. a -> NestedIO b -> NestedIO a
fmap :: forall a b. (a -> b) -> NestedIO a -> NestedIO b
$cfmap :: forall a b. (a -> b) -> NestedIO a -> NestedIO b
Functor, Functor NestedIO
forall a. a -> NestedIO a
forall a b. NestedIO a -> NestedIO b -> NestedIO a
forall a b. NestedIO a -> NestedIO b -> NestedIO b
forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b
forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. NestedIO a -> NestedIO b -> NestedIO a
$c<* :: forall a b. NestedIO a -> NestedIO b -> NestedIO a
*> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
$c*> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
liftA2 :: forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
<*> :: forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b
$c<*> :: forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b
pure :: forall a. a -> NestedIO a
$cpure :: forall a. a -> NestedIO a
Applicative, Applicative NestedIO
forall a. a -> NestedIO a
forall a b. NestedIO a -> NestedIO b -> NestedIO b
forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> NestedIO a
$creturn :: forall a. a -> NestedIO a
>> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
$c>> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
>>= :: forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b
$c>>= :: forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b
Monad, Monad NestedIO
forall a. IO a -> NestedIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> NestedIO a
$cliftIO :: forall a. IO a -> NestedIO a
MonadIO)

-- | Return the bracket IO action.
evalNestedIO :: NestedIO a -> IO a
evalNestedIO :: forall a. NestedIO a -> IO a
evalNestedIO (NestedIO Codensity IO a
m) = forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Codensity IO a
m

-- | Wrap up a bracketing IO operation where the continuation takes 1 argument
nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 :: forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall r. (a -> IO r) -> IO r
f = forall a. Codensity IO a -> NestedIO a
NestedIO (forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall r. (a -> IO r) -> IO r
f)

-- | Wrap up a bracketing IO operation where the continuation takes 2 argument
nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a,b)
nest2 :: forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 forall r. (a -> b -> IO r) -> IO r
f = forall a. Codensity IO a -> NestedIO a
NestedIO (forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity (forall r. (a -> b -> IO r) -> IO r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. ((a, b) -> c) -> a -> b -> c
curry))