Simplify HandlerM

Remove `HandlerM` from `MonadCatch` class; One can use `HandlerM` directly, without `mkHandler`.
IntersectMBO · Jun 25, 2020 · 87504e6 · 87504e6
1 parent 2cf9686
commit 87504e6
Show file tree

Hide file tree

Showing 2 changed files with 12 additions and 25 deletions.
diff --git a/io-sim-classes/src/Control/Monad/Class/MonadThrow.hs b/io-sim-classes/src/Control/Monad/Class/MonadThrow.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE StandaloneDeriving        #-}
 {-# LANGUAGE TypeFamilies              #-}
 
 module Control.Monad.Class.MonadThrow
@@ -15,6 +16,7 @@ module Control.Monad.Class.MonadThrow
   , SomeException
   , ExitCase(..)
   , HandlerM(..)
+  , catchesM
   ) where
 
 import           Control.Exception (Exception (..), SomeException)
@@ -59,16 +61,8 @@ class MonadThrow m => MonadCatch m where
 
   {-# MINIMAL catch #-}
 
-  type Handler m :: * -> *
-
-  -- | 'Handler' smart constructor; useful when writing polymorphic
-  -- code in some moand m which satisfies 'MonadCatch' constraint.
-  --
-  mkHandler  :: Exception e => (e -> m a) -> Handler m a
-
   catch      :: Exception e => m a -> (e -> m a) -> m a
   catchJust  :: Exception e => (e -> Maybe b) -> m a -> (b -> m a) -> m a
-  catches    :: m a -> [Handler m a] -> m a
 
   try        :: Exception e => m a -> m (Either e a)
   tryJust    :: Exception e => (e -> Maybe b) -> m a -> m (Either b a)
@@ -89,16 +83,6 @@ class MonadThrow m => MonadCatch m where
                  :: MonadMask m
                  => m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
 
-  type instance Handler m = HandlerM m
-
-  default mkHandler :: forall a e. (HandlerM m a ~ Handler m a, Exception e)
-                  => (e -> m a) -> Handler m a
-  mkHandler = HandlerM
-
-  default catches :: forall a. (HandlerM m a ~ Handler m a)
-                  => m a -> [Handler m a] -> m a
-  catches ma handlers = ma `catch` catchesHandler handlers
-
   catchJust p a handler =
       catch a handler'
     where
@@ -147,6 +131,13 @@ class MonadThrow m => MonadCatch m where
 --
 data HandlerM m a = forall e. Exception e => HandlerM (e -> m a) 
 
+deriving instance (Functor m) => Functor (HandlerM m)
+
+-- | Like 'catches' but for 'MonadCatch' rather than only 'IO'.
+--
+catchesM :: forall m a. MonadCatch m
+         => m a -> [HandlerM m a] -> m a
+catchesM ma handlers = ma `catch` catchesHandler handlers
 
 -- | Used in the default 'catches' implementation.
 --
@@ -205,11 +196,7 @@ instance MonadThrow IO where
 
 instance MonadCatch IO where
 
-  type Handler IO = IO.Handler
-  mkHandler = IO.Handler
-
   catch      = IO.catch
-  catches    = IO.catches
 
   catchJust  = IO.catchJust
   try        = IO.try

diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs
@@ -100,11 +100,11 @@ dnsResolve :: forall a m s.
     -> DnsSubscriptionTarget
     -> m (SubscriptionTarget m Socket.SockAddr)
 dnsResolve tracer getSeed withResolverFn peerStatesVar beforeConnect (DnsSubscriptionTarget domain _ _) = do
-    rs_e <- (Right <$> getSeed) `catches`
-        [ mkHandler (\ (e :: DNS.DNSError) ->
+    rs_e <- (Right <$> getSeed) `catchesM`
+        [ HandlerM (\ (e :: DNS.DNSError) ->
             return (Left $ toException e) :: m (Either SomeException a))
         -- On windows getSeed fails with BadConfiguration if the network is down.
-        , mkHandler (\ (e :: IOError) ->
+        , HandlerM (\ (e :: IOError) ->
             return (Left $ toException e) :: m (Either SomeException a))
         -- On OSX getSeed can fail with IOError if all network devices are down.
         ]