module Polysemy.Db.Interpreter.AtomicState where

import Conc (Lock, lock)
import Polysemy.AtomicState (AtomicState (AtomicGet, AtomicState))

import qualified Polysemy.Db.Effect.Store as Store
import Polysemy.Db.Effect.Store (QStore)

insertState ::
  ∀ d err r .
  Members [QStore Maybe () d !! err, Stop err] r =>
  Sem r d ->
  Sem r d
insertState :: forall d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Stop err] r =>
Sem r d -> Sem r d
insertState Sem r d
initial = do
  forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop do
    forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise Sem r d
initial forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Functor m => (a -> m ()) -> a -> m a
tap \ d
d ->
      forall (f :: * -> *) i d (r :: EffectRow).
Member (QStore f i d) r =>
Sem r [d]
Store.deleteAll forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) i d (r :: EffectRow).
Member (QStore f i d) r =>
d -> Sem r ()
Store.insert d
d

readState ::
  ∀ d err r .
  Members [QStore Maybe () d !! err, Stop err] r =>
  Sem r d ->
  Sem r d
readState :: forall d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Stop err] r =>
Sem r d -> Sem r d
readState Sem r d
initial = do
  Maybe d
stored <- forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop (forall (f :: * -> *) i d (r :: EffectRow).
Member (QStore f i d) r =>
i -> Sem r (f d)
Store.fetch ())
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Stop err] r =>
Sem r d -> Sem r d
insertState @d @err Sem r d
initial) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe d
stored

handleAtomicStateStore ::
  ∀ tag d err r0 r a .
  Members [QStore Maybe () d !! err, Lock @@ tag, Stop err] r =>
  Sem r d ->
  AtomicState d (Sem r0) a ->
  Sem r a
handleAtomicStateStore :: forall {k} (tag :: k) d err (r0 :: EffectRow) (r :: EffectRow) a.
Members '[QStore Maybe () d !! err, Lock @@ tag, Stop err] r =>
Sem r d -> AtomicState d (Sem r0) a -> Sem r a
handleAtomicStateStore Sem r d
initial = \case
  AtomicState d -> (d, a)
f ->
    forall {k1} (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow)
       a.
Member (Tagged k2 e) r =>
Sem (e : r) a -> Sem r a
tag @tag @Lock forall a b. (a -> b) -> a -> b
$ forall (r :: EffectRow) a. Member Lock r => Sem r a -> Sem r a
lock do
      (d
newState, a
a) <- d -> (d, a)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (forall d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Stop err] r =>
Sem r d -> Sem r d
readState @d @err Sem r d
initial)
      a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Stop err] r =>
Sem r d -> Sem r d
insertState @d @err (forall (f :: * -> *) a. Applicative f => a -> f a
pure d
newState)
  AtomicState d (Sem r0) a
AtomicGet ->
    forall d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Stop err] r =>
Sem r d -> Sem r d
readState @d @err Sem r d
initial

-- |Interpret 'AtomicState' as a singleton table.
--
-- Given an action that produces an initial value, every action reads the value from the database and writes it
-- back.
interpretAtomicStateStore ::
  ∀ tag d err r .
  Members [QStore Maybe () d !! err, Lock @@ tag] r =>
  Sem (Stop err : r) d ->
  InterpreterFor (AtomicState d !! err) r
interpretAtomicStateStore :: forall {k} (tag :: k) d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Lock @@ tag] r =>
Sem (Stop err : r) d -> InterpreterFor (AtomicState d !! err) r
interpretAtomicStateStore Sem (Stop err : r) d
initial =
  forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
FirstOrder eff "interpretResumable" =>
(forall x (r0 :: EffectRow).
 eff (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumable (forall {k} (tag :: k) d err (r0 :: EffectRow) (r :: EffectRow) a.
Members '[QStore Maybe () d !! err, Lock @@ tag, Stop err] r =>
Sem r d -> AtomicState d (Sem r0) a -> Sem r a
handleAtomicStateStore Sem (Stop err : r) d
initial)

-- |Interpret 'AtomicState' as a singleton table.
--
-- Given an initial value, every action reads the value from the database and writes it back.
interpretAtomicStateStoreAs ::
  ∀ tag d err r .
  Members [QStore Maybe () d !! err, Lock @@ tag] r =>
  d ->
  InterpreterFor (AtomicState d !! err) r
interpretAtomicStateStoreAs :: forall {k} (tag :: k) d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Lock @@ tag] r =>
d -> InterpreterFor (AtomicState d !! err) r
interpretAtomicStateStoreAs d
value =
  forall {k} (tag :: k) d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Lock @@ tag] r =>
Sem (Stop err : r) d -> InterpreterFor (AtomicState d !! err) r
interpretAtomicStateStore (forall (f :: * -> *) a. Applicative f => a -> f a
pure d
value)

atomicStateScope ::
  Member (Scoped param (QStore Maybe () d !! err) !! err) r =>
  param ->
  (() -> Sem (QStore Maybe () d !! err : Stop err : r) a) ->
  Sem (Stop err : r) a
