async-lifted.hs

{-# LANGUAGE
      FlexibleInstances,
      FlexibleContexts,
      UndecidableInstances,
      MultiParamTypeClasses,
      GADTs,
      ConstraintKinds,
      ScopedTypeVariables,
      TypeOperators
  #-}

module Concurrently where

import Control.Applicative
import Control.Monad.Trans.Control
import Control.Concurrent.Async.Lifted.Safe
import Data.Constraint
import Data.Constraint.Forall

-- | @Pure m a@ is a synonym for @StM m a ~ a@
class (StM m a ~ a) => Pure m a
instance (StM m a ~ a) => Pure m a

data Concurrently m a where
  Concurrently :: Forall (Pure m) => m a -> Concurrently m a

instance (Functor m) => Functor (Concurrently m) where
  fmap f (Concurrently a) = Concurrently $ f <$> a
instance (MonadBaseControl IO m, Forall (Pure m)) => Applicative (Concurrently m) where
  pure = Concurrently . pure
  Concurrently (fs :: m (a -> b)) <*> Concurrently (as :: m a) =
    (Concurrently $ uncurry ($) <$> concurrently fs as)
      \\ (inst :: Forall (Pure m) :- Pure m a)
      \\ (inst :: Forall (Pure m) :- Pure m (a -> b))