From 74ea6dfa744b3b7a03ac92209325cf6f8c800c87 Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Fri, 7 May 2021 14:02:39 +0800
Subject: [PATCH 1/3] Add MonadIRC

---
 Network/IRC/Client.hs                |  5 +--
 Network/IRC/Client/Events.hs         |  9 +++---
 Network/IRC/Client/Internal.hs       | 28 +++++++----------
 Network/IRC/Client/Internal/Types.hs | 47 ++++++++++++++++++++++------
 Network/IRC/Client/Lens.hs           | 21 +++++++------
 Network/IRC/Client/Utils.hs          | 18 +++++------
 6 files changed, 77 insertions(+), 51 deletions(-)

diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs
index abae449..e4be6de 100644
--- a/Network/IRC/Client.hs
+++ b/Network/IRC/Client.hs
@@ -185,6 +185,7 @@ import           Network.IRC.Client.Lens
 import           Network.IRC.Client.Utils       hiding (fork)
 import qualified Network.IRC.Client.Utils       as U
 
+import           Control.Monad.Catch            (MonadThrow)
 import qualified Paths_irc_client               as Paths
 
 
@@ -260,7 +261,7 @@ defaultInstanceConfig n = InstanceConfig
 
 -- | Connect to the IRC server and run the client: receiving messages
 -- and handing them off to handlers as appropriate.
-runClient :: MonadIO m
+runClient :: (MonadIO m, MonadThrow m)
   => ConnectionConfig s
   -> InstanceConfig s
   -> s
@@ -274,7 +275,7 @@ runClient cconf iconf ustate = newIRCState cconf iconf ustate >>= runClientWith
 -- Multiple clients should not be run with the same 'IRCState'. The
 -- utility of this is to be able to run @IRC s a@ actions in order to
 -- interact with the client from the outside.
-runClientWith :: MonadIO m => IRCState s -> m ()
+runClientWith :: (MonadIO m, MonadThrow m) => IRCState s -> m ()
 runClientWith = runIRCAction runner
 
 
diff --git a/Network/IRC/Client/Events.hs b/Network/IRC/Client/Events.hs
index 19e15b8..4cbd9d0 100644
--- a/Network/IRC/Client/Events.hs
+++ b/Network/IRC/Client/Events.hs
@@ -44,14 +44,13 @@ module Network.IRC.Client.Events
   , module Network.IRC.Conduit.Lens
   ) where
 
-import           Control.Applicative         ((<$>), (<|>))
+import           Control.Applicative         ((<|>))
 import           Control.Concurrent.STM      (atomically, modifyTVar, readTVar)
-import           Control.Monad.Catch         (SomeException, fromException,
+import           Control.Monad.Catch         (fromException,
                                               throwM)
 import           Control.Monad.IO.Class      (liftIO)
 import           Data.Char                   (isAlphaNum)
 import           Data.Maybe                  (fromMaybe)
-import           Data.Monoid                 ((<>))
 import           Data.Text                   (Text, breakOn, takeEnd, toUpper)
 import           Data.Time.Clock             (getCurrentTime)
 import           Data.Time.Format            (formatTime)
@@ -168,7 +167,7 @@ defaultEventHandlers =
   ]
 
 -- | The default connect handler: set the nick.
-defaultOnConnect :: IRC s ()
+defaultOnConnect :: ConnectHandler s
 defaultOnConnect = do
   iconf <- snapshot instanceConfig =<< getIRCState
   send . Nick $ get nick iconf
@@ -180,7 +179,7 @@ defaultOnConnect = do
 --    - If the client disconnected due to another exception, rethrow it.
 --
 --    - If the client disconnected without an exception, halt.
-defaultOnDisconnect :: Maybe SomeException -> IRC s ()
+defaultOnDisconnect :: DisconnectHandler s
 defaultOnDisconnect (Just exc) = case fromException exc of
   Just Timeout -> reconnect
   Nothing -> throwM exc
diff --git a/Network/IRC/Client/Internal.hs b/Network/IRC/Client/Internal.hs
index 24ea553..2178916 100644
--- a/Network/IRC/Client/Internal.hs
+++ b/Network/IRC/Client/Internal.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 
 -- |
 -- Module      : Network.IRC.Client.Internal
@@ -22,7 +23,6 @@ module Network.IRC.Client.Internal
   , module Network.IRC.Client.Internal.Types
   ) where
 
