{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs #-}



module Nix.Thunk.Basic
  ( NThunkF(..)
  , Deferred(..)
  , MonadBasicThunk
  ) where

import           Prelude                 hiding ( force )
import           Relude.Extra                   ( dup )
import           Control.Monad.Catch            ( MonadCatch(..)
                                                , MonadThrow(throwM)
                                                )
import qualified Text.Show
import           Nix.Thunk
import           Nix.Var


-- * Data type @Deferred@

-- | Data is computed OR in a lazy thunk state which
-- is still not evaluated.
data Deferred m v = Computed v | Deferred (m v)
  deriving (a -> Deferred m b -> Deferred m a
(a -> b) -> Deferred m a -> Deferred m b
(forall a b. (a -> b) -> Deferred m a -> Deferred m b)
-> (forall a b. a -> Deferred m b -> Deferred m a)
-> Functor (Deferred m)
forall a b. a -> Deferred m b -> Deferred m a
forall a b. (a -> b) -> Deferred m a -> Deferred m b
forall (m :: * -> *) a b.
Functor m =>
a -> Deferred m b -> Deferred m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Deferred m a -> Deferred m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Deferred m b -> Deferred m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Deferred m b -> Deferred m a
fmap :: (a -> b) -> Deferred m a -> Deferred m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Deferred m a -> Deferred m b
Functor, Deferred m a -> Bool
(a -> m) -> Deferred m a -> m
(a -> b -> b) -> b -> Deferred m a -> b
(forall m. Monoid m => Deferred m m -> m)
-> (forall m a. Monoid m => (a -> m) -> Deferred m a -> m)
-> (forall m a. Monoid m => (a -> m) -> Deferred m a -> m)
-> (forall a b. (a -> b -> b) -> b -> Deferred m a -> b)
-> (forall a b. (a -> b -> b) -> b -> Deferred m a -> b)
-> (forall b a. (b -> a -> b) -> b -> Deferred m a -> b)
-> (forall b a. (b -> a -> b) -> b -> Deferred m a -> b)
-> (forall a. (a -> a -> a) -> Deferred m a -> a)
-> (forall a. (a -> a -> a) -> Deferred m a -> a)
-> (forall a. Deferred m a -> [a])
-> (forall a. Deferred m a -> Bool)
-> (forall a. Deferred m a -> Int)
-> (forall a. Eq a => a -> Deferred m a -> Bool)
-> (forall a. Ord a => Deferred m a -> a)
-> (forall a. Ord a => Deferred m a -> a)
-> (forall a. Num a => Deferred m a -> a)
-> (forall a. Num a => Deferred m a -> a)
-> Foldable (Deferred m)
forall a. Eq a => a -> Deferred m a -> Bool
forall a. Num a => Deferred m a -> a
forall a. Ord a => Deferred m a -> a
forall m. Monoid m => Deferred m m -> m
forall a. Deferred m a -> Bool
forall a. Deferred m a -> Int
forall a. Deferred m a -> [a]
forall a. (a -> a -> a) -> Deferred m a -> a
forall m a. Monoid m => (a -> m) -> Deferred m a -> m
forall b a. (b -> a -> b) -> b -> Deferred m a -> b
forall a b. (a -> b -> b) -> b -> Deferred m a -> b
forall (m :: * -> *) a.
(Foldable m, Eq a) =>
a -> Deferred m a -> Bool
forall (m :: * -> *) a. (Foldable m, Num a) => Deferred m a -> a
forall (m :: * -> *) a. (Foldable m, Ord a) => Deferred m a -> a
forall (m :: * -> *) m. (Foldable m, Monoid m) => Deferred m m -> m
forall (m :: * -> *) a. Foldable m => Deferred m a -> Bool
forall (m :: * -> *) a. Foldable m => Deferred m a -> Int
forall (m :: * -> *) a. Foldable m => Deferred m a -> [a]
forall (m :: * -> *) a.
Foldable m =>
(a -> a -> a) -> Deferred m a -> a
forall (m :: * -> *) m a.
(Foldable m, Monoid m) =>
(a -> m) -> Deferred m a -> m
forall (m :: * -> *) b a.
Foldable m =>
(b -> a -> b) -> b -> Deferred m a -> b
forall (m :: * -> *) a b.
Foldable m =>
(a -> b -> b) -> b -> Deferred m a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Deferred m a -> a
$cproduct :: forall (m :: * -> *) a. (Foldable m, Num a) => Deferred m a -> a
sum :: Deferred m a -> a
$csum :: forall (m :: * -> *) a. (Foldable m, Num a) => Deferred m a -> a
minimum :: Deferred m a -> a
$cminimum :: forall (m :: * -> *) a. (Foldable m, Ord a) => Deferred m a -> a
maximum :: Deferred m a -> a
$cmaximum :: forall (m :: * -> *) a. (Foldable m, Ord a) => Deferred m a -> a
elem :: a -> Deferred m a -> Bool
$celem :: forall (m :: * -> *) a.
(Foldable m, Eq a) =>
a -> Deferred m a -> Bool
length :: Deferred m a -> Int
$clength :: forall (m :: * -> *) a. Foldable m => Deferred m a -> Int
null :: Deferred m a -> Bool
$cnull :: forall (m :: * -> *) a. Foldable m => Deferred m a -> Bool
toList :: Deferred m a -> [a]
$ctoList :: forall (m :: * -> *) a. Foldable m => Deferred m a -> [a]
foldl1 :: (a -> a -> a) -> Deferred m a -> a
$cfoldl1 :: forall (m :: * -> *) a.
Foldable m =>
(a -> a -> a) -> Deferred m a -> a
foldr1 :: (a -> a -> a) -> Deferred m a -> a
$cfoldr1 :: forall (m :: * -> *) a.
Foldable m =>
(a -> a -> a) -> Deferred m a -> a
foldl' :: (b -> a -> b) -> b -> Deferred m a -> b
$cfoldl' :: forall (m :: * -> *) b a.
Foldable m =>
(b -> a -> b) -> b -> Deferred m a -> b
foldl :: (b -> a -> b) -> b -> Deferred m a -> b
$cfoldl :: forall (m :: * -> *) b a.
Foldable m =>
(b -> a -> b) -> b -> Deferred m a -> b
foldr' :: (a -> b -> b) -> b -> Deferred m a -> b
$cfoldr' :: forall (m :: * -> *) a b.
Foldable m =>
(a -> b -> b) -> b -> Deferred m a -> b
foldr :: (a -> b -> b) -> b -> Deferred m a -> b
$cfoldr :: forall (m :: * -> *) a b.
Foldable m =>
(a -> b -> b) -> b -> Deferred m a -> b
foldMap' :: (a -> m) -> Deferred m a -> m
$cfoldMap' :: forall (m :: * -> *) m a.
(Foldable m, Monoid m) =>
(a -> m) -> Deferred m a -> m
foldMap :: (a -> m) -> Deferred m a -> m
$cfoldMap :: forall (m :: * -> *) m a.
(Foldable m, Monoid m) =>
(a -> m) -> Deferred m a -> m
fold :: Deferred m m -> m
$cfold :: forall (m :: * -> *) m. (Foldable m, Monoid m) => Deferred m m -> m
Foldable, Functor (Deferred m)
Foldable (Deferred m)
Functor (Deferred m)
-> Foldable (Deferred m)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Deferred m a -> f (Deferred m b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Deferred m (f a) -> f (Deferred m a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Deferred m a -> m (Deferred m b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Deferred m (m a) -> m (Deferred m a))
-> Traversable (Deferred m)
(a -> f b) -> Deferred m a -> f (Deferred m b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *). Traversable m => Functor (Deferred m)
forall (m :: * -> *). Traversable m => Foldable (Deferred m)
forall (m :: * -> *) (m :: * -> *) a.
(Traversable m, Monad m) =>
Deferred m (m a) -> m (Deferred m a)
forall (m :: * -> *) (f :: * -> *) a.
(Traversable m, Applicative f) =>
Deferred m (f a) -> f (Deferred m a)
forall (m :: * -> *) (m :: * -> *) a b.
(Traversable m, Monad m) =>
(a -> m b) -> Deferred m a -> m (Deferred m b)
forall (m :: * -> *) (f :: * -> *) a b.
(Traversable m, Applicative f) =>
(a -> f b) -> Deferred m a -> f (Deferred m b)
forall (m :: * -> *) a.
Monad m =>
Deferred m (m a) -> m (Deferred m a)
forall (f :: * -> *) a.
Applicative f =>
Deferred m (f a) -> f (Deferred m a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Deferred m a -> m (Deferred m b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Deferred m a -> f (Deferred m b)
sequence :: Deferred m (m a) -> m (Deferred m a)
$csequence :: forall (m :: * -> *) (m :: * -> *) a.
(Traversable m, Monad m) =>
Deferred m (m a) -> m (Deferred m a)
mapM :: (a -> m b) -> Deferred m a -> m (Deferred m b)
$cmapM :: forall (m :: * -> *) (m :: * -> *) a b.
(Traversable m, Monad m) =>
(a -> m b) -> Deferred m a -> m (Deferred m b)
sequenceA :: Deferred m (f a) -> f (Deferred m a)
$csequenceA :: forall (m :: * -> *) (f :: * -> *) a.
(Traversable m, Applicative f) =>
Deferred m (f a) -> f (Deferred m a)
traverse :: (a -> f b) -> Deferred m a -> f (Deferred m b)
$ctraverse :: forall (m :: * -> *) (f :: * -> *) a b.
(Traversable m, Applicative f) =>
(a -> f b) -> Deferred m a -> f (Deferred m b)
$cp2Traversable :: forall (m :: * -> *). Traversable m => Foldable (Deferred m)
$cp1Traversable :: forall (m :: * -> *). Traversable m => Functor (Deferred m)
Traversable)

-- ** Utils

-- | Apply second if @Deferred@, otherwise (@Computed@) - apply first.
-- Analog of @either@ for @Deferred = Computed|Deferred@.
deferred :: (v -> b) -> (m v -> b) -> Deferred m v -> b
deferred :: (v -> b) -> (m v -> b) -> Deferred m v -> b
deferred v -> b
f1 m v -> b
f2 Deferred m v
def =
  case Deferred m v
def of
    Computed v
v -> v -> b
f1 v
v
    Deferred m v
action -> m v -> b
f2 m v
action
{-# inline deferred #-}


-- * Thunk references & lock handling

-- | Thunk resource reference (@ref-tf: Ref m@), and as such also also hold
-- a @Bool@ lock flag.
type ThunkRef m = (Var m Bool)

-- | Reference (@ref-tf: Ref m v@) to a value that the thunk holds.
type ThunkValueRef m v = Var m (Deferred m v)

-- | @ref-tf@ lock instruction for @Ref m@ (@ThunkRef@).
lock :: Bool -> (Bool, Bool)
lock :: Bool -> (Bool, Bool)
lock = (Bool
True, )

-- | @ref-tf@ unlock instruction for @Ref m@ (@ThunkRef@).
unlock :: Bool -> (Bool, Bool)
unlock :: Bool -> (Bool, Bool)
unlock = (Bool
False, )

-- | Takes @ref-tf: Ref m@ reference, returns Bool result of the operation.
lockThunk
  :: ( MonadBasicThunk m
    , MonadCatch m
    )
  => ThunkRef m
  -> m Bool
lockThunk :: ThunkRef m -> m Bool
lockThunk ThunkRef m
r = ThunkRef m -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar ThunkRef m
r Bool -> (Bool, Bool)
lock

-- | Takes @ref-tf: Ref m@ reference, returns Bool result of the operation.
unlockThunk
  :: ( MonadBasicThunk m
    , MonadCatch m
    )
  => ThunkRef m
  -> m Bool
unlockThunk :: ThunkRef m -> m Bool
unlockThunk ThunkRef m
r = ThunkRef m -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar ThunkRef m
r Bool -> (Bool, Bool)
unlock


-- * Data type for thunks: @NThunkF@

-- | The type of very basic thunks
data NThunkF m v
  = Thunk (ThunkId m) (ThunkRef m) (ThunkValueRef m v)

instance (Eq v, Eq (ThunkId m)) => Eq (NThunkF m v) where
  Thunk ThunkId m
x ThunkRef m
_ ThunkValueRef m v
_ == :: NThunkF m v -> NThunkF m v -> Bool
== Thunk ThunkId m
y ThunkRef m
_ ThunkValueRef m v
_ = ThunkId m
x ThunkId m -> ThunkId m -> Bool
forall a. Eq a => a -> a -> Bool
== ThunkId m
y

instance Show (NThunkF m v) where
  show :: NThunkF m v -> String
show Thunk{} = String
"<thunk>"

type MonadBasicThunk m = (MonadThunkId m, MonadVar m)


-- ** @instance MonadThunk NThunkF@

instance (MonadBasicThunk m, MonadCatch m)
  => MonadThunk (NThunkF m v) m v where

  -- | Return thunk ID
  thunkId :: NThunkF m v -> ThunkId m
  thunkId :: NThunkF m v -> ThunkId m
thunkId (Thunk ThunkId m
n ThunkRef m
_ ThunkValueRef m v
_) = ThunkId m
n

  -- | Create new thunk
  thunk :: m v -> m (NThunkF m v)
  thunk :: m v -> m (NThunkF m v)
thunk m v
action =
    do
      ThunkId m
freshThunkId <- m (ThunkId m)
forall (m :: * -> *). MonadThunkId m => m (ThunkId m)
freshId
      ThunkId m -> ThunkRef m -> ThunkValueRef m v -> NThunkF m v
forall (m :: * -> *) v.
ThunkId m -> ThunkRef m -> ThunkValueRef m v -> NThunkF m v
Thunk ThunkId m
freshThunkId (ThunkRef m -> ThunkValueRef m v -> NThunkF m v)
-> m (ThunkRef m) -> m (ThunkValueRef m v -> NThunkF m v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> m (ThunkRef m)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newVar Bool
False m (ThunkValueRef m v -> NThunkF m v)
-> m (ThunkValueRef m v) -> m (NThunkF m v)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Deferred m v -> m (ThunkValueRef m v)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newVar (m v -> Deferred m v
forall (m :: * -> *) v. m v -> Deferred m v
Deferred m v
action)

  -- | Non-blocking query, return value if @Computed@,
  -- return first argument otherwise.
  queryM :: m v -> NThunkF m v -> m v
  queryM :: m v -> NThunkF m v -> m v
queryM m v
n (Thunk ThunkId m
_ ThunkRef m
_ ThunkValueRef m v
ref) =
    do
      (v -> m v) -> (m v -> m v) -> Deferred m v -> m v
forall v b (m :: * -> *).
(v -> b) -> (m v -> b) -> Deferred m v -> b
deferred
        v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (m v -> m v -> m v
forall a b. a -> b -> a
const m v
n)
        (Deferred m v -> m v) -> m (Deferred m v) -> m v
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ThunkValueRef m v -> m (Deferred m v)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar ThunkValueRef m v
ref

  force :: NThunkF m v -> m v
  force :: NThunkF m v -> m v
force = NThunkF m v -> m v
forall (m :: * -> *) v.
(MonadBasicThunk m, MonadCatch m) =>
NThunkF m v -> m v
forceMain

  forceEff :: NThunkF m v -> m v
  forceEff :: NThunkF m v -> m v
forceEff = NThunkF m v -> m v
forall (m :: * -> *) v.
(MonadBasicThunk m, MonadCatch m) =>
NThunkF m v -> m v
forceMain

  further :: NThunkF m v -> m (NThunkF m v)
  further :: NThunkF m v -> m (NThunkF m v)
further t :: NThunkF m v
t@(Thunk ThunkId m
_ ThunkRef m
_ ThunkValueRef m v
ref) =
    do
      Deferred m v
_ <-
        ThunkValueRef m v
-> (Deferred m v -> (Deferred m v, Deferred m v))
-> m (Deferred m v)
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar
          ThunkValueRef m v
ref
          Deferred m v -> (Deferred m v, Deferred m v)
forall a. a -> (a, a)
dup
      pure NThunkF m v
t


-- *** United body of `force*`

-- | If @m v@ is @Computed@ - returns is
forceMain
  :: ( MonadBasicThunk m
    , MonadCatch m
    )
  => NThunkF m v
  -> m v
forceMain :: NThunkF m v -> m v
forceMain (Thunk ThunkId m
n ThunkRef m
thunkRef ThunkValueRef m v
thunkValRef) =
  (v -> m v) -> (m v -> m v) -> Deferred m v -> m v
forall v b (m :: * -> *).
(v -> b) -> (m v -> b) -> Deferred m v -> b
deferred
    v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (\ m v
action ->
      do
        Bool
lockedIt <- ThunkRef m -> m Bool
forall (m :: * -> *).
(MonadBasicThunk m, MonadCatch m) =>
ThunkRef m -> m Bool
lockThunk ThunkRef m
thunkRef
        m v -> m v -> Bool -> m v
forall a. a -> a -> Bool -> a
bool
          m v
forall a. m a
lockFailed
          (do
            v
v <- m v
action m v -> (SomeException -> m v) -> m v
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m v
forall b. SomeException -> m b
actionFailed
            ThunkValueRef m v -> Deferred m v -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar ThunkValueRef m v
thunkValRef (v -> Deferred m v
forall (m :: * -> *) v. v -> Deferred m v
Computed v
v)
            Bool
_unlockedIt <- ThunkRef m -> m Bool
forall (m :: * -> *).
(MonadBasicThunk m, MonadCatch m) =>
ThunkRef m -> m Bool
unlockThunk ThunkRef m
thunkRef
            pure v
v
          )
          (Bool -> Bool
not Bool
lockedIt)
    )
    (Deferred m v -> m v) -> m (Deferred m v) -> m v
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ThunkValueRef m v -> m (Deferred m v)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar ThunkValueRef m v
thunkValRef
 where
  lockFailed :: m a
lockFailed = ThunkLoop -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ThunkLoop -> m a) -> ThunkLoop -> m a
forall a b. (a -> b) -> a -> b
$ Text -> ThunkLoop
ThunkLoop (Text -> ThunkLoop) -> Text -> ThunkLoop
forall a b. (a -> b) -> a -> b
$ ThunkId m -> Text
forall b a. (Show a, IsString b) => a -> b
show ThunkId m
n

  actionFailed :: SomeException -> m b
actionFailed (SomeException
e :: SomeException) =
    do
      Bool
_unlockedIt <- ThunkRef m -> m Bool
forall (m :: * -> *).
(MonadBasicThunk m, MonadCatch m) =>
ThunkRef m -> m Bool
unlockThunk ThunkRef m
thunkRef
      SomeException -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e

{-# inline forceMain #-} -- it is big function, but internal, and look at its use.



-- ** Kleisli functor HOFs: @instance MonadThunkF NThunkF@

instance (MonadBasicThunk m, MonadCatch m)
  => MonadThunkF (NThunkF m v) m v where

  queryMF
    :: (v -> m r)
    -> m r
    -> NThunkF m v
    -> m r
  queryMF :: (v -> m r) -> m r -> NThunkF m v -> m r
queryMF v -> m r
k m r
n (Thunk ThunkId m
_ ThunkRef m
thunkRef ThunkValueRef m v
thunkValRef) =
    do
      Bool
lockedIt <- ThunkRef m -> m Bool
forall (m :: * -> *).
(MonadBasicThunk m, MonadCatch m) =>
ThunkRef m -> m Bool
lockThunk ThunkRef m
thunkRef
      m r -> m r -> Bool -> m r
forall a. a -> a -> Bool -> a
bool
        m r
n
        m r
go
        (Bool -> Bool
not Bool
lockedIt)
    where
      go :: m r
go =
        do
          Deferred m v
eres <- ThunkValueRef m v -> m (Deferred m v)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar ThunkValueRef m v
thunkValRef
          r
res  <-
            (v -> m r) -> (m v -> m r) -> Deferred m v -> m r
forall v b (m :: * -> *).
(v -> b) -> (m v -> b) -> Deferred m v -> b
deferred
              v -> m r
k
              (m r -> m v -> m r
forall a b. a -> b -> a
const m r
n)
              Deferred m v
eres
          Bool
_unlockedIt <- ThunkRef m -> m Bool
forall (m :: * -> *).
(MonadBasicThunk m, MonadCatch m) =>
ThunkRef m -> m Bool
unlockThunk ThunkRef m
thunkRef
          pure r
res

  forceF
    :: (v -> m a)
    -> NThunkF m v
    -> m a
  forceF :: (v -> m a) -> NThunkF m v -> m a
forceF v -> m a
k = v -> m a
k (v -> m a) -> (NThunkF m v -> m v) -> NThunkF m v -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NThunkF m v -> m v
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force

  forceEffF
    :: (v -> m r)
    -> NThunkF m v
    -> m r
  forceEffF :: (v -> m r) -> NThunkF m v -> m r
forceEffF v -> m r
k = v -> m r
k (v -> m r) -> (NThunkF m v -> m v) -> NThunkF m v -> m r
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NThunkF m v -> m v
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
forceEff

  furtherF
    :: (m v -> m v)
    -> NThunkF m v
    -> m (NThunkF m v)
  furtherF :: (m v -> m v) -> NThunkF m v -> m (NThunkF m v)
furtherF m v -> m v
k t :: NThunkF m v
t@(Thunk ThunkId m
_ ThunkRef m
_ ThunkValueRef m v
ref) =
    do
      Deferred m v
_modifiedIt <- ThunkValueRef m v
-> (Deferred m v -> (Deferred m v, Deferred m v))
-> m (Deferred m v)
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar ThunkValueRef m v
ref ((Deferred m v -> (Deferred m v, Deferred m v))
 -> m (Deferred m v))
-> (Deferred m v -> (Deferred m v, Deferred m v))
-> m (Deferred m v)
forall a b. (a -> b) -> a -> b
$
        \Deferred m v
x ->
          (v -> (Deferred m v, Deferred m v))
-> (m v -> (Deferred m v, Deferred m v))
-> Deferred m v
-> (Deferred m v, Deferred m v)
forall v b (m :: * -> *).
(v -> b) -> (m v -> b) -> Deferred m v -> b
deferred
            ((Deferred m v, Deferred m v) -> v -> (Deferred m v, Deferred m v)
forall a b. a -> b -> a
const (Deferred m v
x, Deferred m v
x))
            (\ m v
d -> (m v -> Deferred m v
forall (m :: * -> *) v. m v -> Deferred m v
Deferred (m v -> m v
k m v
d), Deferred m v
x))
            Deferred m v
x
      pure NThunkF m v
t