diff --git a/heftia-effects/heftia-effects.cabal b/heftia-effects/heftia-effects.cabal index 9185d7c..6ee9d99 100644 --- a/heftia-effects/heftia-effects.cabal +++ b/heftia-effects/heftia-effects.cabal @@ -70,6 +70,8 @@ library Control.Effect.Handler.Heftia.Except Control.Effect.Handler.Heftia.ShiftReset Control.Effect.Handler.Heftia.Coroutine + Control.Effect.Handler.Heftia.Input + Control.Effect.Handler.Heftia.Output Control.Effect.Handler.Heftia.Provider Control.Effect.Handler.Heftia.Provider.Implicit Control.Effect.Handler.Heftia.Resource diff --git a/heftia-effects/src/Control/Effect/Handler/Heftia/Input.hs b/heftia-effects/src/Control/Effect/Handler/Heftia/Input.hs new file mode 100644 index 0000000..1ac6448 --- /dev/null +++ b/heftia-effects/src/Control/Effect/Handler/Heftia/Input.hs @@ -0,0 +1,55 @@ +-- 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 Yamada Ryo +License : MPL-2.0 (see the file LICENSE) +Maintainer : ymdfield@outlook.jp +Stability : experimental +Portability : portable +-} +module Control.Effect.Handler.Heftia.Input where +import Control.Freer (Freer) +import Data.Hefty.Union (Union (HasMembership)) +import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder) +import Data.Effect.HFunctor (HFunctor) +import Data.Effect.Input (Input(Input), LInput) +import Control.Effect (type (~>)) +import Control.Arrow ((>>>)) +import Control.Effect.Handler.Heftia.State (evalState) +import Control.Monad.State (StateT) +import Data.Effect.State (LState, gets, put) +import Data.List (uncons) + +runInputEff :: + forall i r eh fr u c. + (Freer c fr, Union u, Applicative (Eff u fr eh r), HFunctor (u eh)) => + Eff u fr eh r i -> Eff u fr eh (LInput i ': r) ~> Eff u fr eh r +runInputEff a = interpretRec \Input -> a +{-# INLINE runInputEff #-} + +runInputConst :: + forall i r eh fr u c. + (Freer c fr, Union u, Applicative (Eff u fr eh r), HFunctor (u eh)) => + i -> Eff u fr eh (LInput i ': r) ~> Eff u fr eh r +runInputConst i = interpretRec \Input -> pure i +{-# INLINE runInputConst #-} + +runInputList :: + forall i r fr u c. + ( Freer c fr, Union u + , Applicative (Eff u fr '[] r), Monad (Eff u fr '[] (LState [i] ': r)) + , c (Eff u fr '[] r), c (StateT [i] (Eff u fr '[] r)) + , HasMembership u (LState [i]) (LState [i] ': r) + , HFunctor (u '[]) + ) => + [i] -> Eff u fr '[] (LInput (Maybe i) ': r) ~> Eff u fr '[] r +runInputList is = + raiseUnder + >>> ( interpret \Input -> do + is' <- gets @[i] uncons + mapM_ (put . snd) is' + pure $ fst <$> is' + ) + >>> evalState is diff --git a/heftia-effects/src/Control/Effect/Handler/Heftia/Output.hs b/heftia-effects/src/Control/Effect/Handler/Heftia/Output.hs new file mode 100644 index 0000000..2c26ffd --- /dev/null +++ b/heftia-effects/src/Control/Effect/Handler/Heftia/Output.hs @@ -0,0 +1,12 @@ +-- 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 Yamada Ryo +License : MPL-2.0 (see the file LICENSE) +Maintainer : ymdfield@outlook.jp +Stability : experimental +Portability : portable +-} +module Control.Effect.Handler.Heftia.Output where diff --git a/heftia-effects/src/Control/Effect/Handler/Heftia/Unlift.hs b/heftia-effects/src/Control/Effect/Handler/Heftia/Unlift.hs index 9262815..5d0c315 100644 --- a/heftia-effects/src/Control/Effect/Handler/Heftia/Unlift.hs +++ b/heftia-effects/src/Control/Effect/Handler/Heftia/Unlift.hs @@ -2,6 +2,13 @@ -- 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 Yamada Ryo +License : MPL-2.0 (see the file LICENSE) +Maintainer : ymdfield@outlook.jp +Stability : experimental +Portability : portable +-} module Control.Effect.Handler.Heftia.Unlift where import Control.Freer (Freer)