{-# LANGUAGE ExistentialQuantification #-}

module Development.Shake.Internal.Core.Rendezvous(
    Waiting, newWaiting, afterWaiting,
    Answer(..), Compute(..),
    rendezvous
    ) where

import Control.Monad
import Data.IORef.Extra
import Data.Primitive.Array
import Development.Shake.Internal.Errors


-- | Given a sequence of 'Answer' values the sequence stops
--   when there is a single 'Abort' or all values end up as 'Continue'.
data Answer a c
    = Abort a
    | Continue c

-- | A compuation that either has a result available immediate,
--   or has a result that can be collected later.
data Compute a
    = Now a
    | Later (Waiting a)

partitionAnswer :: [Answer a c] -> ([a], [c])
partitionAnswer :: [Answer a c] -> ([a], [c])
partitionAnswer = (Answer a c -> ([a], [c]) -> ([a], [c]))
-> ([a], [c]) -> [Answer a c] -> ([a], [c])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Answer a c -> ([a], [c]) -> ([a], [c])
forall a a. Answer a a -> ([a], [a]) -> ([a], [a])
f ([],[])
    where f :: Answer a a -> ([a], [a]) -> ([a], [a])
f (Abort    a :: a
a) ~(as :: [a]
as,cs :: [a]
cs) = (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as,[a]
cs)
          f (Continue c :: a
c) ~(as :: [a]
as,cs :: [a]
cs) = ([a]
as,a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
cs)

partitionCompute :: [Compute a] -> ([a], [Waiting a])
partitionCompute :: [Compute a] -> ([a], [Waiting a])
partitionCompute = (Compute a -> ([a], [Waiting a]) -> ([a], [Waiting a]))
-> ([a], [Waiting a]) -> [Compute a] -> ([a], [Waiting a])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Compute a -> ([a], [Waiting a]) -> ([a], [Waiting a])
forall a. Compute a -> ([a], [Waiting a]) -> ([a], [Waiting a])
f ([],[])
    where f :: Compute a -> ([a], [Waiting a]) -> ([a], [Waiting a])
f (Now   x :: a
x) ~(xs :: [a]
xs,ws :: [Waiting a]
ws) = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs,[Waiting a]
ws)
          f (Later w :: Waiting a
w) ~(xs :: [a]
xs,ws :: [Waiting a]
ws) = ([a]
xs,Waiting a
wWaiting a -> [Waiting a] -> [Waiting a]
forall a. a -> [a] -> [a]
:[Waiting a]
ws)


-- | A type representing someone waiting for a result.
data Waiting a = forall b . Waiting (b -> a) (IORef (b -> IO ()))
    -- Contains a functor value to apply, along with somewhere to register callbacks

instance Functor Waiting where
    fmap :: (a -> b) -> Waiting a -> Waiting b