-import           Control.Applicative               ((<$>))
 import           Control.Concurrent                (forkIO, killThread,
                                                     myThreadId, threadDelay,
                                                     throwTo)
@@ -33,9 +33,9 @@ import           Control.Concurrent.STM.TBMChan    (TBMChan, closeTBMChan,
                                                     isEmptyTBMChan, newTBMChan,
                                                     readTBMChan, writeTBMChan)
 import           Control.Monad                     (forM_, unless, void, when)
-import           Control.Monad.Catch               (SomeException, catch)
+import           Control.Monad.Catch               (SomeException, catch, MonadThrow)
 import           Control.Monad.IO.Class            (MonadIO, liftIO)
-import           Control.Monad.Reader              (ask, runReaderT)
+import           Control.Monad.Reader              (runReaderT)
 import           Data.ByteString                   (ByteString, isPrefixOf)
 import           Data.Conduit                      (ConduitM, await,
                                                     awaitForever, yield, (.|))
@@ -72,9 +72,9 @@ import           Network.IRC.Client.Lens
 setupInternal
   :: (IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ())
   -- ^ Function to start the network conduits.
-  -> IRC s ()
+  -> ConnectHandler s
   -- ^ Connect handler
-  -> (Maybe SomeException -> IRC s ())
+  -> DisconnectHandler s
   -- ^ Disconnect handler
   -> (Origin -> ByteString -> IO ())
   -- ^ Logging function
@@ -102,7 +102,7 @@ setupInternal f oncon ondis logf host port_ = ConnectionConfig
 -- * Event loop
 
 -- | The event loop.
-runner :: IRC s ()
+runner :: MonadIRC s m => m ()
 runner = do
   state <- getIRCState
   let cconf = _connectionConfig state
@@ -243,12 +243,12 @@ concealPass m = m
 
 -- | Send a message as UTF-8, using TLS if enabled. This blocks if
 -- messages are sent too rapidly.
-send :: Message Text -> IRC s ()
+send :: MonadIRC s m => Message Text -> m ()
 send = sendBS . fmap encodeUtf8
 
 -- | Send a message, using TLS if enabled. This blocks if messages are
 -- sent too rapidly.
-sendBS :: Message ByteString -> IRC s ()
+sendBS :: MonadIRC s m => Message ByteString -> m ()
 sendBS msg = do
   qv <- _sendqueue <$> getIRCState
   liftIO . atomically $ flip writeTBMChan msg =<< readTVar qv
@@ -259,7 +259,7 @@ sendBS msg = do
 
 -- | Disconnect from the server, properly tearing down the TLS session
 -- (if there is one).
-disconnect :: IRC s ()
+disconnect :: MonadIRC s m => m ()
 disconnect = do
   s <- getIRCState
 
@@ -298,7 +298,7 @@ disconnect = do
 --
 -- Like 'runClient' and 'runClientWith', this will not return until
 -- the client terminates (ie, disconnects without reconnecting).
-reconnect :: IRC s ()
+reconnect :: MonadIRC s m => m ()
 reconnect = do
   disconnect
 
@@ -314,12 +314,8 @@ reconnect = do
 -- * Utils
 
 -- | Interact with a client from the outside, by using its 'IRCState'.
-runIRCAction :: MonadIO m => IRC s a -> IRCState s -> m a
-runIRCAction ma = liftIO . runReaderT (runIRC ma)
-
--- | Access the client state.
-getIRCState :: IRC s (IRCState s)
-getIRCState = ask
+runIRCAction :: (MonadIO m, MonadThrow m) => IRCT s m a -> IRCState s -> m a
+runIRCAction ma = runReaderT (runIRCT ma)
 
 -- | Get the connection state from an IRC state.
 getConnectionState :: IRCState s -> STM ConnectionState
diff --git a/Network/IRC/Client/Internal/Types.hs b/Network/IRC/Client/Internal/Types.hs
index 73fbf14..d871d57 100644
--- a/Network/IRC/Client/Internal/Types.hs
+++ b/Network/IRC/Client/Internal/Types.hs
@@ -1,7 +1,11 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE RankNTypes #-}
 
 -- |
 -- Module      : Network.IRC.Client.Internal.Types
@@ -26,9 +30,9 @@ import           Control.Monad                  (MonadPlus)
 import           Control.Monad.Catch            (Exception, MonadCatch,
                                                  MonadMask, MonadThrow,
                                                  SomeException)
