{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2023-2024 Sayo Koyoneda
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable
-}
module Control.Effect.Tag where

import Control.Applicative (Alternative)
import Control.Effect (SendFOE (sendFOE), SendHOE (sendHOE))
import Control.Effect.Key (SendFOEBy, SendHOEBy, sendFOEBy, sendHOEBy)
import Control.Monad (MonadPlus)
import Control.Monad.Except (MonadError)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.RWS (MonadRWS)
import Control.Monad.Reader (MonadReader)
import Control.Monad.State (MonadState)
import Control.Monad.Writer (MonadWriter)
import Data.Coerce (coerce)
import Data.Effect.HFunctor (HFunctor, hfmap)
import Data.Effect.Tag (pattern T, pattern TH, type (#), type (##))
import Data.Kind (Type)

-- | A wrapper data type to represent sending an effect to the carrier @f@ with the specified tag.
newtype ViaTag tag (f :: Type -> Type) a = ViaTag {forall {k} (tag :: k) (f :: * -> *) a. ViaTag tag f a -> f a
runViaTag :: f a}
    deriving newtype
        ( (forall a b. (a -> b) -> ViaTag tag f a -> ViaTag tag f b)
-> (forall a b. a -> ViaTag tag f b -> ViaTag tag f a)
-> Functor (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a b.
Functor f =>
a -> ViaTag tag f b -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *) a b.
Functor f =>
(a -> b) -> ViaTag tag f a -> ViaTag tag f b
forall a b. a -> ViaTag tag f b -> ViaTag tag f a
forall a b. (a -> b) -> ViaTag tag f a -> ViaTag tag f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (tag :: k) (f :: * -> *) a b.
Functor f =>
(a -> b) -> ViaTag tag f a -> ViaTag tag f b
fmap :: forall a b. (a -> b) -> ViaTag tag f a -> ViaTag tag f b
$c<$ :: forall k (tag :: k) (f :: * -> *) a b.
Functor f =>
a -> ViaTag tag f b -> ViaTag tag f a
<$ :: forall a b. a -> ViaTag tag f b -> ViaTag tag f a
Functor
        , Functor (ViaTag tag f)
Functor (ViaTag tag f) =>
(forall a. a -> ViaTag tag f a)
-> (forall a b.
    ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b)
-> (forall a b c.
    (a -> b -> c)
    -> ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f c)
-> (forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b)
-> (forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f a)
-> Applicative (ViaTag tag f)
forall a. a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
Applicative f =>
Functor (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a.
Applicative f =>
a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b
forall k (tag :: k) (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f c
forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f a
forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
forall a b.
ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b
forall a b c.
(a -> b -> c) -> ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall k (tag :: k) (f :: * -> *) a.
Applicative f =>
a -> ViaTag tag f a
pure :: forall a. a -> ViaTag tag f a
$c<*> :: forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b
<*> :: forall a b.
ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b
$cliftA2 :: forall k (tag :: k) (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f c
liftA2 :: forall a b c.
(a -> b -> c) -> ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f c
$c*> :: forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
*> :: forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
$c<* :: forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f a
<* :: forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f a
Applicative
        , Applicative (ViaTag tag f)
Applicative (ViaTag tag f) =>
(forall a. ViaTag tag f a)
-> (forall a. ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a)
-> (forall a. ViaTag tag f a -> ViaTag tag f [a])
-> (forall a. ViaTag tag f a -> ViaTag tag f [a])
-> Alternative (ViaTag tag f)
forall a. ViaTag tag f a
forall a. ViaTag tag f a -> ViaTag tag f [a]
forall a. ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
Alternative f =>
Applicative (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a
forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a -> ViaTag tag f [a]
forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a
empty :: forall a. ViaTag tag f a
$c<|> :: forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
<|> :: forall a. ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
$csome :: forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a -> ViaTag tag f [a]
some :: forall a. ViaTag tag f a -> ViaTag tag f [a]
$cmany :: forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a -> ViaTag tag f [a]
many :: forall a. ViaTag tag f a -> ViaTag tag f [a]
Alternative
        , Applicative (ViaTag tag f)
Applicative (ViaTag tag f) =>
(forall a b.
 ViaTag tag f a -> (a -> ViaTag tag f b) -> ViaTag tag f b)
-> (forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b)
-> (forall a. a -> ViaTag tag f a)
-> Monad (ViaTag tag f)
forall a. a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
Monad f =>
Applicative (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a. Monad f => a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *) a b.
Monad f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
forall k (tag :: k) (f :: * -> *) a b.
Monad f =>
ViaTag tag f a -> (a -> ViaTag tag f b) -> ViaTag tag f b
forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
forall a b.
ViaTag tag f a -> (a -> ViaTag tag f b) -> ViaTag tag f b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall k (tag :: k) (f :: * -> *) a b.
Monad f =>
ViaTag tag f a -> (a -> ViaTag tag f b) -> ViaTag tag f b
>>= :: forall a b.
ViaTag tag f a -> (a -> ViaTag tag f b) -> ViaTag tag f b
$c>> :: forall k (tag :: k) (f :: * -> *) a b.
Monad f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
>> :: forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
$creturn :: forall k (tag :: k) (f :: * -> *) a. Monad f => a -> ViaTag tag f a
return :: forall a. a -> ViaTag tag f a
Monad
        , Monad (ViaTag tag f)
Alternative (ViaTag tag f)
(Alternative (ViaTag tag f), Monad (ViaTag tag f)) =>
(forall a. ViaTag tag f a)
-> (forall a. ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a)
-> MonadPlus (ViaTag tag f)
forall a. ViaTag tag f a
forall a. ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
MonadPlus f =>
Monad (ViaTag tag f)
forall k (tag :: k) (f :: * -> *).
MonadPlus f =>
Alternative (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a. MonadPlus f => ViaTag tag f a
forall k (tag :: k) (f :: * -> *) a.
MonadPlus f =>
ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall k (tag :: k) (f :: * -> *) a. MonadPlus f => ViaTag tag f a
mzero :: forall a. ViaTag tag f a
$cmplus :: forall k (tag :: k) (f :: * -> *) a.
MonadPlus f =>
ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
mplus :: forall a. ViaTag tag f a -> ViaTag tag f a -> ViaTag tag f a
MonadPlus
        , Monad (ViaTag tag f)
Monad (ViaTag tag f) =>
(forall a. (a -> ViaTag tag f a) -> ViaTag tag f a)
-> MonadFix (ViaTag tag f)
forall a. (a -> ViaTag tag f a) -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
MonadFix f =>
Monad (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a.
MonadFix f =>
(a -> ViaTag tag f a) -> ViaTag tag f a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall k (tag :: k) (f :: * -> *) a.
MonadFix f =>
(a -> ViaTag tag f a) -> ViaTag tag f a
mfix :: forall a. (a -> ViaTag tag f a) -> ViaTag tag f a
MonadFix
        , Monad (ViaTag tag f)
Monad (ViaTag tag f) =>
(forall a. IO a -> ViaTag tag f a) -> MonadIO (ViaTag tag f)
forall a. IO a -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
MonadIO f =>
Monad (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a.
MonadIO f =>
IO a -> ViaTag tag f a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall k (tag :: k) (f :: * -> *) a.
MonadIO f =>
IO a -> ViaTag tag f a
liftIO :: forall a. IO a -> ViaTag tag f a
MonadIO
        , Monad (ViaTag tag f)
Monad (ViaTag tag f) =>
(forall a. String -> ViaTag tag f a) -> MonadFail (ViaTag tag f)
forall a. String -> ViaTag tag f a
forall k (tag :: k) (f :: * -> *).
MonadFail f =>
Monad (ViaTag tag f)
forall k (tag :: k) (f :: * -> *) a.
MonadFail f =>
String -> ViaTag tag f a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall k (tag :: k) (f :: * -> *) a.
MonadFail f =>
String -> ViaTag tag f a
fail :: forall a. String -> ViaTag tag f a
MonadFail
        , MonadReader r
        , MonadWriter w
        , MonadState s
        , MonadRWS r w s
        , MonadError e
        )

-- | Send all effects within the scope, tagged, to carrier @f@.
tag :: forall tag f a. ViaTag tag f a -> f a
tag :: forall {k} (tag :: k) (f :: * -> *) a. ViaTag tag f a -> f a
tag = ViaTag tag f a -> f a
forall {k} (tag :: k) (f :: * -> *) a. ViaTag tag f a -> f a
runViaTag
{-# INLINE tag #-}

instance (SendFOE (ins # tag) f) => SendFOE ins (ViaTag tag f) where
    sendFOE :: forall a. ins a -> ViaTag tag f a
sendFOE = f a -> ViaTag tag f a
forall {k} (tag :: k) (f :: * -> *) a. f a -> ViaTag tag f a
ViaTag (f a -> ViaTag tag f a)
-> (ins a -> f a) -> ins a -> ViaTag tag f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag ins tag a -> f a
forall a. Tag ins tag a -> f a
forall (ins :: * -> *) (f :: * -> *) a.
SendFOE ins f =>
ins a -> f a
sendFOE (Tag ins tag a -> f a) -> (ins a -> Tag ins tag a) -> ins a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tag :: k) (ins :: * -> *) a. ins a -> Tag ins tag a
forall {k} (tag :: k) (ins :: * -> *) a. ins a -> Tag ins tag a
T @tag
    {-# INLINE sendFOE #-}

instance (SendHOE (sig ## tag) f, HFunctor sig) => SendHOE sig (ViaTag tag f) where
    sendHOE :: forall a. sig (ViaTag tag f) a -> ViaTag tag f a
sendHOE = f a -> ViaTag tag f a
forall {k} (tag :: k) (f :: * -> *) a. f a -> ViaTag tag f a
ViaTag (f a -> ViaTag tag f a)
-> (sig (ViaTag tag f) a -> f a)
-> sig (ViaTag tag f) a
-> ViaTag tag f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagH sig tag f a -> f a
forall a. TagH sig tag f a -> f a
forall (sig :: EffectH) (f :: * -> *) a.
SendHOE sig f =>
sig f a -> f a
sendHOE (TagH sig tag f a -> f a)
-> (sig (ViaTag tag f) a -> TagH sig tag f a)
-> sig (ViaTag tag f) a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tag :: k) (sig :: EffectH) (f :: * -> *) a.
sig f a -> TagH sig tag f a
forall {k} (tag :: k) (sig :: EffectH) (f :: * -> *) a.
sig f a -> TagH sig tag f a
TH @tag (sig f a -> TagH sig tag f a)
-> (sig (ViaTag tag f) a -> sig f a)
-> sig (ViaTag tag f) a
-> TagH sig tag f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViaTag tag f :-> f) -> sig (ViaTag tag f) :-> sig f
forall (f :: * -> *) (g :: * -> *). (f :-> g) -> sig f :-> sig g
forall (h :: EffectH) (f :: * -> *) (g :: * -> *).
HFunctor h =>
(f :-> g) -> h f :-> h g
hfmap ViaTag tag f i -> f i
ViaTag tag f :-> f
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE sendHOE #-}

instance (SendFOEBy key (ins # tag) f) => SendFOEBy key ins (ViaTag tag f) where
    sendFOEBy :: forall a. ins a -> ViaTag tag f a
sendFOEBy = f a -> ViaTag tag f a
forall {k} (tag :: k) (f :: * -> *) a. f a -> ViaTag tag f a
ViaTag (f a -> ViaTag tag f a)
-> (ins a -> f a) -> ins a -> ViaTag tag f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (key :: k) (ins :: * -> *) (f :: * -> *) a.
SendFOEBy key ins f =>
ins a -> f a
forall {k} (key :: k) (ins :: * -> *) (f :: * -> *) a.
SendFOEBy key ins f =>
ins a -> f a
sendFOEBy @key (Tag ins tag a -> f a) -> (ins a -> Tag ins tag a) -> ins a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tag :: k) (ins :: * -> *) a. ins a -> Tag ins tag a
forall {k} (tag :: k) (ins :: * -> *) a. ins a -> Tag ins tag a
T @tag
    {-# INLINE sendFOEBy #-}

instance (SendHOEBy key (sig ## tag) f, HFunctor sig) => SendHOEBy key sig (ViaTag tag f) where
    sendHOEBy :: forall a. sig (ViaTag tag f) a -> ViaTag tag f a
sendHOEBy = f a -> ViaTag tag f a
forall {k} (tag :: k) (f :: * -> *) a. f a -> ViaTag tag f a
ViaTag (f a -> ViaTag tag f a)
-> (sig (ViaTag tag f) a -> f a)
-> sig (ViaTag tag f) a
-> ViaTag tag f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (key :: k) (sig :: EffectH) (f :: * -> *) a.
SendHOEBy key sig f =>
sig f a -> f a
forall {k} (key :: k) (sig :: EffectH) (f :: * -> *) a.
SendHOEBy key sig f =>
sig f a -> f a
sendHOEBy @key (TagH sig tag f a -> f a)
-> (sig (ViaTag tag f) a -> TagH sig tag f a)
-> sig (ViaTag tag f) a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (tag :: k) (sig :: EffectH) (f :: * -> *) a.
sig f a -> TagH sig tag f a
forall {k} (tag :: k) (sig :: EffectH) (f :: * -> *) a.
sig f a -> TagH sig tag f a
TH @tag (sig f a -> TagH sig tag f a)
-> (sig (ViaTag tag f) a -> sig f a)
-> sig (ViaTag tag f) a
-> TagH sig tag f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViaTag tag f :-> f) -> sig (ViaTag tag f) :-> sig f
forall (f :: * -> *) (g :: * -> *). (f :-> g) -> sig f :-> sig g
forall (h :: EffectH) (f :: * -> *) (g :: * -> *).
HFunctor h =>
(f :-> g) -> h f :-> h g
hfmap ViaTag tag f i -> f i
ViaTag tag f :-> f
forall a b. Coercible a b => a -> b
coerce
    {-# INLINE sendHOEBy #-}