{- |
Channel messages
-}
module Sound.MIDI.Message.Channel (
   T(..), Body(..), get, getWithStatus, put, putWithStatus,
   Channel, fromChannel,   toChannel,

   Voice.Pitch,      Voice.fromPitch,      Voice.toPitch,
   Voice.Velocity,   Voice.fromVelocity,   Voice.toVelocity,
   Voice.Program,    Voice.fromProgram,    Voice.toProgram,
   Voice.Controller, Voice.fromController, Voice.toController,

   decodeStatus,
   ) where

import qualified Sound.MIDI.Message.Channel.Voice as Voice
import qualified Sound.MIDI.Message.Channel.Mode  as Mode

import qualified Sound.MIDI.Parser.Status as StatusParser
import           Sound.MIDI.Parser.Primitive
import qualified Sound.MIDI.Parser.Class as Parser
import Sound.MIDI.Parser.Status (Channel, fromChannel, toChannel, )

import Control.Monad (liftM, liftM2, when, )

import qualified Sound.MIDI.Writer.Status as StatusWriter
import qualified Sound.MIDI.Writer.Basic  as Writer
import qualified Sound.MIDI.Bit as Bit

import Sound.MIDI.Monoid ((+#+))

import Data.Tuple.HT (mapSnd, )

import Test.QuickCheck (Arbitrary(arbitrary, shrink), )
import qualified Test.QuickCheck as QC



data T = Cons {
     T -> Channel
messageChannel :: Channel,
     T -> Body
messageBody    :: Body
   }
     -- ToDo: make nicer Show instance
     deriving (Int -> T -> ShowS
[T] -> ShowS
T -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [T] -> ShowS
$cshowList :: [T] -> ShowS
show :: T -> String
$cshow :: T -> String
showsPrec :: Int -> T -> ShowS
$cshowsPrec :: Int -> T -> ShowS
Show, T -> T -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: T -> T -> Bool
$c/= :: T -> T -> Bool
== :: T -> T -> Bool
$c== :: T -> T -> Bool
Eq, Eq T
T -> T -> Bool
T -> T -> Ordering
T -> T -> T
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: T -> T -> T
$cmin :: T -> T -> T
max :: T -> T -> T
$cmax :: T -> T -> T
>= :: T -> T -> Bool
$c>= :: T -> T -> Bool
> :: T -> T -> Bool
$c> :: T -> T -> Bool
<= :: T -> T -> Bool
$c<= :: T -> T -> Bool
< :: T -> T -> Bool
$c< :: T -> T -> Bool
compare :: T -> T -> Ordering
$ccompare :: T -> T -> Ordering
Ord)

data Body =
     Voice Voice.T
   | Mode  Mode.T
     deriving (Int -> Body -> ShowS
[Body] -> ShowS
Body -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Body] -> ShowS
$cshowList :: [Body] -> ShowS
show :: Body -> String
$cshow :: Body -> String
showsPrec :: Int -> Body -> ShowS
$cshowsPrec :: Int -> Body -> ShowS
Show, Body -> Body -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Body -> Body -> Bool
$c/= :: Body -> Body -> Bool
== :: Body -> Body -> Bool
$c== :: Body -> Body -> Bool
Eq, Eq Body
Body -> Body -> Bool
Body -> Body -> Ordering
Body -> Body -> Body
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Body -> Body -> Body
$cmin :: Body -> Body -> Body
max :: Body -> Body -> Body
$cmax :: Body -> Body -> Body
>= :: Body -> Body -> Bool
$c>= :: Body -> Body -> Bool
> :: Body -> Body -> Bool
$c> :: Body -> Body -> Bool
<= :: Body -> Body -> Bool
$c<= :: Body -> Body -> Bool
< :: Body -> Body -> Bool
$c< :: Body -> Body -> Bool
compare :: Body -> Body -> Ordering
$ccompare :: Body -> Body -> Ordering
Ord)

instance Arbitrary T where
   arbitrary :: Gen T
arbitrary =
      forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Channel -> Body -> T
Cons
         (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Channel
toChannel forall a b. (a -> b) -> a -> b
$ forall a. [(Int, Gen a)] -> Gen a
QC.frequency forall a b. (a -> b) -> a -> b
$
            -- we have to prefer one favorite channel in order to test correct implementation of the running status
            (Int
20, forall (m :: * -> *) a. Monad m => a -> m a
return Int
3) forall a. a -> [a] -> [a]
:
            ( Int
1, forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0,Int
15)) forall a. a -> [a] -> [a]
:
            [])
         (forall a. [(Int, Gen a)] -> Gen a
QC.frequency forall a b. (a -> b) -> a -> b
$
            (Int
20, forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Voice forall a. Arbitrary a => Gen a
arbitrary) forall a. a -> [a] -> [a]
:
            ( Int
1, forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Mode  forall a. Arbitrary a => Gen a
arbitrary) forall a. a -> [a] -> [a]
:
            [])
   shrink :: T -> [T]
shrink (Cons Channel
chan Body
body) =
      forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Channel -> Body -> T
Cons) forall a b. (a -> b) -> a -> b
$
      case Body
body of
         Voice T