-import           Control.Monad.IO.Class         (MonadIO, liftIO)
-import           Control.Monad.Reader           (MonadReader, ReaderT, asks)
+import           Control.Monad.Reader           (MonadReader, ReaderT, ask)
 import           Control.Monad.State            (MonadState(..))
+import           Control.Monad.Trans
 import           Data.ByteString                (ByteString)
 import           Data.Conduit                   (ConduitM)
 import qualified Data.Set                       as S
@@ -42,21 +46,38 @@ import           Network.IRC.Conduit            (Event(..), Message, Source)
 -- * The IRC monad
 
 -- | The IRC monad.
-newtype IRC s a = IRC { runIRC :: ReaderT (IRCState s) IO a }
+type IRC s a = IRCT s IO a
+
+-- | The IRC monad transformer
+newtype IRCT s m a = IRCT { runIRCT :: ReaderT (IRCState s) m a }
   deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader (IRCState s), MonadThrow, MonadCatch, MonadMask)
 
-instance MonadState s (IRC s) where
+instance MonadTrans (IRCT s) where
+  lift = IRCT . lift
+
+-- | mtl style class for IRC monad
+class (MonadIO m, MonadThrow m) => MonadIRC s m | m -> s where
+  -- | Access the client state.
+  getIRCState :: m (IRCState s)
+
+instance (MonadIO m, MonadThrow m) => MonadIRC s (IRCT s m) where
+  getIRCState = ask
+
+-- | Add MonadState instances for each MonadIRC monad
+--
+-- This enables orphan instances
+instance (Monad m, MonadIRC s m) => MonadState s m where
   state f = do
-    tvar <- asks _userState
+    tvar <- _userState <$> getIRCState
     liftIO . atomically $ do
       (a, s) <- f <$> readTVar tvar
       writeTVar tvar s
       pure a
   get = do
-    tvar <- asks _userState
+    tvar <- _userState <$> getIRCState
     liftIO $ readTVarIO tvar
   put s = do
-    tvar <- asks _userState
+    tvar <- _userState <$> getIRCState
     liftIO $ atomically (writeTVar tvar s)
 
 -------------------------------------------------------------------------------
@@ -78,6 +99,12 @@ data IRCState s = IRCState
   -- ^ Threads which will be killed when the client disconnects.
   }
 
