]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/Lib/Control/Monad/Classes.hs
Adapte hcompta-cli.
[comptalang.git] / 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