{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-} -- SPDX-License-Identifier: MPL-2.0 {- | Copyright : (c) 2023-2025 Sayo contributors License : MPL-2.0 (see the file LICENSE) Maintainer : ymdfield@outlook.jp -} module Control.Effect where import Control.Alternative.Free qualified as Tree import Control.Alternative.Free.Final qualified as Final import Control.Applicative (Alternative, empty, (<|>)) import Control.Applicative.Free qualified as Tree import Control.Applicative.Free.Fast qualified as Fast import Control.Applicative.Free.Final qualified as Final import Control.Monad (MonadPlus) import Control.Monad.Cont qualified as Cont import Control.Monad.Except (MonadError, catchError, throwError) import Control.Monad.Fix (MonadFix, mfix) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.RWS (MonadRWS) import Control.Monad.Reader (MonadReader (ask), local) import Control.Monad.State (MonadState, get, put) import Control.Monad.Writer (MonadWriter, listen, tell) import Control.Monad.Writer qualified as Writer import Data.Effect ( Ask (Ask), AskLabel, CC (Jump, SubFork), Catch (Catch), ChooseH (ChooseH), Emb (Emb), Empty (Empty), Fail (Fail), Fix (Efix), Local (Local), State (Get, Put), StateLabel, Tell (Tell), TellLabel, Throw (Throw), ThrowLabel, UnliftBase (WithRunInBase), UnliftIO, WriterH (Listen), ) import Data.Effect.OpenUnion ( At, FindByLabel, Has, IdentityResolver, In, KeyDiscriminator, KeyResolver, KnownIndex, KnownOrder, LabelResolver, Membership, Union, hfmapUnion, inject, membership, membershipAt, type (:>), ) import Data.Effect.Tag (Tagged (Tag), type (#)) import Data.Functor.Coyoneda (Coyoneda (Coyoneda), hoistCoyoneda, liftCoyoneda, lowerCoyoneda) import Data.Kind (Type) import Data.Tuple (swap) import UnliftIO qualified as IO newtype Eff ff es a = Eff {unEff :: ff (Union es (Eff ff es)) a} perform :: forall e es ff a c. (e :> es, Free c ff) => e (Eff ff es) a -> Eff ff es a perform = sendFor $ membership @LabelResolver {-# INLINE perform #-} perform' :: forall key e es ff a c. (Has key e es, Free c ff) => e (Eff ff es) a -> Eff ff es a perform' = sendFor (membership @KeyResolver @(KeyDiscriminator key)) . Tag {-# INLINE perform' #-} perform'' :: forall tag e es ff a c. (e # tag :> es, Free c ff) => e (Eff ff es) a -> Eff ff es a perform'' = perform . Tag @tag {-# INLINE perform'' #-} send :: forall e es ff a c. (e `In` es, Free c ff) => e (Eff ff es) a -> Eff ff es a send = sendFor $ membership @IdentityResolver {-# INLINE send #-} sendAt :: forall i es ff a c. (KnownIndex i es, Free c ff) => At i es (Eff ff es) a -> Eff ff es a sendAt = sendFor $ membershipAt @i {-# INLINE sendAt #-} sendFor :: forall e es ff a c . (KnownOrder e, Free c ff) => Membership e es -> e (Eff ff es) a -> Eff ff es a sendFor i = Eff . liftFree . inject i {-# INLINE sendFor #-} emb :: forall f es ff a c. (Emb f :> es, Free c ff) => f a -> Eff ff es a emb = perform . Emb {-# INLINE emb #-} -- | A natural transformation. type f ~> g = forall (x :: Type). f x -> g x infixr 2 ~> type e ~~> f = e f ~> f infix 2 ~~> infixr 3 $ infixr 4 $$ -- | Type-level infix applcation for functors. type (f :: Type -> Type) $ a = f a -- | Type-level infix applcation for higher-order functors. type (h :: (Type -> Type) -> Type -> Type) $$ f = h f instance (FindByLabel AskLabel (Ask r) es, Local r :> es, Monad (Eff ff es), Free c ff) => MonadReader r (Eff ff es) where ask = perform Ask local f a = perform $ Local f a {-# INLINE ask #-} {-# INLINE local #-} instance (FindByLabel TellLabel (Tell w) es, WriterH w :> es, Monoid w, Monad (Eff ff es), Free c ff) => MonadWriter w (Eff ff es) where tell = perform . Tell listen a = fmap swap $ perform $ Listen a pass = pass . fmap swap {-# INLINE tell #-} {-# INLINE listen #-} {- | For a given scope, uses the function (the first component of the pair returned by that scope) to modify the accumulated value of that scope, and then accumulates the result into the current outer scope. @ pass m = do (w, (f, a)) <- listen m tell $ f w pure a @ -} pass :: forall w a es ff c . (Tell w :> es, WriterH w :> es, Monad (Eff ff es), Free c ff) => Eff ff es (w -> w, a) -> Eff ff es a pass m = do (w, (f, a)) <- perform $ Listen m perform $ Tell $ f w pure a {-# INLINE pass #-} instance (FindByLabel StateLabel (State s) es, Monad (Eff ff es), Free c ff) => MonadState s (Eff ff es) where get = perform Get put = perform . Put {-# INLINE get #-} {-# INLINE put #-} instance ( FindByLabel AskLabel (Ask r) es , Local r :> es , FindByLabel TellLabel (Tell w) es , WriterH w :> es , FindByLabel StateLabel (State s) es , Monoid w , Monad (Eff ff es) , Free c ff ) => MonadRWS r w s (Eff ff es) instance (FindByLabel ThrowLabel (Throw e) es, Catch e :> es, Monad (Eff ff es), Free c ff) => MonadError e (Eff ff es) where throwError = perform . Throw catchError a hdl = perform $ Catch a hdl {-# INLINE throwError #-} {-# INLINE catchError #-} instance (Empty :> es, ChooseH :> es, Applicative (Eff ff es), Free c ff) => Alternative (Eff ff es) where empty = perform Empty a <|> b = perform $ ChooseH a b {-# INLINE empty #-} {-# INLINE (<|>) #-} instance (Empty :> es, ChooseH :> es, Monad (Eff ff es), Free c ff) => MonadPlus (Eff ff es) instance (CC ref :> es, Monad (Eff ff es), Free c ff) => Cont.MonadCont (Eff ff es) where callCC = callCC_ {-# INLINE callCC #-} sub :: forall ref a b es ff c . (CC ref :> es, Monad (Eff ff es), Free c ff) => (ref a -> Eff ff es b) -> (a -> Eff ff es b) -> Eff ff es b sub p q = perform SubFork >>= either p q {-# INLINE sub #-} callCC_ :: forall ref a b es ff c . (CC ref :> es, Monad (Eff ff es), Free c ff) => ((a -> Eff ff es b) -> Eff ff es a) -> Eff ff es a callCC_ f = sub (f . jump) pure where jump ref x = perform $ Jump ref x {-# INLINE callCC_ #-} instance (Emb IO :> es, Monad (Eff ff es), Free c ff) => MonadIO (Eff ff es) where liftIO = emb {-# INLINE liftIO #-} instance (Fail :> es, Monad (Eff ff es), Free c ff) => MonadFail (Eff ff es) where fail = perform . Fail {-# INLINE fail #-} instance (Fix :> es, Monad (Eff ff es), Free c ff) => MonadFix (Eff ff es) where mfix = perform . Efix {-# INLINE mfix #-} instance (UnliftIO :> es, Emb IO :> es, Monad (Eff ff es), Free c ff) => IO.MonadUnliftIO (Eff ff es) where withRunInIO f = perform $ WithRunInBase f {-# INLINE withRunInIO #-} -- Free class (forall f. c (ff f)) => Free c (ff :: (Type -> Type) -> Type -> Type) | ff -> c where {-# MINIMAL liftFree, (runFree | (retract, hoist)) #-} liftFree :: f a -> ff f a runFree :: (c g) => (forall x. f x -> g x) -> ff f a -> g a retract :: (c f) => ff f a -> f a hoist :: (forall x. f x -> g x) -> ff f a -> ff g a runFree f = retract . hoist f retract = runFree id default hoist :: (c (ff g)) => (forall x. f x -> g x) -> ff f a -> ff g a hoist phi = runFree $ liftFree . phi {-# INLINE runFree #-} {-# INLINE retract #-} {-# INLINE hoist #-} convertEff :: forall ff gg es a c c' . (Free c ff, Free c' gg, forall r. c (gg r)) => Eff ff es a -> Eff gg es a convertEff = go where go :: Eff ff es ~> Eff gg es go = Eff . hoist (hfmapUnion go) . convertFree . unEff {-# INLINE convertEff #-} convertFree :: (Free c ff, Free c' gg, c (gg r)) => ff r a -> gg r a convertFree = runFree liftFree {-# INLINE convertFree #-} deriving instance (forall f. Functor (ff f)) => Functor (Eff ff es) deriving instance (forall r. Applicative (ff r)) => Applicative (Eff ff es) deriving instance (forall r. Monad (ff r)) => Monad (Eff ff es) instance Free Functor Coyoneda where liftFree = liftCoyoneda runFree f (Coyoneda g x) = g <$> f x retract = lowerCoyoneda hoist = hoistCoyoneda {-# INLINE liftFree #-} {-# INLINE runFree #-} {-# INLINE retract #-} {-# INLINE hoist #-} instance Free Applicative Tree.Ap where liftFree = Tree.liftAp runFree = Tree.runAp retract = Tree.retractAp hoist = Tree.hoistAp {-# INLINE liftFree #-} {-# INLINE runFree #-} {-# INLINE retract #-} {-# INLINE hoist #-} instance Free Applicative Fast.Ap where liftFree = Fast.liftAp runFree = Fast.runAp retract = Fast.retractAp hoist = Fast.hoistAp {-# INLINE liftFree #-} {-# INLINE runFree #-} {-# INLINE retract #-} {-# INLINE hoist #-} instance Free Applicative Final.Ap where liftFree = Final.liftAp runFree = Final.runAp retract = Final.retractAp hoist = Final.hoistAp {-# INLINE liftFree #-} {-# INLINE runFree #-} {-# INLINE retract #-} {-# INLINE hoist #-} instance Free Alternative Tree.Alt where liftFree = Tree.liftAlt runFree = Tree.runAlt hoist = Tree.hoistAlt {-# INLINE liftFree #-} {-# INLINE runFree #-} {-# INLINE hoist #-} instance Free Alternative Final.Alt where liftFree = Final.liftAlt runFree = Final.runAlt hoist = Final.hoistAlt {-# INLINE liftFree #-} {-# INLINE runFree #-} {-# INLINE hoist #-}