cli/Hcompta/Lib/Control/Monad/Classes.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE StandaloneDeriving #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# OPTIONS_GHC -fno-warn-tabs #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.Lib.Control.Monad.Classes where
   7
   8 import Control.Monad (Monad(..))
   9 import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
  10 import qualified Control.Monad.Classes.Proxied as MC
  11 import qualified Control.Monad.Classes.Run as MC
  12 import Data.Function (($))
  13
  14 -- * Type @Control.Monad.Classes.Writer.@'CustromWriterT' (orphan instances)
  15
  16 -- | Type synonym to @Control.Monad.Classes.Writer.@'MC.CustomWriterT'', /eta-reduced/.
  17 type WriterT w m = MC.CustomWriterT' w m m
  18 deriving instance (Monad m, MonadThrow m) => MonadThrow (WriterT w m)
  19 deriving instance (Monad m, MonadCatch m) => MonadCatch (WriterT w m)
  20 deriving instance (Monad m, MonadMask  m) => MonadMask  (WriterT w m)
  21
  22 -- * Type @Control.Monad.Classes.Proxied.@'MC.Proxied' (orphan instances)
  23
  24 instance MonadThrow m => MonadThrow (MC.Proxied x m) where
  25         -- throwM :: Exception e => e -> m a
  26         throwM e = MC.Proxied (\_px -> throwM e)
  27
  28 instance MonadCatch m => MonadCatch (MC.Proxied x m) where
  29         -- catch :: Exception e => m a -> (e -> m a) -> m a
  30         catch (MC.Proxied f) h =
  31                 MC.Proxied $ \px ->
  32                         f px `catch` \e ->
  33                                 case h e of
  34                                  MC.Proxied f' -> f' px
  35
  36 -- newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a)
  37 instance (MonadCatch m, MonadMask m) => MonadMask (MC.Proxied x m) where
  38         -- mask :: MonadMask m => ((forall a. m a -> m a) -> m b) -> m b
  39         mask restore =
  40                 MC.Proxied $ \px ->
  41                         mask $ \r ->
  42                                 case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
  43                                  MC.Proxied f -> f px
  44         -- uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
  45         uninterruptibleMask restore =
  46                 MC.Proxied $ \px ->
  47                         uninterruptibleMask $ \r ->
  48                                 case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
  49                                  MC.Proxied f -> f px