{- |
Parser which handles the running state
that is used in MIDI messages in realtime and files.
The running state consists of a message code and the message channel.
-}
module Sound.MIDI.Parser.Status
   (T, Status, set, get, run, lift,
    Channel, fromChannel, toChannel, ) where

import qualified Sound.MIDI.Parser.Class as Parser

import qualified Control.Monad.Exception.Synchronous  as Sync
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Class as Trans
import Control.Monad.Trans.State (StateT, evalStateT, )
import Control.Monad (liftM, )

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

import Sound.MIDI.Utility (checkRange, )
import Data.Ix (Ix)


{- |
The 'T' monad parses a track of a MIDI File.
In MIDI, a shortcut is used for long strings of similar MIDI events:
If a stream of consecutive events all have the same type and channel,
the type and channel can be omitted for all but the first event.
To implement this /feature/,
the parser must keep track of the type and channel of the most recent MIDI Event.
This is done by managing a 'Status' in the parser.
-}
type T parser = StateT Status parser

type Status = Maybe (Int,Channel)


set :: Monad parser => Status -> Parser.Fragile (T parser) ()
set :: Status -> Fragile (T parser) ()
set = StateT Status parser () -> Fragile (T parser) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (StateT Status parser () -> Fragile (T parser) ())
-> (Status -> StateT Status parser ())
-> Status
-> Fragile (T parser) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> StateT Status parser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put

get :: Monad parser => Parser.Fragile (T parser) Status
get :: Fragile (T parser) Status
get = StateT Status parser Status -> Fragile (T parser) Status
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift StateT Status parser Status
forall (m :: * -> *) s. Monad m => StateT s m s
State.get

run :: Monad parser => T parser a -> parser a
run :: T parser a -> parser a
run = (T parser a -> Status -> parser a)
-> Status -> T parser a -> parser a
forall a b c. (a -> b -> c) -> b -> a -> c
flip T parser a -> Status -> parser a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Status
forall a. Maybe a
Nothing


lift :: Monad parser => Parser.Fragile parser a -> Parser.Fragile (T parser) a
lift :: Fragile parser a -> Fragile (T parser) a
lift = (parser (Exceptional UserMessage a)
 -> StateT Status parser (Exceptional UserMessage a))
-> Fragile parser a -> Fragile (T parser) a
forall (m :: * -> *) e0 a (n :: * -> *) e1 b.
(m (Exceptional e0 a) -> n (Exceptional e1 b))
-> ExceptionalT e0 m a -> ExceptionalT e1 n b
Sync.mapExceptionalT parser (Exceptional UserMessage a)
-> StateT Status parser (Exceptional UserMessage a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift


-- * Channel definition

{- |
This definition should be in Message.Channel,
but this results in a cyclic import.
-}
newtype Channel = Channel {Channel -> Int
fromChannel :: Int} deriving (Int -> Channel -> ShowS
[Channel] -> ShowS
Channel -> UserMessage
(Int -> Channel -> ShowS)
-> (Channel -> UserMessage) -> ([Channel] -> ShowS) -> Show Channel
forall a.
(Int -> a -> ShowS)
-> (a -> UserMessage) -> ([a] -> ShowS) -> Show a
showList :: [Channel] -> ShowS
$cshowList :: [Channel] -> ShowS
show :: Channel -> UserMessage
$cshow :: Channel -> UserMessage
showsPrec :: Int -> Channel -> ShowS
$cshowsPrec :: Int -> Channel -> ShowS
Show, Channel -> Channel -> Bool
(Channel -> Channel -> Bool)
-> (Channel -> Channel -> Bool) -> Eq Channel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Channel -> Channel -> Bool
$c/= :: Channel -> Channel -> Bool
== :: Channel -> Channel -> Bool
$c== :: Channel -> Channel -> Bool
Eq, Eq Channel
Eq Channel
-> (Channel -> Channel -> Ordering)
-> (Channel -> Channel -> Bool)
-> (Channel -> Channel -> Bool)
-> (Channel -> Channel -> Bool)
-> (Channel -> Channel -> Bool)
-> (Channel -> Channel -> Channel)
-> (Channel -> Channel -> Channel)
-> Ord Channel
Channel -> Channel -> Bool
Channel -> Channel -> Ordering
Channel -> Channel -> Channel
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 :: Channel -> Channel -> Channel
$cmin :: Channel -> Channel -> Channel
max :: Channel -> Channel -> Channel
$cmax :: Channel -> Channel -> Channel
>= :: Channel -> Channel -> Bool
$c>= :: Channel -> Channel -> Bool
> :: Channel -> Channel -> Bool
$c> :: Channel -> Channel -> Bool
<= :: Channel -> Channel -> Bool
$c<= :: Channel -> Channel -> Bool
< :: Channel -> Channel -> Bool
$c< :: Channel -> Channel -> Bool
compare :: Channel -> Channel -> Ordering
$ccompare :: Channel -> Channel -> Ordering
$cp1Ord :: Eq Channel
Ord, Ord Channel
Ord Channel
-> ((Channel, Channel) -> [Channel])
-> ((Channel, Channel) -> Channel -> Int)
-> ((Channel, Channel) -> Channel -> Int)
-> ((Channel, Channel) -> Channel -> Bool)
-> ((Channel, Channel) -> Int)
-> ((Channel, Channel) -> Int)
-> Ix Channel
(Channel, Channel) -> Int
(Channel, Channel) -> [Channel]
(Channel, Channel) -> Channel -> Bool
(Channel, Channel) -> Channel -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (Channel, Channel) -> Int
$cunsafeRangeSize :: (Channel, Channel) -> Int
rangeSize :: (Channel, Channel) -> Int
$crangeSize :: (Channel, Channel) -> Int
inRange :: (Channel, Channel) -> Channel -> Bool
$cinRange :: (Channel, Channel) -> Channel -> Bool
unsafeIndex :: (Channel, Channel) -> Channel -> Int
$cunsafeIndex :: (Channel, Channel) -> Channel -> Int
index :: (Channel, Channel) -> Channel -> Int
$cindex :: (Channel, Channel) -> Channel -> Int
range :: (Channel, Channel) -> [Channel]
$crange :: (Channel, Channel) -> [Channel]
$cp1Ix :: Ord Channel
Ix)

toChannel :: Int -> Channel
toChannel :: Int -> Channel
toChannel = UserMessage -> (Int -> Channel) -> Int -> Channel
forall a.
(Bounded a, Ord a, Show a) =>
UserMessage -> (Int -> a) -> Int -> a
checkRange UserMessage
"Channel" Int -> Channel
Channel

instance Enum Channel where
   toEnum :: Int -> Channel
toEnum   = Int -> Channel
toChannel
   fromEnum :: Channel -> Int
fromEnum = Channel -> Int
fromChannel

instance Bounded Channel where
   minBound :: Channel
minBound = Int -> Channel
Channel  Int
0
   maxBound :: Channel
maxBound = Int -> Channel
Channel Int
15

instance Arbitrary Channel where
   arbitrary :: Gen Channel
arbitrary = (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, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0,Int
15)
   shrink :: Channel -> [Channel]
shrink = (Int -> Channel) -> [Int] -> [Channel]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Channel
toChannel (Int -> Channel) -> (Int -> Int) -> Int -> Channel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
16) ([Int] -> [Channel]) -> (Channel -> [Int]) -> Channel -> [Channel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink (Int -> [Int]) -> (Channel -> Int) -> Channel -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Int
fromChannel