{-# 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 Yamada Ryo
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 (SendIns (sendIns), SendSig (sendSig))
import Control.Effect.Key (SendInsBy, SendSigBy, sendInsBy, sendSigBy)
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 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
<$ :: forall a b. a -> ViaTag tag f b -> ViaTag tag f a
$c<$ :: forall k (tag :: k) (f :: * -> *) a b.
Functor f =>
a -> ViaTag tag f b -> ViaTag tag f a
fmap :: forall a b. (a -> b) -> ViaTag tag f a -> ViaTag tag f b
$cfmap :: forall k (tag :: k) (f :: * -> *) a b.
Functor f =>
(a -> b) -> ViaTag tag f a -> ViaTag tag f b
Functor
        , 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
<* :: forall a b. ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f a
$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 b
$c*> :: forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f b
liftA2 :: forall a b c.
(a -> b -> c) -> ViaTag tag f a -> ViaTag tag f b -> ViaTag tag f c
$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
<*> :: forall a b.
ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b
$c<*> :: forall k (tag :: k) (f :: * -> *) a b.
Applicative f =>
ViaTag tag f (a -> b) -> ViaTag tag f a -> ViaTag tag f b
pure :: forall a. a -> ViaTag tag f a
$cpure :: forall k (tag :: k) (f :: * -> *) a.
Applicative f =>
a -> ViaTag tag f a
Applicative
        , 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
many :: 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]
some :: forall 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]
<|> :: forall a. ViaTag tag f a -> ViaTag tag f 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
empty :: forall a. ViaTag tag f a
$cempty :: forall k (tag :: k) (f :: * -> *) a.
Alternative f =>
ViaTag tag f a
Alternative
        , 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
return :: forall a. a -> ViaTag tag f a
$creturn :: forall k (tag :: k) (f :: * -> *) a. Monad f => a -> ViaTag tag f a
>> :: forall a b. ViaTag tag f 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 -> (a -> ViaTag tag f b) -> ViaTag tag f b
$c>>= :: forall k (tag :: k) (f :: * -> *) a b.
Monad f =>
ViaTag tag f a -> (a -> ViaTag tag f b) -> ViaTag tag f b
Monad
        , 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
mplus :: forall a. ViaTag tag f a -> ViaTag tag f 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
mzero :: forall a. ViaTag tag f a
$cmzero :: forall k (tag :: k) (f :: * -> *) a. MonadPlus f => ViaTag tag f a
MonadPlus
        , 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
mfix :: forall a. (a -> ViaTag tag f a) -> ViaTag tag f a
$cmfix :: forall k (tag :: k) (f :: * -> *) a.
MonadFix f =>
(a -> ViaTag tag f a) -> ViaTag tag f a
MonadFix
        , 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
liftIO :: forall a. IO a -> ViaTag tag f a
$cliftIO :: forall k (tag :: k) (f :: * -> *) a.
MonadIO f =>
IO a -> ViaTag tag f a
MonadIO
        , 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
fail :: forall a. String -> ViaTag tag f a
$cfail :: forall k (tag :: k) (f :: * -> *) a.
MonadFail f =>
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 = forall {k} (tag :: k) (f :: * -> *) a. ViaTag tag f a -> f a
runViaTag
{-# INLINE tag #-}

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

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

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

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