+-- | On connect handler in 'ConnectionConfig'
+type ConnectHandler s = forall m. MonadIRC s m => m ()
+
+-- | On disconnect handler in 'ConnectionConfig'
+type DisconnectHandler s = forall m. MonadIRC s m => Maybe SomeException -> m ()
+
 -- | The static state of an IRC server connection.
 data ConnectionConfig s = ConnectionConfig
   { _func       :: IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ()
@@ -98,10 +125,10 @@ data ConnectionConfig s = ConnectionConfig
   -- ^ The maximum time (in seconds) between received messages from
   -- the server. If no messages arrive from the server for this
   -- period, the client is sent a 'Timeout' exception and disconnects.
-  , _onconnect  :: IRC s ()
+  , _onconnect  :: ConnectHandler s
   -- ^ Action to run after sending the @PASS@ and @USER@ commands to the
   -- server. The default behaviour is to send the @NICK@ command.
-  , _ondisconnect :: Maybe SomeException -> IRC s ()
+  , _ondisconnect :: DisconnectHandler s
   -- ^ Action to run after disconnecting from the server, both by
   -- local choice and by losing the connection. This is run after
   -- tearing down the connection. If the connection terminated due to
@@ -146,7 +173,7 @@ data Origin = FromServer | FromClient
 data EventHandler s where
   EventHandler
     :: (Event Text -> Maybe b)
-    -> (Source Text -> b -> IRC s ())
+    -> (forall m. MonadIRC s m => Source Text -> b -> m ())
     -> EventHandler s
 
 
diff --git a/Network/IRC/Client/Lens.hs b/Network/IRC/Client/Lens.hs
index 0afc3f5..3479316 100644
--- a/Network/IRC/Client/Lens.hs
+++ b/Network/IRC/Client/Lens.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
 -- |
 -- Module      : Network.IRC.Client.Lens
 -- Copyright   : (c) 2017 Michael Walker
@@ -10,7 +12,6 @@
 module Network.IRC.Client.Lens where
 
 import           Control.Concurrent.STM            (TVar)
-import           Control.Monad.Catch               (SomeException)
 import           Data.ByteString                   (ByteString)
 import           Data.Profunctor                   (Choice(right'),
                                                     Profunctor(dimap))
@@ -109,15 +110,17 @@ flood = \ afb s -> (\ b -> s {_flood = b}) <$> afb (_flood s)
 timeout :: Lens' (ConnectionConfig s) NominalDiffTime
 timeout = \ afb s -> (\ b -> s {_timeout = b}) <$> afb (_timeout s)
 
-{-# INLINE onconnect #-}
-{-| 'Lens' for '_onconnect'. -}
-onconnect :: Lens' (ConnectionConfig s) (IRC s ())
-onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s)
+-- TODO: polymorphic functions are not first-class before GHC 9.2
+
+-- {-# INLINE onconnect #-}
+-- {-| 'Lens' for '_onconnect'. -}
+-- onconnect :: Lens' (ConnectionConfig s) (ConnectHandler s)
+-- onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s)
 
-{-# INLINE ondisconnect #-}
-{-| 'Lens' for '_ondisconnect'. -}
-ondisconnect :: Lens' (ConnectionConfig s) (Maybe SomeException -> IRC s ())
-ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s)
+-- {-# INLINE ondisconnect #-}
+-- {-| 'Lens' for '_ondisconnect'. -}
+-- ondisconnect :: Lens' (ConnectionConfig s) (DisconnectHandler s)
+-- ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s)
 
 {-# INLINE logfunc #-}
 {-| 'Lens' for '_logfunc'. -}
diff --git a/Network/IRC/Client/Utils.hs b/Network/IRC/Client/Utils.hs
index 2939a66..aa0d2c4 100644
--- a/Network/IRC/Client/Utils.hs
+++ b/Network/IRC/Client/Utils.hs
@@ -60,7 +60,7 @@ import           Network.IRC.Client.Lens
 -- | Update the nick in the instance configuration and also send an
 -- update message to the server. This doesn't attempt to resolve nick
 -- collisions, that's up to the event handlers.
-setNick :: Text -> IRC s ()
+setNick :: MonadIRC s m => Text -> m ()
 setNick new = do
   tvarI <- get instanceConfig <$> getIRCState
   liftIO . atomically $
@@ -73,7 +73,7 @@ setNick new = do
 
 -- | Update the channel list in the instance configuration and also
 -- part the channel.
-leaveChannel :: Text -> Maybe Text -> IRC s ()
+leaveChannel :: MonadIRC s m => Text -> Maybe Text -> m ()
 leaveChannel chan reason = do
   tvarI <- get instanceConfig <$> getIRCState
   liftIO . atomically $ delChan tvarI chan
@@ -91,18 +91,18 @@ delChan tvarI chan =
 -- Events
 
 -- | Add an event handler
-addHandler :: EventHandler s -> IRC s ()
+addHandler :: MonadIRC s m => EventHandler s -> m ()
 addHandler handler = do
   tvarI <- get instanceConfig <$> getIRCState
   liftIO . atomically $
     modifyTVar tvarI (modify handlers (handler:))
 
 -- | Send a message to the source of an event.
-reply :: Event Text -> Text -> IRC s ()
+reply :: MonadIRC s m => Event Text -> Text -> m ()
 reply = replyTo . _source
 
 -- | Send a message to the source of an event.
-replyTo :: Source Text -> Text -> IRC s ()
+replyTo :: MonadIRC s m => Source Text -> Text -> m ()
 replyTo (Channel c _) = mapM_ (send . Privmsg c . Right) . T.lines
 replyTo (User n)      = mapM_ (send . Privmsg n . Right) . T.lines
 replyTo _ = const $ pure ()
@@ -124,19 +124,19 @@ ctcpReply t command args = Notice t . Left $ toCTCP command args
 -- Connection state
 
 -- | Check if the client is connected.
-isConnected :: IRC s Bool
+isConnected :: MonadIRC s m => m Bool
 isConnected = (==Connected) <$> snapConnState
 
 -- | Check if the client is in the process of disconnecting.
-isDisconnecting :: IRC s Bool
+isDisconnecting :: MonadIRC s m => m Bool
 isDisconnecting = (==Disconnecting) <$> snapConnState
 
 -- | Check if the client is disconnected
-isDisconnected :: IRC s Bool
+isDisconnected :: MonadIRC s m => m Bool
 isDisconnected = (==Disconnected) <$> snapConnState
 
 -- | Snapshot the connection state.
-snapConnState :: IRC s ConnectionState
+snapConnState :: MonadIRC s m => m ConnectionState
 snapConnState = liftIO . atomically . getConnectionState =<< getIRCState
 
 

From a2b4fd43c32c022b7541dba4ba2a280fc27ac6ed Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Fri, 7 May 2021 18:42:10 +0800
Subject: [PATCH 2/3] Recover lenses of connect handlers

---
 Network/IRC/Client/Events.hs         | 11 ++++++-----
 Network/IRC/Client/Internal.hs       |  4 ++--
 Network/IRC/Client/Internal/Types.hs |  8 ++++++--
 Network/IRC/Client/Lens.hs           | 20 +++++++++-----------
 4 files changed, 23 insertions(+), 20 deletions(-)

diff --git a/Network/IRC/Client/Events.hs b/Network/IRC/Client/Events.hs
index 4cbd9d0..273ec62 100644
--- a/Network/IRC/Client/Events.hs
+++ b/Network/IRC/Client/Events.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -46,8 +47,7 @@ module Network.IRC.Client.Events
 
 import           Control.Applicative         ((<|>))
 import           Control.Concurrent.STM      (atomically, modifyTVar, readTVar)
-import           Control.Monad.Catch         (fromException,
-                                              throwM)
+import           Control.Monad.Catch         (fromException, throwM)
 import           Control.Monad.IO.Class      (liftIO)
 import           Data.Char                   (isAlphaNum)
 import           Data.Maybe                  (fromMaybe)
@@ -168,7 +168,7 @@ defaultEventHandlers =
 
 -- | The default connect handler: set the nick.
 defaultOnConnect :: ConnectHandler s
-defaultOnConnect = do
+defaultOnConnect = ConnectHandler $ do
   iconf <- snapshot instanceConfig =<< getIRCState
   send . Nick $ get nick iconf
 
@@ -180,10 +180,11 @@ defaultOnConnect = do
 --
 --    - If the client disconnected without an exception, halt.
 defaultOnDisconnect :: DisconnectHandler s
-defaultOnDisconnect (Just exc) = case fromException exc of
+defaultOnDisconnect = DisconnectHandler $ \case
+ (Just exc) -> case fromException exc of
   Just Timeout -> reconnect
   Nothing -> throwM exc
-defaultOnDisconnect Nothing = pure ()
+ Nothing -> pure ()
 
 
 -------------------------------------------------------------------------------
diff --git a/Network/IRC/Client/Internal.hs b/Network/IRC/Client/Internal.hs
index 2178916..efb3058 100644
--- a/Network/IRC/Client/Internal.hs
+++ b/Network/IRC/Client/Internal.hs
@@ -117,7 +117,7 @@ runner = do
         liftIO . atomically $ writeTVar (_connectionState state) Connected
         mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) thePass
         sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal]
-        _onconnect cconf
+        runConnectHandler $ _onconnect cconf
 
   -- Run the event loop, and call the disconnect handler if the remote
   -- end closes the socket.
@@ -153,7 +153,7 @@ runner = do
     (pure . Just)
 
   disconnect
-  _ondisconnect cconf exc
+  runDisconnectHandler (_ondisconnect cconf) exc
 
 -- | Forget failed decodings.
 forgetful :: Monad m => ConduitM (Either a b) b m ()
diff --git a/Network/IRC/Client/Internal/Types.hs b/Network/IRC/Client/Internal/Types.hs
index d871d57..0153f16 100644
--- a/Network/IRC/Client/Internal/Types.hs
+++ b/Network/IRC/Client/Internal/Types.hs
@@ -100,10 +100,14 @@ data IRCState s = IRCState
   }
 
 -- | On connect handler in 'ConnectionConfig'
