{- |
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
(Int -> T -> ShowS) -> (T -> String) -> ([T] -> ShowS) -> Show T
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
(T -> T -> Bool) -> (T -> T -> Bool) -> Eq T
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
Eq T
-> (T -> T -> Ordering)
-> (T -> T -> Bool)
-> (T -> T -> Bool)
-> (T -> T -> Bool)
-> (T -> T -> Bool)
-> (T -> T -> T)
-> (T -> T -> T)
-> Ord 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
$cp1Ord :: Eq T
Ord)

data Body =
     Voice Voice.T
   | Mode  Mode.T
     deriving (Int -> Body -> ShowS
[Body] -> ShowS
Body -> String
(Int -> Body -> ShowS)
-> (Body -> String) -> ([Body] -> ShowS) -> Show Body
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
(Body -> Body -> Bool) -> (Body -> Body -> Bool) -> Eq Body
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
Eq Body
-> (Body -> Body -> Ordering)
-> (Body -> Body -> Bool)
-> (Body -> Body -> Bool)
-> (Body -> Body -> Bool)
-> (Body -> Body -> Bool)
-> (Body -> Body -> Body)
-> (Body -> Body -> Body)
-> Ord 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
$cp1Ord :: Eq Body
Ord)

instance Arbitrary T where
   arbitrary :: Gen T
arbitrary =
      (Channel -> Body -> T) -> Gen Channel -> Gen Body -> Gen T
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Channel -> Body -> T
Cons
         ((Int -> Channel) -> Gen Int -> Gen Channel
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Channel
toChannel (Gen Int -> Gen Channel) -> Gen Int -> Gen Channel
forall a b. (a -> b) -> a -> b
$ [(Int, Gen Int)] -> Gen Int
forall a. [(Int, Gen a)] -> Gen a
QC.frequency ([(Int, Gen Int)] -> Gen Int) -> [(Int, Gen Int)] -> Gen Int
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, Int -> Gen Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
3) (Int, Gen Int) -> [(Int, Gen Int)] -> [(Int, Gen Int)]
forall a. a -> [a] -> [a]
:
            ( Int
1, (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0,Int
15)) (Int, Gen Int) -> [(Int, Gen Int)] -> [(Int, Gen Int)]
forall a. a -> [a] -> [a]
:
            [])
         ([(Int, Gen Body)] -> Gen Body
forall a. [(Int, Gen a)] -> Gen a
QC.frequency ([(Int, Gen Body)] -> Gen Body) -> [(Int, Gen Body)] -> Gen Body
forall a b. (a -> b) -> a -> b
$
            (Int
20, (T -> Body) -> Gen T -> Gen Body
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Voice Gen T
forall a. Arbitrary a => Gen a
arbitrary) (Int, Gen Body) -> [(Int, Gen Body)] -> [(Int, Gen Body)]
forall a. a -> [a] -> [a]
:
            ( Int
1, (T -> Body) -> Gen T -> Gen Body
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Mode  Gen T
forall a. Arbitrary a => Gen a
arbitrary) (Int, Gen Body) -> [(Int, Gen Body)] -> [(Int, Gen Body)]
forall a. a -> [a] -> [a]
:
            [])
   shrink :: T -> [T]
shrink (Cons Channel
chan Body
body) =
      ((Channel, Body) -> T) -> [(Channel, Body)] -> [T]
forall a b. (a -> b) -> [a] -> [b]
map ((Channel -> Body -> T) -> (Channel, Body) -> T
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Channel -> Body -> T
Cons) ([(Channel, Body)] -> [T]) -> [(Channel, Body)] -> [T]
forall a b. (a -> b) -> a -> b
$
      case Body
body of
         Voice T
v -> ((Channel, T) -> (Channel, Body))
-> [(Channel, T)] -> [(Channel, Body)]
forall a b. (a -> b) -> [a] -> [b]
map ((T -> Body) -> (Channel, T) -> (Channel, Body)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Body
Voice) ([(Channel, T)] -> [(Channel, Body)])
-> [(Channel, T)] -> [(Channel, Body)]
forall a b. (a -> b) -> a -> b
$ (Channel, T) -> [(Channel, T)]
forall a. Arbitrary a => a -> [a]
shrink (Channel
chan, T
v)
         Mode  T
m -> ((Channel, T) -> (Channel, Body))
-> [(Channel, T)] -> [(Channel, Body)]
forall a b. (a -> b) -> [a] -> [b]
map ((T -> Body) -> (Channel, T) -> (Channel, Body)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Body
Mode)  ([(Channel, T)] -> [(Channel, Body)])
-> [(Channel, T)] -> [(Channel, Body)]
forall a b. (a -> b) -> a -> b
$ (Channel, T) -> [(Channel, T)]
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 :: Int -> Fragile (T parser) T
getWithStatus Int
tag =
   do (status :: (Int, Channel)
status@(Int
code, Channel
channel), Int
firstData) <-
         if Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80
           then T (T parser) ((Int, Channel), Int)
-> ((Int, Channel) -> T (T parser) ((Int, Channel), Int))
-> Maybe (Int, Channel)
-> T (T parser) ((Int, Channel), Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                   (String -> T (T parser) ((Int, Channel), Int)
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 -> ((Int, Channel), Int) -> T (T parser) ((Int, Channel), Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Channel)
cc,Int
tag))
                      (Maybe (Int, Channel) -> T (T parser) ((Int, Channel), Int))
