{- |
Channel mode messages
-}
module Sound.MIDI.Message.Channel.Mode
    (T(..), get, put,
     fromControllerValue, toControllerValue, ) where

import           Sound.MIDI.Parser.Primitive
import qualified Sound.MIDI.Parser.Class as Parser

import qualified Sound.MIDI.Writer.Basic as Writer

import Sound.MIDI.Parser.Report (UserMessage, )

import qualified Control.Monad.Exception.Asynchronous as Async
import Data.Maybe.HT (toMaybe, )
import Control.Monad.Trans.Class (lift, )
import Control.Monad (liftM, )

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



data T =
     AllSoundOff
   | ResetAllControllers
   | LocalControl Bool
   | AllNotesOff
   | OmniMode Bool
   | MonoMode Int
   | PolyMode
     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)

instance Arbitrary T where
   arbitrary :: Gen T
arbitrary =
      [Gen T] -> Gen T
forall a. [Gen a] -> Gen a
QC.oneof ([Gen T] -> Gen T) -> [Gen T] -> Gen T
forall a b. (a -> b) -> a -> b
$
         T -> Gen T
forall (m :: * -> *) a. Monad m => a -> m a
return T
AllSoundOff Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         T -> Gen T
forall (m :: * -> *) a. Monad m => a -> m a
return T
ResetAllControllers Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         (Bool -> T) -> Gen Bool -> Gen T
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  Bool -> T
LocalControl Gen Bool
forall a. Arbitrary a => Gen a
arbitrary Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         T -> Gen T
forall (m :: * -> *) a. Monad m => a -> m a
return T
AllNotesOff Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         (Bool -> T) -> Gen Bool -> Gen T
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  Bool -> T
OmniMode Gen Bool
forall a. Arbitrary a => Gen a
arbitrary Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         (Int -> T) -> Gen Int -> Gen T
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  Int -> T
MonoMode ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0,Int
16)) Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         T -> Gen T
forall (m :: * -> *) a. Monad m => a -> m a
return T
PolyMode Gen T -> [Gen T] -> [Gen T]
forall a. a -> [a] -> [a]
:
         []


-- * serialization

get :: Parser.C parser => Int -> Parser.Fragile parser T
get :: Int -> Fragile parser T
get Int
mode =
   do Int
x <- Fragile parser Int
forall (parser :: * -> *). C parser => Fragile parser Int
get1
      parser T -> Fragile parser T
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (parser T -> Fragile parser T) -> parser T -> Fragile parser T
forall a b. (a -> b) -> a -> b
$ PossiblyIncomplete T -> parser T
forall (parser :: * -> *) a.
C parser =>
PossiblyIncomplete a -> parser a
Parser.warnIncomplete (PossiblyIncomplete T -> parser T)
-> PossiblyIncomplete T -> parser T
forall a b. (a -> b) -> a -> b
$ (Maybe String -> T -> PossiblyIncomplete T)
-> (Maybe String, T) -> PossiblyIncomplete T
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe String -> T -> PossiblyIncomplete T
forall e a. Maybe e -> a -> Exceptional e a
Async.Exceptional ((Maybe String, T) -> PossiblyIncomplete T)
-> (Maybe String, T) -> PossiblyIncomplete T
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Maybe String, T)
forall a. (Show a, Integral a) => (a, a) -> (Maybe String, T)
fromControllerValue (Int
mode,Int
x)

{- |
This function is also used in alsa-midi,
we could give it the result type @Parser.PossiblyIncomplete T@ otherwise.
-}
fromControllerValue :: (Show a, Integral a) => (a, a) -> (Maybe UserMessage, T)
fromControllerValue :: (a, a) -> (Maybe String, T)
fromControllerValue (a
mode,a
x) =
   case a
mode of
      a
0x78 ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"AllSoundOff" [a
0] a
x,
          T
AllSoundOff)
      a
0x79 ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"ResetAllControllers" [a
0] a
x,
          T
ResetAllControllers)
      a
0x7A ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"LocalControl" [a
0,a
127] a
x,
          Bool -> T
LocalControl (a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=a
0))
      a
0x7B ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"AllNotesOff" [a
0] a
x,
          T
AllNotesOff)
      a
0x7C ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"OmniMode Off" [a
0] a
x,
          Bool -> T
OmniMode Bool
False)
      a
0x7D ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"OmniMode On" [a
0] a
x,
          Bool -> T
OmniMode Bool
True)
      a
0x7E ->
         (Maybe String
forall a. Maybe a
Nothing, Int -> T
MonoMode (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x))
      a
0x7F ->
         (String -> [a] -> a -> Maybe String
forall a.
(Show a, Integral a) =>
String -> [a] -> a -> Maybe String
checkValidValue String
"PolyMode On" [a
0] a
x,
          T
PolyMode)
      a
_ -> String -> (Maybe String, T)
forall a. HasCallStack => String -> a
error (String
"Channel.Mode.get: mode value out of range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
mode)


checkValidValue ::
   (Show a, Integral a) => String -> [a] -> a -> Maybe UserMessage
checkValidValue :: String -> [a] -> a -> Maybe String
checkValidValue String
name [a]
validValues a
value =
   Bool -> String -> Maybe String
forall a. Bool -> a -> Maybe a
toMaybe
      (Bool -> Bool
not (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
value [a]
validValues))
      (String
"Invalid value for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
value)


put :: Writer.C writer => T -> writer
put :: T -> writer
put T
mode =
   let (Word8
code, Word8
value) = T -> (Word8, Word8)
forall a. Integral a => T -> (a, a)
toControllerValue T
mode
   in  ByteList -> writer
forall writer. C writer => ByteList -> writer
Writer.putByteList [Word8
code, Word8
value]

toControllerValue :: Integral a => T -> (a, a)
toControllerValue :: T -> (a, a)
toControllerValue T
mode =
   case T
mode of
      T
AllSoundOff         -> (,) a
0x78 a
0
      T
ResetAllControllers -> (,) a
0x79 a
0
      LocalControl Bool
b      -> (,) a
0x7A (if Bool
b then a
127 else a
0)
      T
AllNotesOff         -> (,) a
0x7B a
0
      OmniMode Bool
b          -> (,) (if Bool
b then a
0x7D else a
0x7C) a
0
      MonoMode Int
x          -> (,) a
0x7E (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
      T
PolyMode            -> (,) a
0x7F a
0