-- | Support for accumulation of values in a thread local array.
--
-- @since 2.7.0.0
module Effectful.Output.Static.Local.Array
  ( -- * Effect
    Output

    -- ** Handlers
  , runOutput

    -- ** Operations
  , output

    -- * Re-exports
  , Array
  ) where

import Control.Monad.Primitive
import Data.Kind
import Data.Primitive.Array

import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive
import Effectful.Internal.Utils

-- | Provide access to accumulation of values of type @o@ in a thread local
-- array.
data Output (o :: Type) :: Effect

type instance DispatchOf (Output o) = Static NoSideEffects
data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o)

-- | Run the 'Output' effect and return the final value along with the
-- accumulated array.
runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
runOutput :: forall o (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
Eff (Output o : es) a -> Eff es (a, Array o)
runOutput = (StaticRep (Output o) -> IO (Array o))
-> Eff (Output o : es) a -> Eff es (a, Array o)
forall o acc (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
(StaticRep (Output o) -> IO acc)
-> Eff (Output o : es) a -> Eff es (a, acc)
runOutputImpl ((StaticRep (Output o) -> IO (Array o))
 -> Eff (Output o : es) a -> Eff es (a, Array o))
-> (StaticRep (Output o) -> IO (Array o))
-> Eff (Output o : es) a
-> Eff es (a, Array o)
forall a b. (a -> b) -> a -> b
$ \(Output Int
size MutableArray RealWorld o
arr) -> do
  MutableArray (PrimState IO) o -> Int -> Int -> IO (Array o)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> Int -> m (Array a)
freezeArray MutableArray RealWorld o
MutableArray (PrimState IO) o
arr Int
0 Int
size

-- | Append the value to the end of the array.
output
  :: (HasCallStack, Output o :> es)
  => o -- ^ The value.
  -> Eff es ()
output :: forall o (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, Output o :> es) =>
o -> Eff es ()
output !o
o = (Env es -> IO ()) -> Eff es ()
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO ()) -> Eff es ()) -> (Env es -> IO ()) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Output Int
size MutableArray RealWorld o
arr0 <- Env es -> IO (EffectRep (DispatchOf (Output o)) (Output o))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  let len0 :: Int
len0 = MutableArray RealWorld o -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld o
arr0
  MutableArray RealWorld o
arr <- case Int
size Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
len0 of
    Ordering
