EQueue.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Concurrent.EQueue
  ( EQueue(registerSemi, registerQueued), EQueueW(waitEQ)
  , AnyEQueue(AEQ), ForceEdge(EEQ), MappedEQueue(MEQ), meqEQ
  , STMEQueue, STMEQueueWait(..), newSTMEQueue
  ) where

import Control.Concurrent.EQueue.Class
import Control.Concurrent.EQueue.STMEQueue (STMEQueue, STMEQueueWait(..), newSTMEQueue)
import Data.Bifunctor
import Data.Functor.Contravariant

-- | Allows us to return an unknown instance of EQueue, getting around Haskells lack of
--   existential qualification.
data AnyEQueue a where
  AEQ :: EQueue eq => eq a -> AnyEQueue a

instance EQueue AnyEQueue where
  registerSemi (AEQ eq) = registerSemi eq
  registerQueued (AEQ eq) = registerQueued eq

-- | A wrapper that translates level triggered events into events that observe the edges.
data ForceEdge a where
  EEQ :: EQueue eq => eq a -> ForceEdge a

instance EQueue ForceEdge where
  registerSemi (EEQ eq) f = (first (. f)) <$> registerQueued eq
  registerQueued (EEQ eq) = registerQueued eq

-- | A wrapper that allows us to pretend a queue of one type is of another.
data MappedEQueue eq b a where
  MEQ :: (a -> b) -> eq b -> MappedEQueue eq b a

-- | Retrieve the EQueue we're mapping to from the MappedEQueue.
meqEQ :: MappedEQueue eq b a -> eq b
meqEQ (MEQ _ eq) = eq

instance Contravariant (MappedEQueue eq b) where
  contramap f (MEQ g eq) = MEQ (g . f) eq

instance EQueue eq => EQueue (MappedEQueue eq b) where
  registerSemi (MEQ g eq) f = registerSemi eq (g . f)
  registerQueued (MEQ g eq) = (first (. g)) <$> registerQueued eq