v -> forall a b. (a -> b) -> [a] -> [b]
map (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Body
Voice) forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => a -> [a]
shrink (Channel
chan, T
v)
         Mode  T
m -> forall a b. (a -> b) -> [a] -> [b]
map (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Body
Mode)  forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => a -> [a]
shrink (Channel
chan, T
m)


-- * serialization

{- |
Parse an event.
Note that in the case of a regular MIDI Event, the tag is the status,
and we read the first byte of data before we call 'get'.
In the case of a MIDIEvent with running status,
we find out the status from the parser
(it's been nice enough to keep track of it for us),
and the tag that we've already gotten is the first byte of data.
-}
getWithStatus :: Parser.C parser => Int -> Parser.Fragile (StatusParser.T parser) T
getWithStatus :: forall (parser :: * -> *). C parser => Int -> Fragile (T parser) T
getWithStatus Int
tag =
   do (status :: (Int, Channel)
status@(Int
code, Channel
channel), Int
firstData) <-
         if Int
tag forall a. Ord a => a -> a -> Bool
< Int
0x80
           then forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                   (forall (m :: * -> *) a. Monad m => String -> T m a
Parser.giveUp String
"messages wants to repeat status byte, but there was no status yet")
                   (\(Int, Channel)
cc -> forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Channel)
cc,Int
tag))
                      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (parser :: * -> *).
Monad parser =>
Fragile (T parser) Status
StatusParser.get
           else forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) forall a b. (a -> b) -> a -> b
$ Int -> (Int, Channel)
decodeStatus Int
tag) forall a b. (a -> b) -> a -> b
$ forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
StatusParser.lift forall (parser :: * -> *). C parser => Fragile parser Int
get1
      forall (parser :: * -> *).
Monad parser =>
Status -> Fragile (T parser) ()
StatusParser.set (forall a. a -> Maybe a
Just (Int, Channel)
status)
      forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
StatusParser.lift forall a b. (a -> b) -> a -> b
$ forall (parser :: * -> *).
C parser =>
Int -> Channel -> Int -> Fragile parser T
get Int
code Channel
channel Int
firstData

-- | for internal use
decodeStatus :: Int -> (Int, Channel)
decodeStatus :: Int -> (Int, Channel)
decodeStatus  =  forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd Int -> Channel
toChannel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Int -> a -> (a, a)
Bit.splitAt Int
4

{- |
Parse a MIDI Channel message.
Note that since getting the first byte is a little complex
(there are issues with running status),
the code, channel and first data byte
must be determined by the caller.
-}
get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fragile parser T
get :: forall (parser :: * -> *).
C parser =>
Int -> Channel -> Int -> Fragile parser T
get Int
code Channel
channel Int
firstData =
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Channel -> Body -> T
Cons Channel
channel) forall a b. (a -> b) -> a -> b
$
   if Int
code forall a. Eq a => a -> a -> Bool
== Int
11 Bool -> Bool -> Bool
&& Int
firstData forall a. Ord a => a -> a -> Bool
>= Int
0x78
     then
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
firstData forall a. Ord a => a -> a -> Bool
>= Int
0x80)
           (forall (m :: * -> *) a. Monad m => String -> T m a
Parser.giveUp (String
"mode value out of range: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
firstData)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Mode (forall (parser :: * -> *). C parser => Int -> Fragile parser T
Mode.get Int
firstData)
     else forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Voice (forall (parser :: * -> *).
C parser =>
Int -> Int -> Fragile parser T
Voice.get Int
code Int
firstData)


put :: Writer.C writer => T -> writer
put :: forall writer. C writer => T -> writer
put = forall writer. Monoid writer => T Uncompressed writer -> writer
StatusWriter.toWriterWithoutStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
putWithStatus

putWithStatus ::
   (StatusWriter.Compression compress, Writer.C writer) =>
   T -> StatusWriter.T compress writer
putWithStatus :: forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
putWithStatus (Cons Channel
c Body
e) =
   case Body
e of
      Voice T
v -> forall writer compress.
C writer =>
(Int -> T compress writer) -> T -> T compress writer
Voice.putWithStatus (forall compress writer.
(Compression compress, C writer) =>
Channel -> Int -> T compress writer
putChannel Channel
c) T
v
      Mode  T
m -> forall compress writer.
(Compression compress, C writer) =>
Channel -> Int -> T compress writer
putChannel Channel
c Int
11 forall m. Monoid m => m -> m -> m
+#+ forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
StatusWriter.lift (forall writer. C writer => T -> writer
Mode.put T
m)

-- | output a channel + message code
putChannel ::
   (StatusWriter.Compression compress, Writer.C writer) =>
   Channel -> Int -> StatusWriter.T compress writer
putChannel :: forall compress writer.
(Compression compress, C writer) =>
Channel -> Int -> T compress writer
putChannel Channel
chan Int
code =
   forall compress writer.
(Compression compress, Monoid writer) =>
(Int, Channel) -> writer -> T compress writer
StatusWriter.change (Int
code, Channel
chan) forall a b. (a -> b) -> a -> b
$
      forall writer. C writer => Int -> writer
Writer.putIntAsByte (Int
16forall a. Num a => a -> a -> a
*Int
code forall a. Num a => a -> a -> a
+ Channel -> Int
fromChannel Channel
chan)