{- |
This module allows to cancel events according to some criteria.
In all cases other than 'setInput' and 'setOutput'
the criteria are combined by logical AND.
For every criterion we provide three kinds of accessors:

* @set@: enable a criterion

* @put@: enable or disable a criterion

* @get@: query, whether the criterion is enabled or disabled.

Currently only the @set@ functions are really usable.
The @put@ and @get@ functions would become useful
for manipulating the remove criterion record, that ALSA maintains.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Sound.ALSA.Sequencer.Event.RemoveMonad (
  T,
  run,
  -- no need to export this, since Event.Remove is not exported as well
  -- apply,

  setInput,     putInput,     getInput,
  setOutput,    putOutput,    getOutput,
  setChannel,   putChannel,   getChannel,
  setEventType, putEventType,
  setTag,       putTag,       getTag,
  setDest,      putDest,      getDest,
  setTime,      putTime,      getTime,
  setIgnoreOff, putIgnoreOff, getIgnoreOff,
  ) where

import qualified Sound.ALSA.Sequencer.Event.Remove as Remove

import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq
import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr
import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue
import qualified Sound.ALSA.Sequencer.Marshal.Event as Event
import qualified Sound.ALSA.Sequencer.Marshal.Time as Time

import qualified Control.Monad.Trans.Reader as MR
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import Control.Applicative (Applicative, )

import qualified Data.EnumBitSet as EnumSet
import Data.EnumBitSet ((.-.), (.|.), )

import Control.Monad (liftM2, )
import Data.Monoid (mempty, mappend, )


newtype T a = Cons (MR.ReaderT Remove.T (MS.StateT Remove.Condition IO) a)
   deriving (forall a b. a -> T b -> T a
forall a b. (a -> b) -> T a -> T b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> T b -> T a
$c<$ :: forall a b. a -> T b -> T a
fmap :: forall a b. (a -> b) -> T a -> T b
$cfmap :: forall a b. (a -> b) -> T a -> T b
Functor, Functor T
forall a. a -> T a
forall a b. T a -> T b -> T a
forall a b. T a -> T b -> T b
forall a b. T (a -> b) -> T a -> T b
forall a b c. (a -> b -> c) -> T a -> T b -> T c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. T a -> T b -> T a
$c<* :: forall a b. T a -> T b -> T a
*> :: forall a b. T a -> T b -> T b
$c*> :: forall a b. T a -> T b -> T b
liftA2 :: forall a b c. (a -> b -> c) -> T a -> T b -> T c
$cliftA2 :: forall a b c. (a -> b -> c) -> T a -> T b -> T c
<*> :: forall a b. T (a -> b) -> T a -> T b
$c<*> :: forall a b. T (a -> b) -> T a -> T b
pure :: forall a. a -> T a
$cpure :: forall a. a -> T a
Applicative, Applicative T
forall a. a -> T a
forall a b. T a -> T b -> T b
forall a b. T a -> (a -> T b) -> T b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> T a
$creturn :: forall a. a -> T a
>> :: forall a b. T a -> T b -> T b
$c>> :: forall a b. T a -> T b -> T b
>>= :: forall a b. T a -> (a -> T b) -> T b
$c>>= :: forall a b. T a -> (a -> T b) -> T b
Monad)


unpack :: T a -> Remove.T -> Remove.Condition -> IO (a, Remove.Condition)
unpack :: forall a. T a -> T -> Condition -> IO (a, Condition)
unpack (Cons ReaderT T (StateT Condition IO) a
m) T
r = forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
MS.runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MR.runReaderT ReaderT T (StateT Condition IO) a
m T
r)

-- | apply the changes in the Remove monad to the Remove record
_apply :: T a -> Remove.T -> IO a
_apply :: forall a. T a -> T -> IO a
_apply T a
m T
r = do
  Condition
c0 <- T -> IO Condition
Remove.getCondition T
r
  (a
a,Condition
c1) <- forall a. T a -> T -> Condition -> IO (a, Condition)
unpack T a
m T
r Condition
c0
  T -> Condition -> IO ()
