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

{-# OPTIONS_GHC -Wno-orphans #-}

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

import           Control.Exception       hiding ( catch )
import           Control.Monad.Catch

import           Nix.Thunk
import           Nix.Utils
import           Nix.Var

data Deferred m v = Deferred (m v) | Computed 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)

-- | The type of very basic thunks
data NThunkF m v
    = Thunk (ThunkId m) (Var m Bool) (Var m (Deferred m v))

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

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

type MonadBasicThunk m = (MonadThunkId m, MonadVar m)

instance (MonadBasicThunk m, MonadCatch m)
  => MonadThunk (NThunkF m v) m v where
  thunk :: m v -> m (NThunkF m v)
thunk = m v -> m (NThunkF m v)
forall (m :: * -> *) v. MonadBasicThunk m => m v -> m (NThunkF m v)
buildThunk
  thunkId :: NThunkF m v -> ThunkId m
thunkId (Thunk n :: ThunkId m
n _ _) = ThunkId m
n
  queryM :: NThunkF m v -> m r -> (v -> m r) -> m r
queryM   = NThunkF m v -> m r -> (v -> m r) -> m r
forall (m :: * -> *) v a.
MonadVar m =>
NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk
  force :: NThunkF m v -> (v -> m r) -> m r
force    = NThunkF m v -> (v -> m r) -> m r
forall (m :: * -> *) v a.
(MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m)) =>
NThunkF m v -> (v -> m a) -> m a
forceThunk
  forceEff :: NThunkF m v -> (v -> m r) -> m r
forceEff = NThunkF m v -> (v -> m r) -> m r
forall (m :: * -> *) v r.
MonadVar m =>
NThunkF m v -> (v -> m r) -> m r
forceEffects
  further :: NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
further  = NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
forall (m :: * -> *) v.
MonadVar m =>
NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
furtherThunk

buildThunk :: MonadBasicThunk m => m v -> m (NThunkF m v)
buildThunk :: m v -> m (NThunkF m v)
buildThunk action :: m v
action = do
  ThunkId m
freshThunkId <- m (ThunkId m)
forall (m :: * -> *). MonadThunkId m => m (ThunkId m)
freshId
  ThunkId m -> Var m Bool -> Var m (Deferred m v) -> NThunkF m v
forall (m :: * -> *) v.
ThunkId m -> Var m Bool -> Var m (Deferred m v) -> NThunkF m v
Thunk ThunkId m
freshThunkId (Var m Bool -> Var m (Deferred m v) -> NThunkF m v)
-> m (Var m Bool) -> m (Var m (Deferred m v) -> NThunkF m v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> m (Var m Bool)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newVar Bool
False m (Var m (Deferred m v) -> NThunkF m v)
-> m (Var m (Deferred m v)) -> m (NThunkF m v)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Deferred m v -> m (Var m (Deferred 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)

queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk :: NThunkF m v -> m a -> (v -> m a) -> m a
queryThunk (Thunk _ active :: Var m Bool
active ref :: Var m (Deferred m v)
ref) n :: m a
n k :: v -> m a
k = do
  Bool
nowActive <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
True, )
  if Bool
nowActive
    then m a
n
    else do
      Deferred m v
eres <- Var m (Deferred m v) -> m (Deferred m v)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar Var m (Deferred m v)
ref
      a
res  <- case Deferred m v
eres of
        Computed v :: v
v -> v -> m a
k v
v
        _          -> m a
n
      Bool
_ <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
False, )
      a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

forceThunk
  :: forall m v a
   . (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m))
  => NThunkF m v
  -> (v -> m a)
  -> m a
forceThunk :: NThunkF m v -> (v -> m a) -> m a
forceThunk (Thunk n :: ThunkId m
n active :: Var m Bool
active ref :: Var m (Deferred m v)
ref) k :: v -> m a
k = do
  Deferred m v
eres <- Var m (Deferred m v) -> m (Deferred m v)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar Var m (Deferred m v)
ref
  case Deferred m v
eres of
    Computed v :: v
v      -> v -> m a
k v
v
    Deferred action :: m v
action -> do
      Bool
nowActive <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
True, )
      if Bool
nowActive
        then 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
$ String -> ThunkLoop
ThunkLoop (String -> ThunkLoop) -> String -> ThunkLoop
forall a b. (a -> b) -> a -> b
$ ThunkId m -> String
forall a. Show a => a -> String
show ThunkId m
n
        else do
          String -> m ()
forall (m :: * -> *). Monad m => String -> m ()
traceM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "Forcing " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ThunkId m -> String
forall a. Show a => a -> String
show ThunkId m
n
          v
v <- m v -> (SomeException -> m v) -> m v
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch m v
action ((SomeException -> m v) -> m v) -> (SomeException -> m v) -> m v
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> do
            Bool
_ <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
False, )
            SomeException -> m v
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
          Bool
_ <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
False, )
          Var m (Deferred m v) -> Deferred m v -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar Var m (Deferred m v)
ref (v -> Deferred m v
forall (m :: * -> *) v. v -> Deferred m v
Computed v
v)
          v -> m a
k v
v

forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r
forceEffects :: NThunkF m v -> (v -> m r) -> m r
forceEffects (Thunk _ active :: Var m Bool
active ref :: Var m (Deferred m v)
ref) k :: v -> m r
k = do
  Bool
nowActive <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
True, )
  if Bool
nowActive
    then r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> m r) -> r -> m r
forall a b. (a -> b) -> a -> b
$ String -> r
forall a. HasCallStack => String -> a
error "Loop detected"
    else do
      Deferred m v
eres <- Var m (Deferred m v) -> m (Deferred m v)
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar Var m (Deferred m v)
ref
      case Deferred m v
eres of
        Computed v :: v
v      -> v -> m r
k v
v
        Deferred action :: m v
action -> do
          v
v <- m v
action
          Var m (Deferred m v) -> Deferred m v -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar Var m (Deferred m v)
ref (v -> Deferred m v
forall (m :: * -> *) v. v -> Deferred m v
Computed v
v)
          Bool
_ <- Var m Bool -> (Bool -> (Bool, Bool)) -> m Bool
forall (m :: * -> *) a b.
MonadAtomicRef m =>
Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar Var m Bool
active (Bool
False, )
          v -> m r
k v
v

furtherThunk :: MonadVar m => NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
furtherThunk :: NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
furtherThunk t :: NThunkF m v
t@(Thunk _ _ ref :: Var m (Deferred m v)
ref) k :: m v -> m v
k = do
  Deferred m v
_ <- Var m (Deferred 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 Var m (Deferred 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
$ \x :: Deferred m v
x -> case Deferred m v
x of
    Computed _ -> (Deferred m v
x, Deferred m v
x)
    Deferred d :: 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)
  NThunkF m v -> m (NThunkF m v)
forall (m :: * -> *) a. Monad m => a -> m a
return NThunkF m v
t