-- 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.Input where

import Control.Arrow ((>>>))
import Control.Monad.Hefty (Eff, interpret, raiseUnder, type (~>))
import Control.Monad.Hefty.State (evalState)
import Data.Effect.Input (Input (Input))
import Data.Effect.State (gets, put)
import Data.List (uncons)

runInputEff
    :: forall i ef eh
     . Eff eh ef i
    -> Eff eh (Input i ': ef) ~> Eff eh ef
runInputEff :: forall i (ef :: [EffectF]) (eh :: [EffectH]).
Eff eh ef i -> Eff eh (Input i : ef) ~> Eff eh ef
runInputEff Eff eh ef i
a = (Input i ~> Eff eh ef) -> Eff eh (Input i : ef) ~> Eff eh ef
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \Input i x
Input -> Eff eh ef i
Eff eh ef x
a

runInputConst
    :: forall i ef eh
     . i
    -> Eff eh (Input i ': ef) ~> Eff eh ef
runInputConst :: forall i (ef :: [EffectF]) (eh :: [EffectH]).
i -> Eff eh (Input i : ef) ~> Eff eh ef
runInputConst i
i = (Input i ~> Eff eh ef) -> Eff eh (Input i : ef) ~> Eff eh ef
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \Input i x
Input -> x -> Eff eh ef x
forall a. a -> Eff eh ef a
forall (f :: EffectF) a. Applicative f => a -> f a
pure i
x
i

runInputList :: forall i r. [i] -> Eff '[] (Input (Maybe i) ': r) ~> Eff '[] r
runInputList :: forall i (r :: [EffectF]).
[i] -> Eff '[] (Input (Maybe i) : r) ~> Eff '[] r
runInputList [i]
is =
    Eff '[] (Input (Maybe i) : r) x
-> Eff '[] (Input (Maybe i) : State [i] : r) x
forall (e1 :: EffectF) (e2 :: EffectF) (ef :: [EffectF])
       (eh :: [EffectH]) x.
Eff eh (e1 : ef) x -> Eff eh (e1 : e2 : ef) x
raiseUnder
        (Eff '[] (Input (Maybe i) : r) x
 -> Eff '[] (Input (Maybe i) : State [i] : r) x)
-> (Eff '[] (Input (Maybe i) : State [i] : r) x -> Eff '[] r x)
-> Eff '[] (Input (Maybe i) : r) x
-> Eff '[] r x
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Eff '[] (Input (Maybe i) : State [i] : r) x
-> Eff '[] (State [i] : r) x
int
        (Eff '[] (Input (Maybe i) : State [i] : r) x
 -> Eff '[] (State [i] : r) x)
-> (Eff '[] (State [i] : r) x -> Eff '[] r x)
-> Eff '[] (Input (Maybe i) : State [i] : r) x
-> Eff '[] r x
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [i] -> Eff '[] (State [i] : r) x -> Eff '[] r x
forall s (ef :: [EffectF]) a.
s -> Eff '[] (State s : ef) a -> Eff '[] ef a
evalState [i]
is
  where
    int :: Eff '[] (Input (Maybe i) : State [i] : r) x
-> Eff '[] (State [i] : r) x
int = (Input (Maybe i) ~> Eff '[] (State [i] : r))
-> Eff '[] (Input (Maybe i) : State [i] : r)
   ~> Eff '[] (State [i] : r)
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \Input (Maybe i) x
Input -> do
        Maybe (i, [i])
is' <- forall s (f :: EffectF) a.
(State s <: f, Functor f) =>
(s -> a) -> f a
gets @[i] [i] -> Maybe (i, [i])
forall a. [a] -> Maybe (a, [a])
uncons
        ((i, [i]) -> Eff '[] (State [i] : r) ())
-> Maybe (i, [i]) -> Eff '[] (State [i] : r) ()
forall (t :: EffectF) (m :: EffectF) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([i] -> Eff '[] (State [i] : r) ()
forall s (f :: EffectF). SendFOE (State s) f => s -> f ()
put ([i] -> Eff '[] (State [i] : r) ())
-> ((i, [i]) -> [i]) -> (i, [i]) -> Eff '[] (State [i] : r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i, [i]) -> [i]
forall a b. (a, b) -> b
snd) Maybe (i, [i])
is'
        x -> Eff '[] (State [i] : r) x
forall a. a -> Eff '[] (State [i] : r) a
forall (f :: EffectF) a. Applicative f => a -> f a
pure (x -> Eff '[] (State [i] : r) x) -> x -> Eff '[] (State [i] : r) x
forall a b. (a -> b) -> a -> b
$ (i, [i]) -> i
forall a b. (a, b) -> a
fst ((i, [i]) -> i) -> Maybe (i, [i]) -> Maybe i
forall (f :: EffectF) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (i, [i])
is'