fmap f :: a -> b
f (Waiting op :: b -> a
op ref :: IORef (b -> IO ())
ref) = (b -> b) -> IORef (b -> IO ()) -> Waiting b
forall a b. (b -> a) -> IORef (b -> IO ()) -> Waiting a
Waiting (a -> b
f (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
op) IORef (b -> IO ())
ref

instance Show (Waiting a) where
    show :: Waiting a -> String
show _ = "Waiting"


newWaiting :: IO (Waiting a, a -> IO ())
newWaiting :: IO (Waiting a, a -> IO ())
newWaiting = do
    IORef (a -> IO ())
ref <- (a -> IO ()) -> IO (IORef (a -> IO ()))
forall a. a -> IO (IORef a)
newIORef ((a -> IO ()) -> IO (IORef (a -> IO ())))
-> (a -> IO ()) -> IO (IORef (a -> IO ()))
forall a b. (a -> b) -> a -> b
$ \_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    let run :: a -> IO ()
run x :: a
x = ((a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
x) ((a -> IO ()) -> IO ()) -> IO (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (a -> IO ()) -> IO (a -> IO ())
forall a. IORef a -> IO a
readIORef IORef (a -> IO ())
ref
    (Waiting a, a -> IO ()) -> IO (Waiting a, a -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> a) -> IORef (a -> IO ()) -> Waiting a
forall a b. (b -> a) -> IORef (b -> IO ()) -> Waiting a
Waiting a -> a
forall a. a -> a
id IORef (a -> IO ())
ref, a -> IO ()
run)

afterWaiting :: Waiting a -> (a -> IO ()) -> IO ()
afterWaiting :: Waiting a -> (a -> IO ()) -> IO ()
afterWaiting (Waiting op :: b -> a
op ref :: IORef (b -> IO ())
ref) act :: a -> IO ()
act = IORef (b -> IO ()) -> ((b -> IO ()) -> b -> IO ()) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (b -> IO ())
ref (\a :: b -> IO ()
a s :: b
s -> b -> IO ()
a b
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
act (b -> a
op b
s))


rendezvous :: [Compute (Answer a c)] -> IO (Compute (Either a [c]))
rendezvous :: [Compute (Answer a c)] -> IO (Compute (Either a [c]))
rendezvous xs :: [Compute (Answer a c)]
xs = do
    let (now :: [Answer a c]
now, later :: [Waiting (Answer a c)]
later) = [Compute (Answer a c)] -> ([Answer a c], [Waiting (Answer a c)])
forall a. [Compute a] -> ([a], [Waiting a])
partitionCompute [Compute (Answer a c)]
xs
    let (abort :: [a]
abort, continue :: [c]
continue) = [Answer a c] -> ([a], [c])
forall a c. [Answer a c] -> ([a], [c])
partitionAnswer [Answer a c]
now
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
abort then
        Compute (Either a [c]) -> IO (Compute (Either a [c]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Compute (Either a [c]) -> IO (Compute (Either a [c])))
-> Compute (Either a [c]) -> IO (Compute (Either a [c]))
forall a b. (a -> b) -> a -> b
$ Either a [c] -> Compute (Either a [c])
forall a. a -> Compute a
Now (Either a [c] -> Compute (Either a [c]))
-> Either a [c] -> Compute (Either a [c])
forall a b. (a -> b) -> a -> b
$ a -> Either a [c]
forall a b. a -> Either a b
Left (a -> Either a [c]) -> a -> Either a [c]
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
head [a]
abort
     else if [Waiting (Answer a c)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Waiting (Answer a c)]
later then
        Compute (Either a [c]) -> IO (Compute (Either a [c]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Compute (Either a [c]) -> IO (Compute (Either a [c])))
-> Compute (Either a [c]) -> IO (Compute (Either a [c]))
forall a b. (a -> b) -> a -> b
$ Either a [c] -> Compute (Either a [c])
forall a. a -> Compute a
Now (Either a [c] -> Compute (Either a [c]))
-> Either a [c] -> Compute (Either a [c])
forall a b. (a -> b) -> a -> b
$ [c] -> Either a [c]
forall a b. b -> Either a b
Right [c]
continue
     else do
        (waiting :: Waiting (Either a [c])
waiting, run :: Either a [c] -> IO ()
run) <- IO (Waiting (Either a [c]), Either a [c] -> IO ())
forall a. IO (Waiting a, a -> IO ())
newWaiting
        let n :: Int
n = [Compute (Answer a c)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Compute (Answer a c)]
xs
        MutableArray RealWorld c
result <- Int -> c -> IO (MutableArray (PrimState IO) c)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
n (c -> IO (MutableArray RealWorld c))
-> c -> IO (MutableArray RealWorld c)
forall a b. (a -> b) -> a -> b
$ String -> c
forall a. String -> a
errorInternal "rendezvous"
        IORef Int
todo <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int)) -> Int -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ [Waiting (Answer a c)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Waiting (Answer a c)]
later
        [(Int, Compute (Answer a c))]
-> ((Int, Compute (Answer a c)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Compute (Answer a c)] -> [(Int, Compute (Answer a c))]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Compute (Answer a c)]
xs) (((Int, Compute (Answer a c)) -> IO ()) -> IO ())
-> ((Int, Compute (Answer a c)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i,x :: Compute (Answer a c)
x) -> case Compute (Answer a c)
x of
            Now (Continue c :: c
c) -> MutableArray (PrimState IO) c -> Int -> c -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld c
MutableArray (PrimState IO) c
result Int
i c
c
            Later w :: Waiting (Answer a c)
w -> Waiting (Answer a c) -> (Answer a c -> IO ()) -> IO ()
forall a. Waiting a -> (a -> IO ()) -> IO ()
afterWaiting Waiting (Answer a c)
w ((Answer a c -> IO ()) -> IO ()) -> (Answer a c -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \v :: Answer a c
v -> do
                Int
t <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
todo
                case Answer a c
v of
                    _ | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- must have already aborted
                    Abort a :: a
a -> do
                        IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
todo 0
                        Either a [c] -> IO ()
run (Either a [c] -> IO ()) -> Either a [c] -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Either a [c]
forall a b. a -> Either a b
Left a
a
                    Continue c :: c
c -> do
                        MutableArray (PrimState IO) c -> Int -> c -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld c
MutableArray (PrimState IO) c
result Int
i c
c
                        IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef Int
todo (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-1
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Array c
rs <- MutableArray (PrimState IO) c -> IO (Array c)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
unsafeFreezeArray MutableArray RealWorld c
MutableArray (PrimState IO) c
result
                            Either a [c] -> IO ()
run (Either a [c] -> IO ()) -> Either a [c] -> IO ()
forall a b. (a -> b) -> a -> b
$ [c] -> Either a [c]
forall a b. b -> Either a b
Right ([c] -> Either a [c]) -> [c] -> Either a [c]
forall a b. (a -> b) -> a -> b
$ (Int -> c) -> [Int] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map (Array c -> Int -> c
forall a. Array a -> Int -> a
indexArray Array c
rs) [0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]
        Compute (Either a [c]) -> IO (Compute (Either a [c]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Compute (Either a [c]) -> IO (Compute (Either a [c])))
-> Compute (Either a [c]) -> IO (Compute (Either a [c]))
forall a b. (a -> b) -> a -> b
$ Waiting (Either a [c]) -> Compute (Either a [c])
forall a. Waiting a -> Compute a
Later Waiting (Either a [c])
waiting