GT -> [Char] -> IO (MutableArray RealWorld o)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (MutableArray RealWorld o))
-> [Char] -> IO (MutableArray RealWorld o)
forall a b. (a -> b) -> a -> b
$ [Char]
"size (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
size [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") > len0 (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
len0 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    Ordering
LT -> MutableArray RealWorld o -> IO (MutableArray RealWorld o)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutableArray RealWorld o
arr0
    Ordering
EQ -> do
      let len :: Int
len = Int -> Int
growCapacity Int
len0
      MutableArray RealWorld o
arr <- Int -> o -> IO (MutableArray (PrimState IO) o)
forall (m :: Type -> Type) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
len o
forall a. HasCallStack => a
undefinedValue
      MutableArray (PrimState IO) o
-> Int -> MutableArray (PrimState IO) o -> Int -> Int -> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
MutableArray (PrimState m) a
-> Int -> MutableArray (PrimState m) a -> Int -> Int -> m ()
copyMutableArray MutableArray RealWorld o
MutableArray (PrimState IO) o
arr Int
0 MutableArray RealWorld o
MutableArray (PrimState IO) o
arr0 Int
0 Int
size
      MutableArray RealWorld o -> IO (MutableArray RealWorld o)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MutableArray RealWorld o
arr
  MutableArray (PrimState IO) o -> Int -> o -> IO ()
forall (m :: Type -> Type) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld o
MutableArray (PrimState IO) o
arr Int
size o
o
  Env es -> EffectRep (DispatchOf (Output o)) (Output o) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> EffectRep (DispatchOf e) e -> IO ()
putEnv Env es
es (EffectRep (DispatchOf (Output o)) (Output o) -> IO ())
-> EffectRep (DispatchOf (Output o)) (Output o) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> MutableArray RealWorld o -> StaticRep (Output o)
forall o. Int -> MutableArray RealWorld o -> StaticRep (Output o)
Output (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MutableArray RealWorld o
arr

----------------------------------------
-- Helpers

runOutputImpl
  :: HasCallStack
  => (StaticRep (Output o) -> IO acc)
  -> Eff (Output o : es) a
  -> Eff es (a, acc)
runOutputImpl :: forall o acc (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
(StaticRep (Output o) -> IO acc)
-> Eff (Output o : es) a -> Eff es (a, acc)
runOutputImpl StaticRep (Output o) -> IO acc
f Eff (Output o : es) a
action = (Env es -> IO (a, acc)) -> Eff es (a, acc)
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO (a, acc)) -> Eff es (a, acc))
-> (Env es -> IO (a, acc)) -> Eff es (a, acc)
forall a b. (a -> b) -> a -> b
$ \Env es
es0 -> do
  MutableArray RealWorld o
arr <- Int -> o -> IO (MutableArray (PrimState IO) o)
forall (m :: Type -> Type) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
0 o
forall a. HasCallStack => a
undefinedValue
  IO (Env (Output o : es))
-> (Env (Output o : es) -> IO ())
-> (Env (Output o : es) -> IO (a, acc))
-> IO (a, acc)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket
    (EffectRep (DispatchOf (Output o)) (Output o)
-> Relinker (EffectRep (DispatchOf (Output o))) (Output o)
-> Env es
-> IO (Env (Output o : es))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
HasCallStack =>
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
consEnv (Int -> MutableArray RealWorld o -> StaticRep (Output o)
forall o. Int -> MutableArray RealWorld o -> StaticRep (Output o)
Output Int
0 MutableArray RealWorld o
arr) Relinker (EffectRep (DispatchOf (Output o))) (Output o)
Relinker StaticRep (Output o)
forall {a}. Relinker StaticRep (Output a)
relinkOutput Env es
es0)
    Env (Output o : es) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
HasCallStack =>
Env (e : es) -> IO ()
unconsEnv
    (\Env (Output o : es)
es -> (,) (a -> acc -> (a, acc)) -> IO a -> IO (acc -> (a, acc))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff (Output o : es) a -> Env (Output o : es) -> IO a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff Eff (Output o : es) a
action Env (Output o : es)
es IO (acc -> (a, acc)) -> IO acc -> IO (a, acc)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (StaticRep (Output o) -> IO acc
f (StaticRep (Output o) -> IO acc)
-> IO (StaticRep (Output o)) -> IO acc
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env (Output o : es)
-> IO (EffectRep (DispatchOf (Output o)) (Output o))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env (Output o : es)
es))
  where
    relinkOutput :: Relinker StaticRep (Output a)
relinkOutput = (HasCallStack =>
 (forall (es :: [(Type -> Type) -> Type -> Type]).
  Env es -> IO (Env es))
 -> StaticRep (Output a) -> IO (StaticRep (Output a)))
-> Relinker StaticRep (Output a)
forall (a :: ((Type -> Type) -> Type -> Type) -> Type)
       (b :: (Type -> Type) -> Type -> Type).
(HasCallStack =>
 (forall (es :: [(Type -> Type) -> Type -> Type]).
  Env es -> IO (Env es))
 -> a b -> IO (a b))
-> Relinker a b
Relinker ((HasCallStack =>
  (forall (es :: [(Type -> Type) -> Type -> Type]).
   Env es -> IO (Env es))
  -> StaticRep (Output a) -> IO (StaticRep (Output a)))
 -> Relinker StaticRep (Output a))
-> (HasCallStack =>
    (forall (es :: [(Type -> Type) -> Type -> Type]).
     Env es -> IO (Env es))
    -> StaticRep (Output a) -> IO (StaticRep (Output a)))
-> Relinker StaticRep (Output a)
forall a b. (a -> b) -> a -> b
$ \forall (es :: [(Type -> Type) -> Type -> Type]).
Env es -> IO (Env es)
_ (Output Int
size MutableArray RealWorld a
arr0) -> do
      MutableArray RealWorld a
arr <- MutableArray (PrimState IO) a
-> Int -> Int -> IO (MutableArray (PrimState IO) a)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutableArray (PrimState m) a
-> Int -> Int -> m (MutableArray (PrimState m) a)
cloneMutableArray MutableArray RealWorld a
MutableArray (PrimState IO) a
arr0 Int
0 (MutableArray RealWorld a -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld a
arr0)
      StaticRep (Output a) -> IO (StaticRep (Output a))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (StaticRep (Output a) -> IO (StaticRep (Output a)))
-> StaticRep (Output a) -> IO (StaticRep (Output a))
forall a b. (a -> b) -> a -> b
$ Int -> MutableArray RealWorld a -> StaticRep (Output a)
forall o. Int -> MutableArray RealWorld o -> StaticRep (Output o)
Output Int
size MutableArray RealWorld a
arr

undefinedValue :: HasCallStack => a
undefinedValue :: forall a. HasCallStack => a
undefinedValue = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Undefined value"