-type ConnectHandler s = forall m. MonadIRC s m => m ()
+--
+-- GHC does not support impredicative types, so we need wrap forall into a newtype.
+newtype ConnectHandler s = ConnectHandler { runConnectHandler :: forall m. MonadIRC s m => m () }
 
 -- | On disconnect handler in 'ConnectionConfig'
-type DisconnectHandler s = forall m. MonadIRC s m => Maybe SomeException -> m ()
+--
+-- GHC does not support impredicative types, so we need wrap forall into a newtype.
+newtype DisconnectHandler s = DisconnectHandler { runDisconnectHandler :: forall m. MonadIRC s m => Maybe SomeException -> m () }
 
 -- | The static state of an IRC server connection.
 data ConnectionConfig s = ConnectionConfig
diff --git a/Network/IRC/Client/Lens.hs b/Network/IRC/Client/Lens.hs
index 3479316..0234066 100644
--- a/Network/IRC/Client/Lens.hs
+++ b/Network/IRC/Client/Lens.hs
@@ -110,17 +110,15 @@ flood = \ afb s -> (\ b -> s {_flood = b}) <$> afb (_flood s)
 timeout :: Lens' (ConnectionConfig s) NominalDiffTime
 timeout = \ afb s -> (\ b -> s {_timeout = b}) <$> afb (_timeout s)
 