Remove.setCondition T
r Condition
c1
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Remove events according to the given conditions
run :: Seq.T mode -> T a -> IO a
run :: forall mode a. T mode -> T a -> IO a
run T mode
h T a
m = do
  T
r <- IO T
Remove.malloc
  (a
a,Condition
c) <- forall a. T a -> T -> Condition -> IO (a, Condition)
unpack T a
m T
r forall a w. (Enum a, Bits w) => T w a
EnumSet.empty
  T -> Condition -> IO ()
Remove.setCondition T
r Condition
c
  forall mode. T mode -> T -> IO ()
Remove.run T mode
h T
r
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a



liftGet :: (Remove.T -> IO a) -> T a
liftGet :: forall a. (T -> IO a) -> T a
liftGet T -> IO a
f = forall a. ReaderT T (StateT Condition IO) a -> T a
Cons forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
MR.ReaderT forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> IO a
f

liftGetCond :: (Remove.T -> IO a) -> Remove.Condition -> T (Maybe a)
liftGetCond :: forall a. (T -> IO a) -> Condition -> T (Maybe a)
liftGetCond T -> IO a
f Condition
cond = do
   Bool
b <- Condition -> T Bool
getCond Condition
cond
   if Bool
b
     then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (T -> IO a) -> T a
liftGet T -> IO a
f
     else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

liftSet :: (Remove.T -> b -> IO a) -> b -> T a
liftSet :: forall b a. (T -> b -> IO a) -> b -> T a
liftSet T -> b -> IO a
f b
x = forall a. ReaderT T (StateT Condition IO) a -> T a
Cons forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
MR.ReaderT forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip T -> b -> IO a
f b
x

