{-# LANGUAGE DerivingVia #-}
-- | Interface adapted from "Control.Concurrent.Async"
module Control.Effect.Conc
  ( -- * Effects
    Conc
  , Async

    -- * Interpretations
  , concToIO

  , concToUnliftIO

    -- * Key actions
  , async
  , withAsync
  , wait
  , poll

  , concurrently
  , race

  , waitEither
  , waitBoth
  , link
  , link2

  , waitAny
  , mapConcurrently
  , forConcurrently

    -- * Concurrently applicative
  , Concurrently(..)

    -- * Other actions
  , asyncBound
  , asyncOn
  , asyncWithUnmask
  , asyncOnWithUnmask
  , withAsyncBound
  , withAsyncWithUnmask
  , withAsyncOnWithUnmask
  , waitCatch
  , cancel
  , uninterruptibleCancel
  , cancelWith
  , waitAnyCatch
  , waitAnyCancel
  , waitAnyCatchCancel
  , waitEitherCatch
  , waitEitherCancel
  , waitEitherCatchCancel
  , waitEither_
  , linkOnly
  , link2Only
  , race_
  , concurrently_
  , mapConcurrently_
  , forConcurrently_
  , replicateConcurrently
  , replicateConcurrently_

    -- * Re-exports from "Control.Concurrent.Async"
  , A.asyncThreadId
  , A.AsyncCancelled(..)
  , A.ExceptionInLinkedThread(..)
  , A.waitAnySTM
  , A.waitAnyCatchSTM
  , A.waitEitherSTM
  , A.waitEitherCatchSTM
  , A.waitEitherSTM_
  , A.waitBothSTM
  , A.compareAsyncs

    -- * Carriers
  , ConcToIOC
  , ConcToUnliftIOC
  ) where

import Control.Applicative
import Control.Monad

import Control.Concurrent.Async (Async)
import qualified Control.Concurrent.Async as A

import Control.Effect
import Control.Effect.Internal.Conc
import Control.Effect.Unlift

import Control.Exception (SomeException, Exception)
import Control.Effect.Internal.Newtype

-- For coercion purposes
import Control.Effect.Internal.Utils
import Control.Effect.Carrier.Internal.Interpret


type ConcToUnliftIOC = UnwrapC Conc

-- | Run a 'Conc' effect if __all__ effects used in the program --
-- past and future -- are eventually reduced to operations on 'IO'.
--
-- Due to its very restrictive primitive effect and carrier constraint,
-- 'concToIO' can't be used together with most pure interpreters.
-- For example, instead of 'Control.Effect.Error.runError', you must use
-- 'Control.Effect.Error.errorToIO'.
--
-- This poses a problem if you want to use some effect that /doesn't have/
-- an interpreter compatible with 'concToIO' -- like
-- 'Control.Effect.NonDet.NonDet'.
-- In that case, you might still be able to use both effects in the same program
-- by applying
-- [Split Interpretation](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-Topics#split-interpretation)
-- to seperate their uses.
--
-- @'Derivs' ('ConcToIOC' m) = 'Conc' ': 'Derivs' m@
--
-- @'Control.Effect.Primitive.Prims'  ('ConcToIOC' m) = 'Unlift' 'IO' ': 'Control.Effect.Primitive.Prims' m@
--
concToIO :: ( Carrier m
            , MonadBaseControlPure IO m
            )
          => ConcToIOC m a
          -> m a
concToIO =
     unliftToFinal
  .# unwrapTop
  .# unConcToIOC
{-# INLINE concToIO #-}

-- | Transform a 'Conc' effect into @'Unlift' IO@.
concToUnliftIO :: Eff (Unlift IO) m
               => ConcToUnliftIOC m a
               -> m a
concToUnliftIO = unwrap
{-# INLINE concToUnliftIO #-}

async :: Eff Conc m => m a -> m (Async a)
async m = unliftConc $ \lower -> A.async (lower m)
{-# INLINE async #-}

asyncBound :: Eff Conc m => m a -> m (Async a)
asyncBound m = unliftConc $ \lower -> A.asyncBound (lower m)
{-# INLINE asyncBound #-}

asyncOn :: Eff Conc m => Int -> m a -> m (Async a)
asyncOn i m = unliftConc $ \lower -> A.asyncOn i (lower m)
{-# INLINE asyncOn #-}

asyncWithUnmask :: Eff Conc m => ((forall x. m x -> m x) -> m a) -> m (Async a)
asyncWithUnmask main = unliftConc $ \lower -> A.asyncWithUnmask $ \restore ->
  lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m)
{-# INLINE asyncWithUnmask #-}

asyncOnWithUnmask :: Eff Conc m => Int -> ((forall x. m x -> m x) -> m a) -> m (Async a)
asyncOnWithUnmask i main = unliftConc $ \lower -> A.asyncOnWithUnmask i $ \restore ->
  lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m)
{-# INLINE asyncOnWithUnmask #-}

withAsync :: Eff Conc m => m a -> (Async a -> m b) -> m b
withAsync m c = unliftConc $ \lower -> A.withAsync (lower m) (lower . c)
{-# INLINE withAsync #-}

withAsyncBound :: Eff Conc m => m a -> (Async a -> m b) -> m b
withAsyncBound m c = unliftConc $ \lower -> A.withAsyncBound (lower m) (lower . c)
{-# INLINE withAsyncBound #-}

withAsyncWithUnmask :: Eff Conc m => ((forall x. m x -> m x) -> m a) -> (Async a -> m b) -> m b
withAsyncWithUnmask main c = unliftConc $ \lower ->
  A.withAsyncWithUnmask
    (\restore -> lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m))
    (lower . c)
{-# INLINE withAsyncWithUnmask #-}


withAsyncOnWithUnmask :: Eff Conc m => Int -> ((forall x. m x -> m x) -> m a) -> (Async a -> m b) -> m b
withAsyncOnWithUnmask i main c = unliftConc $ \lower ->
  A.withAsyncOnWithUnmask i
    (\restore -> lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m))
    (lower . c)
{-# INLINE withAsyncOnWithUnmask #-}

wait :: Eff Conc m => Async a -> m a
wait a = unliftConc $ \_ -> A.wait a
{-# INLINE wait #-}

poll :: Eff Conc m => Async a -> m (Maybe (Either SomeException a))
poll a = unliftConc $ \_ -> A.poll a
{-# INLINE poll #-}

waitCatch :: Eff Conc m => Async a -> m (Either SomeException a)
waitCatch a = unliftConc $ \_ -> A.waitCatch a
{-# INLINE waitCatch #-}

cancel :: Eff Conc m => Async a -> m ()
cancel a = unliftConc $ \_ -> A.cancel a
{-# INLINE cancel #-}

uninterruptibleCancel :: Eff Conc m => Async a -> m ()
uninterruptibleCancel a = unliftConc $ \_ -> A.uninterruptibleCancel a
{-# INLINE uninterruptibleCancel #-}

cancelWith :: Eff Conc m => (Exception e, Eff Conc m) => Async a -> e -> m ()
cancelWith a e = unliftConc $ \_ -> A.cancelWith a e
{-# INLINE cancelWith #-}

waitAny :: Eff Conc m => [Async a] -> m (Async a, a)
waitAny as = unliftConc $ \_ -> A.waitAny as
{-# INLINE waitAny #-}

waitAnyCatch :: Eff Conc m => [Async a] -> m (Async a, Either SomeException a)
waitAnyCatch as = unliftConc $ \_ -> A.waitAnyCatch as
{-# INLINE waitAnyCatch #-}

waitAnyCancel :: Eff Conc m => [Async a] -> m (Async a, a)
waitAnyCancel as = unliftConc $ \_ -> A.waitAnyCancel as
{-# INLINE waitAnyCancel #-}

waitAnyCatchCancel :: Eff Conc m => [Async a] -> m (Async a, Either SomeException a)
waitAnyCatchCancel as = unliftConc $ \_ -> A.waitAnyCatchCancel as
{-# INLINE waitAnyCatchCancel #-}

waitEither :: Eff Conc m => Async a -> Async b -> m (Either a b)
waitEither aa ab = unliftConc $ \_ -> A.waitEither aa ab
{-# INLINE waitEither #-}


waitEitherCatch :: Eff Conc m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatch aa ab = unliftConc $ \_ -> A.waitEitherCatch aa ab
{-# INLINE waitEitherCatch #-}

waitEitherCancel :: Eff Conc m => Async a -> Async b -> m (Either a b)
waitEitherCancel aa ab = unliftConc $ \_ -> A.waitEitherCancel aa ab
{-# INLINE waitEitherCancel #-}

waitEitherCatchCancel :: Eff Conc m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))
waitEitherCatchCancel aa ab = unliftConc $ \_ -> A.waitEitherCatchCancel aa ab
{-# INLINE waitEitherCatchCancel #-}

waitEither_ :: Eff Conc m => Async a -> Async b -> m ()
waitEither_ aa ab = unliftConc $ \_ -> A.waitEither_ aa ab
{-# INLINE waitEither_ #-}

waitBoth :: Eff Conc m => Async a -> Async b -> m (a, b)
waitBoth aa ab = unliftConc $ \_ -> A.waitBoth aa ab
{-# INLINE waitBoth #-}

link :: Eff Conc m => Async a -> m ()
link a = unliftConc $ \_ -> A.link a
{-# INLINE link #-}

linkOnly :: Eff Conc m => (SomeException -> Bool) -> Async a -> m ()
linkOnly h a = unliftConc $ \_ -> A.linkOnly h a
{-# INLINE linkOnly #-}

link2 :: Eff Conc m => Async a -> Async b -> m ()
link2 a b = unliftConc $ \_ -> A.link2 a b
{-# INLINE link2 #-}

link2Only :: Eff Conc m => (SomeException -> Bool) -> Async a -> Async b -> m ()
link2Only h a b = unliftConc $ \_ -> A.link2Only h a b
{-# INLINE link2Only #-}

race :: Eff Conc m => m a -> m b -> m (Either a b)
race ma mb = unliftConc $ \lower -> A.race (lower ma) (lower mb)
{-# INLINE race #-}

race_ :: Eff Conc m => m a -> m b -> m ()
race_ ma mb = unliftConc $ \lower -> A.race_ (lower ma) (lower mb)
{-# INLINE race_ #-}

concurrently :: Eff Conc m => m a -> m b -> m (a, b)
concurrently ma mb = unliftConc $ \lower -> A.concurrently (lower ma) (lower mb)
{-# INLINE concurrently #-}

concurrently_ :: Eff Conc m => m a -> m b -> m ()
concurrently_ ma mb = unliftConc $ \lower -> A.concurrently_ (lower ma) (lower mb)
{-# INLINE concurrently_ #-}

mapConcurrently :: (Traversable t, Eff Conc m) => (a -> m b) -> t a -> m (t b)
mapConcurrently = (runConcurrently .) #. traverse .# (Concurrently .)
{-# INLINE mapConcurrently #-}

forConcurrently :: (Traversable t, Eff Conc m) => t a -> (a -> m b) -> m (t b)
forConcurrently = flip mapConcurrently
{-# INLINE forConcurrently #-}

mapConcurrently_ :: (Foldable t, Eff Conc m) => (a -> m b) -> t a -> m ()
mapConcurrently_ f = runConcurrently #. foldMap (Concurrently #. void . f)
{-# INLINE mapConcurrently_ #-}

forConcurrently_ :: (Foldable t, Eff Conc m) => t a -> (a -> m b) -> m ()
forConcurrently_ = flip mapConcurrently_
{-# INLINE forConcurrently_ #-}

replicateConcurrently :: Eff Conc m => Int -> m a -> m [a]
replicateConcurrently cnt = runConcurrently #. replicateM cnt .# Concurrently
{-# INLINE replicateConcurrently #-}

replicateConcurrently_ :: Eff Conc m => Int -> m a -> m ()
replicateConcurrently_ cnt = runConcurrently #. replicateM_ cnt .# Concurrently
{-# INLINE replicateConcurrently_ #-}

newtype Concurrently m a = Concurrently { runConcurrently :: m a }
  deriving Functor

instance Eff Conc m => Applicative (Concurrently m) where
  pure = Concurrently #. return
  {-# INLINE pure #-}

  Concurrently fs <*> Concurrently as = Concurrently $ unliftConc $ \lower ->
    A.runConcurrently (A.Concurrently (lower fs) <*> A.Concurrently (lower as))
  {-# INLINE (<*>) #-}

instance Eff Conc m => Alternative (Concurrently m) where
  empty = Concurrently $ unliftConc $ \_ -> A.runConcurrently empty
  {-# INLINE empty #-}

  Concurrently as <|> Concurrently bs = Concurrently $ unliftConc $ \lower ->
    A.runConcurrently (A.Concurrently(lower as) <|> A.Concurrently (lower bs))
  {-# INLINE (<|>) #-}

instance (Eff Conc m, Semigroup a) => Semigroup (Concurrently m a) where
  (<>) = liftA2 (<>)
  {-# INLINE (<>) #-}

instance (Eff Conc m, Monoid a) => Monoid (Concurrently m a) where
  mempty = pure mempty
  {-# INLINE mempty #-}