{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Lib.Control.Monad.Classes where

import Control.Monad (Monad(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
import qualified Control.Monad.Classes.Proxied as MC
import qualified Control.Monad.Classes.Run as MC
import Data.Function (($))

-- * Type @Control.Monad.Classes.Writer.@'CustromWriterT' (orphan instances)

-- | Type synonym to @Control.Monad.Classes.Writer.@'MC.CustomWriterT'', /eta-reduced/.
type WriterT w m = MC.CustomWriterT' w m m
deriving instance (Monad m, MonadThrow m) => MonadThrow (WriterT w m)
deriving instance (Monad m, MonadCatch m) => MonadCatch (WriterT w m)
deriving instance (Monad m, MonadMask  m) => MonadMask  (WriterT w m)

-- * Type @Control.Monad.Classes.Proxied.@'MC.Proxied' (orphan instances)

instance MonadThrow m => MonadThrow (MC.Proxied x m) where
	-- throwM :: Exception e => e -> m a
	throwM e = MC.Proxied (\_px -> throwM e)

instance MonadCatch m => MonadCatch (MC.Proxied x m) where
	-- catch :: Exception e => m a -> (e -> m a) -> m a
	catch (MC.Proxied f) h =
		MC.Proxied $ \px ->
			f px `catch` \e ->
				case h e of
				 MC.Proxied f' -> f' px

-- newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a)
instance (MonadCatch m, MonadMask m) => MonadMask (MC.Proxied x m) where
	-- mask :: MonadMask m => ((forall a. m a -> m a) -> m b) -> m b
	mask restore =
		MC.Proxied $ \px ->
			mask $ \r ->
				case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
				 MC.Proxied f -> f px
	-- uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
	uninterruptibleMask restore =
		MC.Proxied $ \px ->
			uninterruptibleMask $ \r ->
				case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
				 MC.Proxied f -> f px