{-# Language GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards #-}
module Client.CApi
(
ActiveExtension(..)
, extensionSymbol
, openExtension
, startExtension
, stopExtension
, notifyExtension
, commandExtension
, chatExtension
, ThreadEntry(..)
, threadFinish
, popTimer
, pushTimer
, cancelTimer
, evalNestedIO
, withChat
, withRawIrcMsg
) where
import Client.Configuration
(ExtensionConfiguration,
extensionPath, extensionRtldFlags, extensionArgs)
import Client.CApi.Types
import Control.Lens (view)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Codensity
import Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as IntPSQ
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Irc.Identifier
import Irc.RawIrcMsg
import Irc.UserInfo
import System.Posix.DynamicLinker
extensionSymbol :: String
extensionSymbol :: String
extensionSymbol = String
"extension"
data ActiveExtension = ActiveExtension
{ ActiveExtension -> FgnExtension
aeFgn :: !FgnExtension
, ActiveExtension -> DL
aeDL :: !DL
, ActiveExtension -> Ptr ()
aeSession :: !(Ptr ())
, 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 ())
popTimer ::
ActiveExtension ->
Maybe (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
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
Bool -> Maybe ()
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') <- IntPSQ UTCTime TimerEntry
-> Maybe (Int, UTCTime, TimerEntry, IntPSQ UTCTime TimerEntry)
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' }
(UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
-> Maybe
(UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
time, Int -> TimerId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timerId, FunPtr TimerCallback
fun, Ptr ()
ptr, ActiveExtension
ae')
pushTimer ::
UTCTime ->
FunPtr TimerCallback ->
Ptr () ->
ActiveExtension ->
(Int,ActiveExtension)
pushTimer :: UTCTime
-> FunPtr TimerCallback
-> Ptr ()
-> ActiveExtension
-> (Int, ActiveExtension)
pushTimer UTCTime
time FunPtr TimerCallback
fun Ptr ()
ptr ActiveExtension
ae = TimerEntry
entry TimerEntry -> (Int, ActiveExtension) -> (Int, ActiveExtension)
`seq` ActiveExtension
ae' ActiveExtension -> (Int, ActiveExtension) -> (Int, ActiveExtension)
`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 = Int
-> UTCTime
-> TimerEntry
-> IntPSQ UTCTime TimerEntry
-> IntPSQ UTCTime TimerEntry
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
cancelTimer ::
Int ->
ActiveExtension ->
Maybe (Ptr (), ActiveExtension)
cancelTimer :: Int -> ActiveExtension -> Maybe (Ptr (), ActiveExtension)
cancelTimer Int
timerId ActiveExtension
ae =
do (UTCTime
_, TimerEntry FunPtr TimerCallback
_ Ptr ()
ptr) <- Int -> IntPSQ UTCTime TimerEntry -> Maybe (UTCTime, TimerEntry)
forall p v. Int -> IntPSQ p v -> Maybe (p, v)
IntPSQ.lookup Int
timerId (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)
(Ptr (), ActiveExtension) -> Maybe (Ptr (), ActiveExtension)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr ()
ptr, ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = Int -> IntPSQ UTCTime TimerEntry -> IntPSQ UTCTime TimerEntry
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v
IntPSQ.delete Int
timerId (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)})
openExtension ::
ExtensionConfiguration ->
IO ActiveExtension
openExtension :: ExtensionConfiguration -> IO ActiveExtension
openExtension ExtensionConfiguration
config =
do DL
dl <- String -> [RTLDFlags] -> IO DL
dlopen (Getting String ExtensionConfiguration String
-> ExtensionConfiguration -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String ExtensionConfiguration String
Lens' ExtensionConfiguration String
extensionPath ExtensionConfiguration
config)
(Getting [RTLDFlags] ExtensionConfiguration [RTLDFlags]
-> ExtensionConfiguration -> [RTLDFlags]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [RTLDFlags] ExtensionConfiguration [RTLDFlags]
Lens' ExtensionConfiguration [RTLDFlags]
extensionRtldFlags ExtensionConfiguration
config)
FunPtr Any
p <- DL -> String -> IO (FunPtr Any)
forall a. DL -> String -> IO (FunPtr a)
dlsym DL
dl String
extensionSymbol
FgnExtension
fgn <- Ptr FgnExtension -> IO FgnExtension
forall a. Storable a => Ptr a -> IO a
peek (FunPtr Any -> Ptr FgnExtension
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr Any
p)
String
name <- CString -> IO String
peekCString (FgnExtension -> CString
fgnName FgnExtension
fgn)
ActiveExtension -> IO ActiveExtension
forall (m :: * -> *) a. Monad m => a -> m a
return (ActiveExtension -> IO ActiveExtension)
-> ActiveExtension -> IO ActiveExtension
forall a b. (a -> b) -> a -> b
$! ActiveExtension :: FgnExtension
-> DL
-> Ptr ()
-> Text
-> Int
-> Int
-> IntPSQ UTCTime TimerEntry
-> Int
-> Int
-> Bool
-> ActiveExtension
ActiveExtension
{ aeFgn :: FgnExtension
aeFgn = FgnExtension
fgn
, aeDL :: DL
aeDL = DL
dl
, aeSession :: Ptr ()
aeSession = Ptr ()
forall a. Ptr a
nullPtr
, aeName :: Text
aeName = String -> Text
Text.pack String
name
, aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = IntPSQ UTCTime TimerEntry
forall p v. IntPSQ p v
IntPSQ.empty
, aeMajorVersion :: Int
aeMajorVersion = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FgnExtension -> CInt
fgnMajorVersion FgnExtension
fgn)
, aeMinorVersion :: Int
aeMinorVersion = CInt -> Int
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 () ->
ExtensionConfiguration ->
ActiveExtension ->
IO (Ptr ())
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 FunPtr StartExtension
forall a. FunPtr a
nullFunPtr FunPtr StartExtension -> FunPtr StartExtension -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr StartExtension
f
then Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
forall a. Ptr a
nullPtr
else NestedIO (Ptr ()) -> IO (Ptr ())
forall a. NestedIO a -> IO a
evalNestedIO (NestedIO (Ptr ()) -> IO (Ptr ()))
-> NestedIO (Ptr ()) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$
do CString
extPath <- (forall r. (CString -> IO r) -> IO r) -> NestedIO CString
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 (String -> (CString -> IO r) -> IO r
forall a. String -> (CString -> IO a) -> IO a
withCString (Getting String ExtensionConfiguration String
-> ExtensionConfiguration -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String ExtensionConfiguration String
Lens' ExtensionConfiguration String
extensionPath ExtensionConfiguration
config))
[FgnStringLen]
args <- (Text -> NestedIO FgnStringLen)
-> [Text] -> NestedIO [FgnStringLen]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> NestedIO FgnStringLen
withText
([Text] -> NestedIO [FgnStringLen])
-> [Text] -> NestedIO [FgnStringLen]
forall a b. (a -> b) -> a -> b
$ Getting [Text] ExtensionConfiguration [Text]
-> ExtensionConfiguration -> [Text]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Text] ExtensionConfiguration [Text]
Lens' ExtensionConfiguration [Text]
extensionArgs ExtensionConfiguration
config
Ptr FgnStringLen
argsArray <- (forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ([FgnStringLen] -> (Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [FgnStringLen]
args)
let len :: CSize
len = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([FgnStringLen] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FgnStringLen]
args)
IO (Ptr ()) -> NestedIO (Ptr ())
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)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FunPtr StopExtension
forall a. FunPtr a
nullFunPtr FunPtr StopExtension -> FunPtr StopExtension -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr StopExtension
f) (IO () -> IO ()) -> IO () -> IO ()
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)
chatExtension ::
ActiveExtension ->
Ptr FgnChat ->
IO Bool
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 FunPtr ProcessChat -> FunPtr ProcessChat -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessChat
forall a. FunPtr a
nullFunPtr
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else (ProcessResult
passMessage ProcessResult -> ProcessResult -> Bool
forall a. Eq a => a -> a -> Bool
==) (ProcessResult -> Bool) -> IO ProcessResult -> IO 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
notifyExtension ::
ActiveExtension ->
Ptr FgnMsg ->
IO Bool
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 FunPtr ProcessMessage -> FunPtr ProcessMessage -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessMessage
forall a. FunPtr a
nullFunPtr
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else (ProcessResult
passMessage ProcessResult -> ProcessResult -> Bool
forall a. Eq a => a -> a -> Bool
==) (ProcessResult -> Bool) -> IO ProcessResult -> IO 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
commandExtension ::
Text ->
ActiveExtension ->
IO ()
commandExtension :: Text -> ActiveExtension -> IO ()
commandExtension Text
command ActiveExtension
ae = NestedIO () -> IO ()
forall a. NestedIO a -> IO a
evalNestedIO (NestedIO () -> IO ()) -> NestedIO () -> IO ()
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)
IO () -> NestedIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> NestedIO ()) -> IO () -> NestedIO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FunPtr ProcessCommand
f FunPtr ProcessCommand -> FunPtr ProcessCommand -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessCommand
forall a. FunPtr a
nullFunPtr)
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Dynamic ProcessCommand
runProcessCommand FunPtr ProcessCommand
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnCmd
cmd
threadFinish :: ThreadEntry -> IO ()
threadFinish :: ThreadEntry -> IO ()
threadFinish (ThreadEntry FunPtr StopExtension
f Ptr ()
x) = Dynamic StopExtension
runThreadFinish FunPtr StopExtension
f Ptr ()
x
withRawIrcMsg ::
Text ->
RawIrcMsg ->
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 (Text -> NestedIO FgnStringLen) -> Text -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ Text -> (UserInfo -> Text) -> Maybe UserInfo -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty (Identifier -> Text
idText(Identifier -> Text)
-> (UserInfo -> Identifier) -> UserInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.UserInfo -> Identifier
userNick) Maybe UserInfo
_msgPrefix
FgnStringLen
pfxU <- Text -> NestedIO FgnStringLen
withText (Text -> NestedIO FgnStringLen) -> Text -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ Text -> (UserInfo -> Text) -> Maybe UserInfo -> Text
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 (Text -> NestedIO FgnStringLen) -> Text -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ Text -> (UserInfo -> Text) -> Maybe UserInfo -> Text
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 <- (Text -> NestedIO FgnStringLen)
-> [Text] -> NestedIO [FgnStringLen]
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 <- (TagEntry -> NestedIO (FgnStringLen, FgnStringLen))
-> [TagEntry] -> NestedIO [(FgnStringLen, FgnStringLen)]
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) = [(FgnStringLen, FgnStringLen)] -> ([FgnStringLen], [FgnStringLen])
forall a b. [(a, b)] -> ([a], [b])
unzip [(FgnStringLen, FgnStringLen)]
tags
(Int
tagN,Ptr FgnStringLen
keysPtr) <- (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 ((forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen))
-> (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (a -> b) -> a -> b
$ [FgnStringLen] -> (Int -> Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [FgnStringLen]
keys
Ptr FgnStringLen
valsPtr <- (forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen))
-> (forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen)
forall a b. (a -> b) -> a -> b
$ [FgnStringLen] -> (Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [FgnStringLen]
vals
(Int
prmN,Ptr FgnStringLen
prmPtr) <- (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 ((forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen))
-> (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (a -> b) -> a -> b
$ [FgnStringLen] -> (Int -> Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [FgnStringLen]
prms
(forall r. (Ptr FgnMsg -> IO r) -> IO r) -> NestedIO (Ptr FgnMsg)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnMsg -> IO r) -> IO r) -> NestedIO (Ptr FgnMsg))
-> (forall r. (Ptr FgnMsg -> IO r) -> IO r)
-> NestedIO (Ptr FgnMsg)
forall a b. (a -> b) -> a -> b
$ FgnMsg -> (Ptr FgnMsg -> IO r) -> IO r
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (FgnMsg -> (Ptr FgnMsg -> IO r) -> IO r)
-> FgnMsg -> (Ptr FgnMsg -> IO r) -> IO r
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 (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prmN)
Ptr FgnStringLen
keysPtr Ptr FgnStringLen
valsPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tagN)
withChat ::
Text ->
Text ->
Text ->
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 r. (Ptr FgnChat -> IO r) -> IO r) -> NestedIO (Ptr FgnChat)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnChat -> IO r) -> IO r)
-> NestedIO (Ptr FgnChat))
-> (forall r. (Ptr FgnChat -> IO r) -> IO r)
-> NestedIO (Ptr FgnChat)
forall a b. (a -> b) -> a -> b
$ FgnChat -> (Ptr FgnChat -> IO r) -> IO r
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (FgnChat -> (Ptr FgnChat -> IO r) -> IO r)
-> FgnChat -> (Ptr FgnChat -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ FgnStringLen -> FgnStringLen -> FgnStringLen -> FgnChat
FgnChat FgnStringLen
net' FgnStringLen
tgt' FgnStringLen
msg'
withCommand ::
Text ->
NestedIO (Ptr FgnCmd)
withCommand :: Text -> NestedIO (Ptr FgnCmd)
withCommand Text
command =
do FgnStringLen
cmd <- Text -> NestedIO FgnStringLen
withText Text
command
(forall r. (Ptr FgnCmd -> IO r) -> IO r) -> NestedIO (Ptr FgnCmd)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnCmd -> IO r) -> IO r) -> NestedIO (Ptr FgnCmd))
-> (forall r. (Ptr FgnCmd -> IO r) -> IO r)
-> NestedIO (Ptr FgnCmd)
forall a b. (a -> b) -> a -> b
$ FgnCmd -> (Ptr FgnCmd -> IO r) -> IO r
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (FgnCmd -> (Ptr FgnCmd -> IO r) -> IO r)
-> FgnCmd -> (Ptr FgnCmd -> IO r) -> IO r
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
(FgnStringLen, FgnStringLen)
-> NestedIO (FgnStringLen, FgnStringLen)
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 r. ((CString, Int) -> IO r) -> IO r)
-> NestedIO (CString, Int)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. ((CString, Int) -> IO r) -> IO r)
-> NestedIO (CString, Int))
-> (forall r. ((CString, Int) -> IO r) -> IO r)
-> NestedIO (CString, Int)
forall a b. (a -> b) -> a -> b
$ Text -> ((CString, Int) -> IO r) -> IO r
forall a. Text -> ((CString, Int) -> IO a) -> IO a
withText0 Text
txt
FgnStringLen -> NestedIO FgnStringLen
forall (m :: * -> *) a. Monad m => a -> m a
return (FgnStringLen -> NestedIO FgnStringLen)
-> FgnStringLen -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ CString -> CSize -> FgnStringLen
FgnStringLen CString
ptr (CSize -> FgnStringLen) -> CSize -> FgnStringLen
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
newtype NestedIO a = NestedIO (Codensity IO a)
deriving (a -> NestedIO b -> NestedIO a
(a -> b) -> NestedIO a -> NestedIO b
(forall a b. (a -> b) -> NestedIO a -> NestedIO b)
-> (forall a b. a -> NestedIO b -> NestedIO a) -> Functor NestedIO
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
<$ :: a -> NestedIO b -> NestedIO a
$c<$ :: forall a b. a -> NestedIO b -> NestedIO a
fmap :: (a -> b) -> NestedIO a -> NestedIO b
$cfmap :: forall a b. (a -> b) -> NestedIO a -> NestedIO b
Functor, Functor NestedIO
a -> NestedIO a
Functor NestedIO
-> (forall a. a -> NestedIO a)
-> (forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b)
-> (forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c)
-> (forall a b. NestedIO a -> NestedIO b -> NestedIO b)
-> (forall a b. NestedIO a -> NestedIO b -> NestedIO a)
-> Applicative NestedIO
NestedIO a -> NestedIO b -> NestedIO b
NestedIO a -> NestedIO b -> NestedIO a
NestedIO (a -> b) -> NestedIO a -> NestedIO b
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
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
<* :: NestedIO a -> NestedIO b -> NestedIO a
$c<* :: forall a b. NestedIO a -> NestedIO b -> NestedIO a
*> :: NestedIO a -> NestedIO b -> NestedIO b
$c*> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
liftA2 :: (a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
<*> :: NestedIO (a -> b) -> NestedIO a -> NestedIO b
$c<*> :: forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b
pure :: a -> NestedIO a
$cpure :: forall a. a -> NestedIO a
$cp1Applicative :: Functor NestedIO
Applicative, Applicative NestedIO
a -> NestedIO a
Applicative NestedIO
-> (forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b)
-> (forall a b. NestedIO a -> NestedIO b -> NestedIO b)
-> (forall a. a -> NestedIO a)
-> Monad NestedIO
NestedIO a -> (a -> NestedIO b) -> NestedIO b
NestedIO a -> NestedIO b -> NestedIO b
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 :: a -> NestedIO a
$creturn :: forall a. a -> NestedIO a
>> :: NestedIO a -> NestedIO b -> NestedIO b
$c>> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
>>= :: NestedIO a -> (a -> NestedIO b) -> NestedIO b
$c>>= :: forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b
$cp1Monad :: Applicative NestedIO
Monad, Monad NestedIO
Monad NestedIO
-> (forall a. IO a -> NestedIO a) -> MonadIO NestedIO
IO a -> NestedIO a
forall a. IO a -> NestedIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> NestedIO a
$cliftIO :: forall a. IO a -> NestedIO a
$cp1MonadIO :: Monad NestedIO
MonadIO)
evalNestedIO :: NestedIO a -> IO a
evalNestedIO :: NestedIO a -> IO a
evalNestedIO (NestedIO Codensity IO a
m) = Codensity IO a -> IO a
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Codensity IO a
m
nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall r. (a -> IO r) -> IO r
f = Codensity IO a -> NestedIO a
forall a. Codensity IO a -> NestedIO a
NestedIO ((forall r. (a -> IO r) -> IO r) -> Codensity IO a
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)
nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a,b)
nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 forall r. (a -> b -> IO r) -> IO r
f = Codensity IO (a, b) -> NestedIO (a, b)
forall a. Codensity IO a -> NestedIO a
NestedIO ((forall b. ((a, b) -> IO b) -> IO b) -> Codensity IO (a, b)
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((a -> b -> IO b) -> IO b
forall r. (a -> b -> IO r) -> IO r
f ((a -> b -> IO b) -> IO b)
-> (((a, b) -> IO b) -> a -> b -> IO b) -> ((a, b) -> IO b) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> IO b) -> a -> b -> IO b
forall a b c. ((a, b) -> c) -> a -> b -> c
curry))