atomicStateScope :: forall param d err (r :: EffectRow) a.
Member (Scoped param (QStore Maybe () d !! err) !! err) r =>
param
-> (() -> Sem ((QStore Maybe () d !! err) : Stop err : r) a)
-> Sem (Stop err : r) a
atomicStateScope param
p () -> Sem ((QStore Maybe () d !! err) : Stop err : r) a
use =
  forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop (forall param (effect :: (* -> *) -> * -> *) (r :: EffectRow).
Member (Scoped param effect) r =>
param -> InterpreterFor effect r
scoped param
p (forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder (() -> Sem ((QStore Maybe () d !! err) : Stop err : r) a
use ())))

interpretAtomicStateStoreScoped ::
  ∀ tag param d err r .
  Members [Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
  Sem (Stop err : r) d ->
  InterpreterFor (Scoped param (AtomicState d !! err) !! err) r
interpretAtomicStateStoreScoped :: forall {k} (tag :: k) param d err (r :: EffectRow).
Members
  '[Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
Sem (Stop err : r) d
-> InterpreterFor (Scoped param (AtomicState d !! err) !! err) r
interpretAtomicStateStoreScoped Sem (Stop err : r) d
initial =
  forall (extra :: EffectRow) param resource
       (effect :: (* -> *) -> * -> *) eo ei (r :: EffectRow).
KnownList extra =>
(forall (q :: (* -> *) -> * -> *) x.
 param
 -> (resource -> Sem (extra ++ (Stop eo : Opaque q : r)) x)
 -> Sem (Stop eo : Opaque q : r) x)
-> (forall (q :: (* -> *) -> * -> *) (r0 :: EffectRow) x.
    resource
    -> effect (Sem r0) x
    -> Sem (Stop ei : (extra ++ (Stop eo : Opaque q : r))) x)
-> InterpreterFor (Scoped param (effect !! ei) !! eo) r
interpretScopedRWith @'[QStore Maybe () d !! err] forall param d err (r :: EffectRow) a.
Member (Scoped param (QStore Maybe () d !! err) !! err) r =>
param
-> (() -> Sem ((QStore Maybe () d !! err) : Stop err : r) a)
-> Sem (Stop err : r) a
atomicStateScope \ () ->
    forall {k} (tag :: k) d err (r0 :: EffectRow) (r :: EffectRow) a.
Members '[QStore Maybe () d !! err, Lock @@ tag, Stop err] r =>
Sem r d -> AtomicState d (Sem r0) a -> Sem r a
handleAtomicStateStore (forall (index :: Nat) (inserted :: EffectRow) (head :: EffectRow)
       (oldTail :: EffectRow) (tail :: EffectRow) (old :: EffectRow)
       (full :: EffectRow) a.
(ListOfLength index head, WhenStuck index InsertAtUnprovidedIndex,
 old ~ Append head oldTail, tail ~ Append inserted oldTail,
 full ~ Append head tail,
 InsertAtIndex index head tail oldTail full inserted) =>
Sem old a -> Sem full a
insertAt @1 Sem (Stop err : r) d
initial)

interpretAtomicStateStoreScopedAs ::
  ∀ tag param d err r .
  Members [Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
  d ->
  InterpreterFor (Scoped param (AtomicState d !! err) !! err) r
interpretAtomicStateStoreScopedAs :: forall {k} (tag :: k) param d err (r :: EffectRow).
Members
  '[Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
d -> InterpreterFor (Scoped param (AtomicState d !! err) !! err) r
interpretAtomicStateStoreScopedAs d
value =
  forall {k} (tag :: k) param d err (r :: EffectRow).
Members
  '[Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
Sem (Stop err : r) d
-> InterpreterFor (Scoped param (AtomicState d !! err) !! err) r
interpretAtomicStateStoreScoped (forall (f :: * -> *) a. Applicative f => a -> f a
pure d
value)

interpretAtomicStatesStore ::
  ∀ tag param d err r .
  Members [QStore Maybe () d !! err, Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
  Sem (Stop err : r) d ->
  InterpretersFor [AtomicState d !! err, Scoped param (AtomicState d !! err) !! err] r
interpretAtomicStatesStore :: forall {k} (tag :: k) param d err (r :: EffectRow).
Members
  '[QStore Maybe () d !! err,
    Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag]
  r =>
Sem (Stop err : r) d
-> InterpretersFor
     '[AtomicState d !! err, Scoped param (AtomicState d !! err) !! err]
     r
interpretAtomicStatesStore Sem (Stop err : r) d
initial =
  forall {k} (tag :: k) param d err (r :: EffectRow).
Members
  '[Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>
Sem (Stop err : r) d
-> InterpreterFor (Scoped param (AtomicState d !! err) !! err) r
interpretAtomicStateStoreScoped Sem (Stop err : r) d
initial forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall {k} (tag :: k) d err (r :: EffectRow).
Members '[QStore Maybe () d !! err, Lock @@ tag] r =>
Sem (Stop err : r) d -> InterpreterFor (AtomicState d !! err) r
interpretAtomicStateStore (forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder Sem (Stop err : r) d
initial)