--- TODO: polymorphic functions are not first-class before GHC 9.2
-
--- {-# INLINE onconnect #-}
--- {-| 'Lens' for '_onconnect'. -}
--- onconnect :: Lens' (ConnectionConfig s) (ConnectHandler s)
--- onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s)
-
--- {-# INLINE ondisconnect #-}
--- {-| 'Lens' for '_ondisconnect'. -}
--- ondisconnect :: Lens' (ConnectionConfig s) (DisconnectHandler s)
--- ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s)
+{-# INLINE onconnect #-}
+{-| 'Lens' for '_onconnect'. -}
+onconnect :: Lens' (ConnectionConfig s) (ConnectHandler s)
+onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s)
+
+{-# INLINE ondisconnect #-}
+{-| 'Lens' for '_ondisconnect'. -}
+ondisconnect :: Lens' (ConnectionConfig s) (DisconnectHandler s)
+ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s)
 
 {-# INLINE logfunc #-}
 {-| 'Lens' for '_logfunc'. -}

From 32b9097d267fb9eff4f1360cf54804d14f2b04e3 Mon Sep 17 00:00:00 2001
From: Potato Hatsue <1793913507@qq.com>
Date: Fri, 7 May 2021 19:10:41 +0800
Subject: [PATCH 3/3] Add forkUnliftIO

---
 Network/IRC/Client/Utils.hs | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/Network/IRC/Client/Utils.hs b/Network/IRC/Client/Utils.hs
index aa0d2c4..f4872aa 100644
--- a/Network/IRC/Client/Utils.hs
+++ b/Network/IRC/Client/Utils.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
 -- |
 -- Module      : Network.IRC.Client.Utils
 -- Copyright   : (c) 2016 Michael Walker
@@ -32,6 +34,7 @@ module Network.IRC.Client.Utils
 
     -- * Concurrency
   , fork
+  , forkUnliftIO
 
     -- * Lenses
   , snapshot
@@ -43,7 +46,7 @@ module Network.IRC.Client.Utils
 
 import           Control.Concurrent          (ThreadId, forkFinally, myThreadId)
 import           Control.Concurrent.STM      (STM, TVar, atomically, modifyTVar)
-import           Control.Monad.IO.Class      (liftIO)
+import           Control.Monad.IO.Class      (MonadIO, liftIO)
 import qualified Data.Set                    as S
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
@@ -51,6 +54,7 @@ import           Network.IRC.CTCP            (toCTCP)
 import           Network.IRC.Conduit         (Event(..), Message(..),
                                               Source(..))
 
+import           Control.Monad.Catch         (MonadThrow)
 import           Network.IRC.Client.Internal
 import           Network.IRC.Client.Lens
 
@@ -146,10 +150,14 @@ snapConnState = liftIO . atomically . getConnectionState =<< getIRCState
 -- | Fork a thread which will be thrown a 'Disconnect' exception when
 -- the client disconnects.
 fork :: IRC s () -> IRC s ThreadId
-fork ma = do
+fork = forkUnliftIO id
+
+-- | A more general version of 'fork', which accepts 'IRCT'. The underlaying monad should have the ability to be run as IO.
+forkUnliftIO :: (MonadIO m, MonadThrow m) => (forall a. m a -> IO a) -> IRCT s m () -> IRCT s m ThreadId
+forkUnliftIO unliftIO ma = do
   s <- getIRCState
   liftIO $ do
-    tid <- forkFinally (runIRCAction ma s) $ \_ -> do
+    tid <- forkFinally (unliftIO $ runIRCAction ma s) $ \_ -> do
       tid <- myThreadId
       atomically $ modifyTVar (_runningThreads s) (S.delete tid)
     atomically $ modifyTVar (_runningThreads s) (S.insert tid)