-- 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) 2024 Sayo Koyoneda
License     :  MPL-2.0 (see the LICENSE file)
Maintainer  :  ymdfield@outlook.jp
Portability :  portable
-}
module Control.Monad.Hefty.Output where

import Control.Arrow ((>>>))
import Control.Monad.Hefty (Eff, interpret, interpretStateBy, raiseUnder, type (~>))
import Control.Monad.Hefty.State (runState)
import Control.Monad.Hefty.Writer (handleTell)
import Data.Effect.Output (Output (Output))
import Data.Effect.State (modify)
import Data.Effect.Writer (Tell (Tell))

runOutputEff
    :: forall o ef eh
     . (o -> Eff eh ef ())
    -> Eff eh (Output o ': ef) ~> Eff eh ef
runOutputEff :: forall o (ef :: [EffectF]) (eh :: [EffectH]).
(o -> Eff eh ef ()) -> Eff eh (Output o : ef) ~> Eff eh ef
runOutputEff o -> Eff eh ef ()
f = (Output o ~> Eff eh ef) -> Eff eh (Output o : ef) ~> Eff eh ef
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \(Output o
o) -> o -> Eff eh ef ()
f o
o

ignoreOutput
    :: forall o ef eh
     . Eff eh (Output o ': ef) ~> Eff eh ef
ignoreOutput :: forall o (ef :: [EffectF]) (eh :: [EffectH]) x.
Eff eh (Output o : ef) x -> Eff eh ef x
ignoreOutput = (o -> Eff eh ef ()) -> Eff eh (Output o : ef) ~> Eff eh ef
forall o (ef :: [EffectF]) (eh :: [EffectH]).
(o -> Eff eh ef ()) -> Eff eh (Output o : ef) ~> Eff eh ef
runOutputEff ((o -> Eff eh ef ()) -> Eff eh (Output o : ef) ~> Eff eh ef)
-> (o -> Eff eh ef ()) -> Eff eh (Output o : ef) ~> Eff eh ef
forall a b. (a -> b) -> a -> b
$ Eff eh ef () -> o -> Eff eh ef ()
forall a b. a -> b -> a
const (Eff eh ef () -> o -> Eff eh ef ())
-> Eff eh ef () -> o -> Eff eh ef ()
forall a b. (a -> b) -> a -> b
$ () -> Eff eh ef ()
forall a. a -> Eff eh ef a
forall (f :: EffectF) a. Applicative f => a -> f a
pure ()

runOutputList
    :: forall o a ef
     . Eff '[] (Output o ': ef) a
    -> Eff '[] ef ([o], a)
runOutputList :: forall o a (ef :: [EffectF]).
Eff '[] (Output o : ef) a -> Eff '[] ef ([o], a)
runOutputList =
    Eff '[] (Output o : ef) a -> Eff '[] (Output o : State [o] : ef) a
forall (e1 :: EffectF) (e2 :: EffectF) (ef :: [EffectF])
       (eh :: [EffectH]) x.
Eff eh (e1 : ef) x -> Eff eh (e1 : e2 : ef) x
raiseUnder
        (Eff '[] (Output o : ef) a
 -> Eff '[] (Output o : State [o] : ef) a)
-> (Eff '[] (Output o : State [o] : ef) a -> Eff '[] ef ([o], a))
-> Eff '[] (Output o : ef) a
-> Eff '[] ef ([o], a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Output o ~> Eff '[] (State [o] : ef))
-> Eff '[] (Output o : State [o] : ef) ~> Eff '[] (State [o] : ef)
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret (\(Output o
o) -> ([o] -> [o]) -> Eff '[] (State [o] : ef) ()
forall s (m :: EffectF).
(State s <: m, Monad m) =>
(s -> s) -> m ()
modify (o
o :))
        (Eff '[] (Output o : State [o] : ef) a
 -> Eff '[] (State [o] : ef) a)
-> (Eff '[] (State [o] : ef) a -> Eff '[] ef ([o], a))
-> Eff '[] (Output o : State [o] : ef) a
-> Eff '[] ef ([o], a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [o] -> Eff '[] (State [o] : ef) a -> Eff '[] ef ([o], a)
forall s (ef :: [EffectF]) a.
s -> Eff '[] (State s : ef) a -> Eff '[] ef (s, a)
runState []

-- | Run an `Output` effect by transforming into a monoid.
runOutputMonoid
    :: forall o w a ef
     . ( Monoid w
       )
    => (o -> w)
    -> Eff '[] (Output o ': ef) a
    -> Eff '[] ef (w, a)
runOutputMonoid :: forall o w a (ef :: [EffectF]).
Monoid w =>
(o -> w) -> Eff '[] (Output o : ef) a -> Eff '[] ef (w, a)
runOutputMonoid o -> w
f =
    w
-> (w -> a -> Eff '[] ef (w, a))
-> StateInterpreter w (Output o) (Eff '[] ef) (w, a)
-> Eff '[] (Output o : ef) a
-> Eff '[] ef (w, a)
forall s (e :: EffectF) (ef :: [EffectF]) ans a.
s
-> (s -> a -> Eff '[] ef ans)
-> StateInterpreter s e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretStateBy w
forall a. Monoid a => a
mempty (((w, a) -> Eff '[] ef (w, a)) -> w -> a -> Eff '[] ef (w, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (w, a) -> Eff '[] ef (w, a)
forall a. a -> Eff '[] ef a
forall (f :: EffectF) a. Applicative f => a -> f a
pure) \(Output o
o) ->
        Tell w x -> w -> (w -> x -> Eff '[] ef (w, a)) -> Eff '[] ef (w, a)
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
forall w (ef :: [EffectF]) a.
Monoid w =>
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
handleTell (Tell w x
 -> w -> (w -> x -> Eff '[] ef (w, a)) -> Eff '[] ef (w, a))
-> Tell w x
-> w
-> (w -> x -> Eff '[] ef (w, a))
-> Eff '[] ef (w, a)
forall a b. (a -> b) -> a -> b
$ w -> Tell w ()
forall w. w -> Tell w ()
Tell (w -> Tell w ()) -> w -> Tell w ()
forall a b. (a -> b) -> a -> b
$ o -> w
f o
o