WeirdUnlift.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Foo where
import GHC.Types
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor.Identity
import qualified Control.Concurrent.Async as A
import Control.Applicative (liftA2)
import Data.Functor.Compose as C
import Data.Tuple (swap)

class Split m where
    type Outer m :: Type -> Type
    type Middle m :: Type -> Type
    type Inner m :: Type -> Type
    split :: m a -> Outer m (Middle m (Inner m a))
    unsplit :: Outer m (Middle m (Inner m a)) -> m a

instance (Split m) => Split (ReaderT env m)  where
    type Outer (ReaderT env m) = Compose ((->) env) (Outer m)
    type Middle (ReaderT env m) = Middle m
    type Inner (ReaderT env m) = Inner m
    split = Compose . fmap split . runReaderT
    unsplit = ReaderT . fmap unsplit . getCompose
  
instance (Split m, Functor (Outer m), Functor (Middle m), Functor (Inner m)) => Split (StateT s m) where
    type Outer (StateT s m) = Compose ((->) s) (Outer m)
    type Middle (StateT s m) = Middle m
    type Inner (StateT s m) = Compose (Inner m) ((,)s)
    split = Compose . fmap (fmap (fmap fixup) . split) . runStateT
      where fixup = Compose . fmap swap
    unsplit = StateT . fmap (unsplit . fmap ((fmap fixup))) . getCompose
      where fixup = fmap swap . getCompose


instance Split IO  where
    type Outer IO = Identity
    type Inner IO = Identity
    type Middle IO = IO
    split = Identity . fmap Identity
    unsplit = fmap runIdentity . runIdentity

concurrently 
    ::
    ( Applicative (Outer m), Applicative (Inner m)
    , Middle m ~ IO
    , Split m
    ) => m a -> m b -> m (a, b)
concurrently a b = unsplit $ mergeStates  $ liftA2 A.concurrently (split a) (split b)
  where mergeStates = fmap (fmap (uncurry $ liftA2 (,)))


-- *Foo> concurrently (put 1 :: ReaderT Char (StateT Int IO) ()) (put 2)

-- <interactive>:145:1: error:
--     * No instance for (Monoid Int) arising from a use of `concurrently'
--     * In the expression:
--         concurrently (put 1 :: ReaderT Char (StateT Int IO) ()) (put 2)
--       In an equation for `it':
--           it
--             = concurrently (put 1 :: ReaderT Char (StateT Int IO) ()) (put 2)

liftComp :: (Split m,  Functor (Outer m)) => (forall r. Middle m r -> Middle m r) -> m a -> m a
liftComp comp = unsplit . fmap comp . split