-> ExceptionalT String (T parser) (Maybe (Int, Channel))
-> T (T parser) ((Int, Channel), Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptionalT String (T parser) (Maybe (Int, Channel))
forall (parser :: * -> *).
Monad parser =>
Fragile (T parser) (Maybe (Int, Channel))
StatusParser.get
           else (Int -> ((Int, Channel), Int))
-> ExceptionalT String (T parser) Int
-> T (T parser) ((Int, Channel), Int)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) ((Int, Channel) -> Int -> ((Int, Channel), Int))
-> (Int, Channel) -> Int -> ((Int, Channel), Int)
forall a b. (a -> b) -> a -> b
$ Int -> (Int, Channel)
decodeStatus Int
tag) (ExceptionalT String (T parser) Int
 -> T (T parser) ((Int, Channel), Int))
-> ExceptionalT String (T parser) Int
-> T (T parser) ((Int, Channel), Int)
forall a b. (a -> b) -> a -> b
$ Fragile parser Int -> ExceptionalT String (T parser) Int
forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
StatusParser.lift Fragile parser Int
forall (parser :: * -> *). C parser => Fragile parser Int
get1
      Maybe (Int, Channel) -> Fragile (T parser) ()
forall (parser :: * -> *).
Monad parser =>
Maybe (Int, Channel) -> Fragile (T parser) ()
StatusParser.set ((Int, Channel) -> Maybe (Int, Channel)
forall a. a -> Maybe a
Just (Int, Channel)
status)
      Fragile parser T -> Fragile (T parser) T
forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
StatusParser.lift (Fragile parser T -> Fragile (T parser) T)
-> Fragile parser T -> Fragile (T parser) T
forall a b. (a -> b) -> a -> b
$ Int -> Channel -> Int -> Fragile parser T
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  =  (Int -> Channel) -> (Int, Int) -> (Int, Channel)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd Int -> Channel
toChannel ((Int, Int) -> (Int, Channel))
-> (Int -> (Int, Int)) -> Int -> (Int, Channel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> (Int, Int)
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 :: Int -> Channel -> Int -> Fragile parser T
get Int
code Channel
channel Int
firstData =
   (Body -> T) -> ExceptionalT String parser Body -> Fragile parser T
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Channel -> Body -> T
Cons Channel
channel) (ExceptionalT String parser Body -> Fragile parser T)
-> ExceptionalT String parser Body -> Fragile parser T
forall a b. (a -> b) -> a -> b
$
   if Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
11 Bool -> Bool -> Bool
&& Int
firstData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0x78
     then
        Bool
-> ExceptionalT String parser () -> ExceptionalT String parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
firstData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0x80)
           (String -> ExceptionalT String parser ()
forall (m :: * -> *) a. Monad m => String -> T m a
Parser.giveUp (String
"mode value out of range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
firstData)) ExceptionalT String parser ()
-> ExceptionalT String parser Body
-> ExceptionalT String parser Body
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        (T -> Body)
-> ExceptionalT String parser T -> ExceptionalT String parser Body
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Mode (Int -> ExceptionalT String parser T
forall (parser :: * -> *). C parser => Int -> Fragile parser T
Mode.get Int
firstData)
     else (T -> Body)
-> ExceptionalT String parser T -> ExceptionalT String parser Body
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM T -> Body
Voice (Int -> Int -> ExceptionalT String parser T
forall (parser :: * -> *).
C parser =>
Int -> Int -> Fragile parser T
Voice.get Int
code Int
firstData)


put :: Writer.C writer => T -> writer
put :: T -> writer
put = T Uncompressed writer -> writer
forall writer. Monoid writer => T Uncompressed writer -> writer
StatusWriter.toWriterWithoutStatus (T Uncompressed writer -> writer)
-> (T -> T Uncompressed writer) -> T -> writer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> T Uncompressed writer
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 :: T -> T compress writer
putWithStatus (Cons Channel
c Body
e) =
   case Body
e of
      Voice T
v -> (Int -> T compress writer) -> T -> T compress writer
forall writer compress.
C writer =>
(Int -> T compress writer) -> T -> T compress writer
Voice.putWithStatus (Channel -> Int -> T compress writer
forall compress writer.
(Compression compress, C writer) =>
Channel -> Int -> T compress writer
putChannel Channel
c) T
v
      Mode  T
m -> Channel -> Int -> T compress writer
forall compress writer.
(Compression compress, C writer) =>
Channel -> Int -> T compress writer
putChannel Channel
c Int
11 T compress writer -> T compress writer -> T compress writer
forall m. Monoid m => m -> m -> m
+#+ writer -> T compress writer
forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
StatusWriter.lift (T -> writer
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 :: Channel -> Int -> T compress writer
putChannel Channel
chan Int
code =
   (Int, Channel) -> writer -> T compress writer
forall compress writer.
(Compression compress, Monoid writer) =>
(Int, Channel) -> writer -> T compress writer
StatusWriter.change (Int
code, Channel
chan) (writer -> T compress writer) -> writer -> T compress writer
forall a b. (a -> b) -> a -> b
$
      Int -> writer
forall writer. C writer => Int -> writer
Writer.putIntAsByte (Int
16Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
code Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Channel -> Int
fromChannel Channel
chan)