{-
Note [RoundId]

A token representing the round.  This needs to be unique per round,
and it needs to support Eq.  Fortunately the IORef RequestStore is
exactly what we need: IORef supports Eq, and we make a new one for
each round.  There's a danger that storing this in the DataCache could
cause a space leak, so we stub out the contents after each round (see
runHaxl).
-}

-- | 'cachedComputation' memoizes a Haxl computation.  The key is a
-- request.
--
-- /Note:/ These cached computations will /not/ be included in the output
-- of 'dumpCacheAsHaskell'.
--
cachedComputation
   :: forall req u a. (Request req a)
   => req a -> GenHaxl u a -> GenHaxl u a
cachedComputation req haxl = GenHaxl $ \env ref -> do
  cache <- readIORef (memoRef env)
  case DataCache.lookup req cache of
    Nothing -> do
      memovar <- newIORef (MemoInProgress ref haxl)
      writeIORef (memoRef env) $! DataCache.insert req (MemoVar memovar) cache
      run memovar haxl env ref
    Just (MemoVar memovar) -> do
      status <- readIORef memovar
      case status of
        MemoDone r -> done r
        MemoInProgress round cont
          | round == ref -> return (Blocked (retryMemo req))
          | otherwise    -> run memovar cont env ref
          -- was blocked in a previous round; run the saved continuation to
          -- make more progress.
 where
  -- If we got blocked on this memo in the current round, this is the
  -- continuation: just try to evaluate the memo again.  We know it is
  -- already in the cache (because we just checked), so the computation
  -- will never be used.
  retryMemo req =
   cachedComputation req (throw (CriticalError "retryMemo"))

  -- Run the memoized computation and store the result (complete or
  -- partial) back in the MemoVar afterwards.
 --
 -- We don't attempt to catch IO monad exceptions here.  That may seem
 -- dangerous, because if an IO exception is raised we'll leave the
 -- MemoInProgress in the MemoVar.  But we always want to just
 -- propagate an IO monad exception (it should kill the whole runHaxl,
 -- unless there's a unsafeToHaxlException), so we should never be
 -- looking at the MemoVar again anyway.  Furthermore, storing the
 -- exception in the MemoVar is wrong, because that will turn it into
 -- a Haxl exception (see rethrowAsyncExceptions).
  run memovar cont env ref = do
    e <- unHaxl cont env ref
    case e of
      Done a -> complete memovar (Right a)
      Throw e -> complete memovar (Left e)
      Blocked cont -> do
        writeIORef memovar (MemoInProgress ref cont)
        return (Blocked (retryMemo req))

  -- We're finished: store the final result
  complete memovar r = do
    writeIORef memovar (MemoDone r)
    done r

-- | Lifts an 'Either' into either 'Throw' or 'Done'.
cachedComputation
   :: forall req u a. (Request req a)
   => req a -> GenHaxl u a -> GenHaxl u a
cachedComputation req haxl = GenHaxl $ \env ref -> do
  cache <- readIORef (memoRef env)
  case DataCache.lookup req cache of
    Nothing -> do
      memovar <- newIORef (MemoInProgress ref haxl)
      writeIORef (memoRef env) $! DataCache.insert req (MemoVar memovar) cache
      run memovar haxl env ref
    Just (MemoVar memovar) -> do
      status <- readIORef memovar
      case status of
        MemoDone r -> done r
        MemoInProgress round cont
          | round == ref -> return (Blocked (retryMemo req))
          | otherwise    -> run memovar cont env ref
          -- was blocked in a previous round; run the saved continuation to
          -- make more progress.
 where
  -- If we got blocked on this memo in the current round, this is the
  -- continuation: just try to evaluate the memo again.  We know it is
  -- already in the cache (because we just checked), so the computation
  -- will never be used.
  retryMemo req =
   cachedComputation req (throw (CriticalError "retryMemo"))

  -- Run the memoized computation and store the result (complete or
  -- partial) back in the MemoVar afterwards.
 --
 -- We don't attempt to catch IO monad exceptions here.  That may seem
 -- dangerous, because if an IO exception is raised we'll leave the
 -- MemoInProgress in the MemoVar.  But we always want to just
 -- propagate an IO monad exception (it should kill the whole runHaxl,
 -- unless there's a unsafeToHaxlException), so we should never be
 -- looking at the MemoVar again anyway.  Furthermore, storing the
 -- exception in the MemoVar is wrong, because that will turn it into
 -- a Haxl exception (see rethrowAsyncExceptions).
  run memovar cont env ref = do
    e <- unHaxl cont env ref
    case e of
      Done a -> complete memovar (Right a)
      Throw e -> complete memovar (Left e)
      Blocked cont -> do
        writeIORef memovar (MemoInProgress ref cont)
        return (Blocked (retryMemo req))

  -- We're finished: store the final result
  complete memovar r = do
    writeIORef memovar (MemoDone r)
    done r

-- | Lifts an 'Either' into either 'Throw' or 'Done'.
cachedComputation req haxl = GenHaxl $ \env ref -> do
  cache <- readIORef (memoRef env)
  case DataCache.lookup req cache of
    Nothing -> do
      memovar <- newIORef (MemoInProgress ref haxl)
      writeIORef (memoRef env) $! DataCache.insert req (MemoVar memovar) cache
      run memovar haxl env ref
    Just (MemoVar memovar) -> do
      status <- readIORef memovar
      case status of
        MemoDone r -> done r
        MemoInProgress round cont
          | round == ref -> return (Blocked (retryMemo req))
          | otherwise    -> run memovar cont env ref
          -- was blocked in a previous round; run the saved continuation to
          -- make more progress.
 where
  -- If we got blocked on this memo in the current round, this is the
  -- continuation: just try to evaluate the memo again.  We know it is
  -- already in the cache (because we just checked), so the computation
  -- will never be used.
  retryMemo req =
   cachedComputation req (throw (CriticalError "retryMemo"))

  -- Run the memoized computation and store the result (complete or
  -- partial) back in the MemoVar afterwards.
 --
 -- We don't attempt to catch IO monad exceptions here.  That may seem
 -- dangerous, because if an IO exception is raised we'll leave the
 -- MemoInProgress in the MemoVar.  But we always want to just
 -- propagate an IO monad exception (it should kill the whole runHaxl,
 -- unless there's a unsafeToHaxlException), so we should never be
 -- looking at the MemoVar again anyway.  Furthermore, storing the
 -- exception in the MemoVar is wrong, because that will turn it into
 -- a Haxl exception (see rethrowAsyncExceptions).
  run memovar cont env ref = do
    e <- unHaxl cont env ref
    case e of
      Done a -> complete memovar (Right a)
      Throw e -> complete memovar (Left e)
      Blocked cont -> do
        writeIORef memovar (MemoInProgress ref cont)
        return (Blocked (retryMemo req))

  -- We're finished: store the final result
  complete memovar r = do
    writeIORef memovar (MemoDone r)
    done r

-- | Lifts an 'Either' into either 'Throw' or 'Done'.