liftSetCond :: (Remove.T -> a -> IO b) -> Remove.Condition -> a -> T b
liftSetCond :: forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> a -> IO b
f Condition
cond a
x = do
   (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend Condition
cond
   forall b a. (T -> b -> IO a) -> b -> T a
liftSet T -> a -> IO b
f a
x

liftPutCond :: (Remove.T -> a -> IO ()) -> Remove.Condition -> Maybe a -> T ()
liftPutCond :: forall a. (T -> a -> IO ()) -> Condition -> Maybe a -> T ()
liftPutCond T -> a -> IO ()
f Condition
cond Maybe a
mx =
   case Maybe a
mx of
      Maybe a
Nothing -> (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ (forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.-. Condition
cond)
      Just a
x -> forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> a -> IO ()
f Condition
cond a
x

getCond :: Remove.Condition -> T Bool
getCond :: Condition -> T Bool
getCond Condition
cond =
   forall a. ReaderT T (StateT Condition IO) a -> T a
Cons forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets forall a b. (a -> b) -> a -> b
$ forall a w. (Enum a, Bits w) => T w a -> T w a -> Bool
EnumSet.subset Condition
cond

setCond :: Remove.Condition -> T ()
setCond :: Condition -> T ()
setCond Condition
cond =
   (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend Condition
cond

putCond :: Remove.Condition -> Bool -> T ()
putCond :: Condition -> Bool -> T ()
putCond Condition
cond Bool
b =
   (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ (if Bool
b then forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
(.|.) else forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
(.-.)) Condition
cond

modifyCond :: (Remove.Condition -> Remove.Condition) -> T ()
modifyCond :: (Condition -> Condition) -> T ()
modifyCond Condition -> Condition
f =
   forall a. ReaderT T (StateT Condition IO) a -> T a
Cons forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MS.modify Condition -> Condition
f

{- |
All events in the local input buffer are removed.
The conditions are not checked for these events.
This is equivalent to 'Event.dropInputBuffer'.
-}
setInput :: T ()
putInput :: Bool -> T ()
getInput :: T Bool

{- |
Matching events in the local output buffer are removed, too.
Matching events in the kernel buffer are removed in any case.
If there are no further conditions,
then this is equivalent to 'Event.dropOutputBuffer'.
-}
setOutput :: T ()
putOutput :: Bool -> T ()
getOutput :: T Bool

setChannel :: Event.Channel -> T ()
putChannel :: Maybe Event.Channel -> T ()
getChannel :: T (Maybe Event.Channel)

_setEventType :: Event.EType -> T ()
_getEventType :: T Event.EType
setEventType :: Event.Type e => e -> T ()
putEventType :: Event.Type e => Maybe e -> T ()

setTag :: Event.Tag -> T ()
putTag :: Maybe Event.Tag -> T ()
getTag :: T (Maybe Event.Tag)

{- |
ALSA maintainers say, that destination address and queue are checked together,
at least in the kernel buffer.
However up to ALSA-1.0.22 the check for the queue is missing in libasound
for the local buffer.
-}
setDest :: (Addr.T, Queue.T) -> T ()
putDest :: Maybe (Addr.T, Queue.T) -> T ()
getDest :: T (Maybe (Addr.T, Queue.T))

{- |
NoteOff events are kept in any case.
-}
setIgnoreOff :: T ()
putIgnoreOff :: Bool -> T ()
getIgnoreOff :: T Bool


getInput :: T Bool
getInput = Condition -> T Bool
getCond Condition
Remove.condInput
setInput :: T ()
setInput = Condition -> T ()
setCond Condition
Remove.condInput
putInput :: Bool -> T ()
putInput = Condition -> Bool -> T ()
putCond Condition
Remove.condInput

getOutput :: T Bool
getOutput = Condition -> T Bool
getCond Condition
Remove.condOutput
setOutput :: T ()
setOutput = Condition -> T ()
setCond Condition
Remove.condOutput
putOutput :: Bool -> T ()
putOutput = Condition -> Bool -> T ()
putCond Condition
Remove.condOutput

getChannel :: T (Maybe Channel)
getChannel = forall a. (T -> IO a) -> Condition -> T (Maybe a)
liftGetCond T -> IO Channel
Remove.getChannel Condition
Remove.condDestChannel
setChannel :: Channel -> T ()
setChannel = forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> Channel -> IO ()
Remove.setChannel Condition
Remove.condDestChannel
putChannel :: Maybe Channel -> T ()
putChannel = forall a. (T -> a -> IO ()) -> Condition -> Maybe a -> T ()
liftPutCond T -> Channel -> IO ()
Remove.setChannel Condition
Remove.condDestChannel

_getEventType :: T EType
_getEventType = forall a. (T -> IO a) -> T a
liftGet T -> IO EType
Remove.getEventType
_setEventType :: EType -> T ()
_setEventType = forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> EType -> IO ()
Remove.setEventType Condition
Remove.condEventType
setEventType :: forall e. Type e => e -> T ()
setEventType =
   forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> EType -> IO ()
Remove.setEventType Condition
Remove.condEventType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Type e => e -> EType
Event.expEv
putEventType :: forall e. Type e => Maybe e -> T ()
putEventType =
   forall a. (T -> a -> IO ()) -> Condition -> Maybe a -> T ()
liftPutCond T -> EType -> IO ()
Remove.setEventType Condition
Remove.condEventType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Type e => e -> EType
Event.expEv

getTag :: T (Maybe Tag)
getTag = forall a. (T -> IO a) -> Condition -> T (Maybe a)
liftGetCond T -> IO Tag
Remove.getTag Condition
Remove.condTagMatch
setTag :: Tag -> T ()
setTag = forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> Tag -> IO ()
Remove.setTag Condition
Remove.condTagMatch
putTag :: Maybe Tag -> T ()
putTag = forall a. (T -> a -> IO ()) -> Condition -> Maybe a -> T ()
liftPutCond T -> Tag -> IO ()
Remove.setTag Condition
Remove.condTagMatch

getDestQueue :: Remove.T -> IO (Addr.T, Queue.T)
getDestQueue :: T -> IO (T, T)
getDestQueue T
r = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (T -> IO T
Remove.getDest T
r) (T -> IO T
Remove.getQueue T
r)
setDestQueue :: Remove.T -> (Addr.T, Queue.T) -> IO ()
setDestQueue :: T -> (T, T) -> IO ()
setDestQueue T
r (T
a,T
q) = T -> T -> IO ()
Remove.setDest T
r T
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> T -> T -> IO ()
Remove.setQueue T
r T
q

getDest :: T (Maybe (T, T))
getDest = forall a. (T -> IO a) -> Condition -> T (Maybe a)
liftGetCond T -> IO (T, T)
getDestQueue Condition
Remove.condDest
setDest :: (T, T) -> T ()
setDest = forall a b. (T -> a -> IO b) -> Condition -> a -> T b
liftSetCond T -> (T, T) -> IO ()
setDestQueue Condition
Remove.condDest
putDest :: Maybe (T, T) -> T ()
putDest = forall a. (T -> a -> IO ()) -> Condition -> Maybe a -> T ()
liftPutCond T -> (T, T) -> IO ()
setDestQueue Condition
Remove.condDest

getIgnoreOff :: T Bool
getIgnoreOff = Condition -> T Bool
getCond Condition
Remove.condIgnoreOff
setIgnoreOff :: T ()
setIgnoreOff = Condition -> T ()
setCond Condition
Remove.condIgnoreOff
putIgnoreOff :: Bool -> T ()
putIgnoreOff = Condition -> Bool -> T ()
putCond Condition
Remove.condIgnoreOff


getTime :: T (Maybe Ordering, Time.Stamp)
getTime :: T (Maybe Ordering, Stamp)
getTime = do
   Bool
ticks <- Condition -> T Bool
getCond Condition
Remove.condTimeTick
   Stamp
stamp <-
      if Bool
ticks
        then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tick -> Stamp
Time.Tick forall a b. (a -> b) -> a -> b
$ forall a. (T -> IO a) -> T a
liftGet T -> IO Tick
Remove.getTickTime
        else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T -> Stamp
Time.Real forall a b. (a -> b) -> a -> b
$ forall a. (T -> IO a) -> T a
liftGet T -> IO T
Remove.getRealTime
   Bool
after  <- Condition -> T Bool
getCond Condition
Remove.condTimeAfter
   Bool
before <- Condition -> T Bool
getCond Condition
Remove.condTimeBefore
   let mo :: Maybe Ordering
mo =
          case (Bool
after, Bool
before) of
             (Bool
False, Bool
False) -> forall a. Maybe a
Nothing
             (Bool
True,  Bool
False) -> forall a. a -> Maybe a
Just Ordering
GT
             (Bool
False, Bool
True ) -> forall a. a -> Maybe a
Just Ordering
LT
             (Bool
True,  Bool
True ) -> forall a. a -> Maybe a
Just Ordering
EQ
   forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ordering
mo, Stamp
stamp)

setTime :: Ordering -> Time.Stamp -> T ()
setTime :: Ordering -> Stamp -> T ()
setTime Ordering
o = Maybe Ordering -> Stamp -> T ()
putTime forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Ordering
o

putTime :: Maybe Ordering -> Time.Stamp -> T ()
putTime :: Maybe Ordering -> Stamp -> T ()
putTime Maybe Ordering
mo Stamp
t = do
   (Condition -> Condition) -> T ()
modifyCond ( forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.-. (Condition
Remove.condTimeAfter forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.|. Condition
Remove.condTimeBefore))
   (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend forall a b. (a -> b) -> a -> b
$
      case Maybe Ordering
mo of
         Maybe Ordering
Nothing -> forall a. Monoid a => a
mempty
         Just Ordering
LT -> Condition
Remove.condTimeBefore
         Just Ordering
GT -> Condition
Remove.condTimeAfter
         Just Ordering
EQ -> forall a. Monoid a => a -> a -> a
mappend Condition
Remove.condTimeBefore Condition
Remove.condTimeAfter
   case Stamp
t of
      Time.Tick Tick
x -> do
         (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ (forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.-. Condition
Remove.condTimeTick)
         forall b a. (T -> b -> IO a) -> b -> T a
liftSet T -> Tick -> IO ()
Remove.setTickTime Tick
x
      Time.Real T
x -> do
         (Condition -> Condition) -> T ()
modifyCond forall a b. (a -> b) -> a -> b
$ (forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.|. Condition
Remove.condTimeTick)
         forall b a. (T -> b -> IO a) -> b -> T a
liftSet T -> T -> IO ()
Remove.setRealTime T
x