> module Euterpea.IO.MIDI.Play (
>     play -- standard playback, allows infinite values

>     ,playDev -- play to a custom device, allows infinite values

>     ,playS -- play with strict timing (finite values only)

>     ,playDevS -- play to a custom device with strict timing (finite values only)

>     ,playC -- custom playback implementation to replace playA, playS, playDev, etc.

>     ,devices -- function that prints available MIDI device information

>     ,musicToMsgs' -- music to MIDI message conversion

>     ,linearCP -- linear channel assignment policy

>     ,dynamicCP -- dynamic channel assignment policy

>     ,predefinedCP -- user-specified channel map (for MUIs)

>     ,defParams
>     ,playM'
>     ,PlayParams(..)
>     ,ChannelMapFun
>     ,ChannelMap
>     ) where

> import Codec.Midi hiding (Tempo)
> import Control.DeepSeq
> import Control.Monad
> import Control.Concurrent
> import Control.Exception
> import Data.List
> import Euterpea.IO.MIDI.MidiIO
> import Euterpea.IO.MIDI.ToMidi
> import Euterpea.IO.MIDI.MEvent
> import Euterpea.Music
> import Sound.PortMidi

--------------------------

 | User-Level Functions |
--------------------------


Playback parameter data type.

> data PlayParams = PlayParams{
>     PlayParams -> Bool
strict :: Bool, -- strict timing (False for infinite values)

>     PlayParams -> ChannelMapFun
chanPolicy :: ChannelMapFun, -- channel assignment policy

>     PlayParams -> Maybe OutputDeviceID
devID :: Maybe OutputDeviceID, -- output device (Nothing means to use the OS default)

>     PlayParams -> Time
closeDelay :: Time, -- offset in seconds to avoid truncated notes

>     PlayParams -> Music1 -> [MEvent]
perfAlg :: Music1 -> [MEvent]
>     }

Default parameters are the default pmap+context, allowing for infinite playback,
using a linear channel assignment policy for 16 channels with percussion on
channel 9 (which is channel 10 when indexing from 1), using the default MIDI
device as set by the operating system, and using a closing offset of 1.0sec.

> defParams :: PlayParams
defParams = Bool
-> ChannelMapFun
-> Maybe OutputDeviceID
-> Time
-> (Music1 -> [MEvent])
-> PlayParams
PlayParams Bool
False (Int -> Int -> ChannelMapFun
linearCP Int
16 Int
9) Maybe OutputDeviceID
forall a. Maybe a
Nothing Time
1.0 Music1 -> [MEvent]
perform1

New implementation of play using default parameters:

> play :: (ToMusic1 a, NFData a) => Music a -> IO ()
> play :: forall a. (ToMusic1 a, NFData a) => Music a -> IO ()
play = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams

> playS :: (ToMusic1 a, NFData a) => Music a -> IO ()
> playS :: forall a. (ToMusic1 a, NFData a) => Music a -> IO ()
playS = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams{strict=True}

> playDev :: (ToMusic1 a, NFData a) => Int -> Music a -> IO ()
> playDev :: forall a. (ToMusic1 a, NFData a) => Int -> Music a -> IO ()
playDev Int
i = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams{devID = Just $ unsafeOutputID i}

> playDevS :: (ToMusic1 a, NFData a) => Int -> Music a -> IO()
> playDevS :: forall a. (ToMusic1 a, NFData a) => Int -> Music a -> IO ()
playDevS Int
i = PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
defParams{strict=True, devID = Just $ unsafeOutputID i}

"Custom play" interface:

> playC :: (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
> playC :: forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playC PlayParams
p = if PlayParams -> Bool
strict PlayParams
p then PlayParams -> Music a -> IO ()
forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playStrict PlayParams
p else PlayParams -> Music a -> IO ()
forall a. ToMusic1 a => PlayParams -> Music a -> IO ()
playInf PlayParams
p

Getting a list of all MIDI input and output devices, showing both
their device IDs and names.

> devices :: IO ()
devices = do
>   ([(InputDeviceID, DeviceInfo)]
devsIn, [(OutputDeviceID, DeviceInfo)]
devsOut) <- IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
getAllDevices
>   let f :: (a, DeviceInfo) -> [Char]
f (a
devid, DeviceInfo
devname) = [Char]
"  "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++a -> [Char]
forall a. Show a => a -> [Char]
show a
devid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DeviceInfo -> [Char]
name DeviceInfo
devname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
>       strIn :: [Char]
strIn = ((InputDeviceID, DeviceInfo) -> [Char])
-> [(InputDeviceID, DeviceInfo)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (InputDeviceID, DeviceInfo) -> [Char]
forall {a}. Show a => (a, DeviceInfo) -> [Char]
f [(InputDeviceID, DeviceInfo)]
devsIn
>       strOut :: [Char]
strOut = ((OutputDeviceID, DeviceInfo) -> [Char])
-> [(OutputDeviceID, DeviceInfo)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OutputDeviceID, DeviceInfo) -> [Char]
forall {a}. Show a => (a, DeviceInfo) -> [Char]
f [(OutputDeviceID, DeviceInfo)]
devsOut
>   [Char] -> IO ()
putStrLn [Char]
"\nInput devices: " IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
putStrLn [Char]
strIn
>   [Char] -> IO ()
putStrLn [Char]
"Output devices: " IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
putStrLn [Char]
strOut


------------------------------------

 | Supporting functions for playC |
------------------------------------


Strict playback: timing will be as close to perfect as possible, but the
Music value must be finite. Timing will be correct starting from the first
note, even if there is a long computation offset prior to any sound.

> playStrict :: (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
> playStrict :: forall a. (ToMusic1 a, NFData a) => PlayParams -> Music a -> IO ()
playStrict PlayParams
p Music a
m = Music a
m Music a -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq`
>     let x :: Midi
x = [MEvent] -> Midi
toMidi (PlayParams -> Music1 -> [MEvent]
perfAlg PlayParams
p (Music1 -> [MEvent]) -> Music1 -> [MEvent]
forall a b. (a -> b) -> a -> b
$ Music a -> Music1
forall a. ToMusic1 a => Music a -> Music1
toMusic1 Music a
m)
>     in  Midi
x Midi -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` Maybe OutputDeviceID -> Midi -> IO ()
playM' (PlayParams -> Maybe OutputDeviceID
devID PlayParams
p) Midi
x

> playM' :: Maybe OutputDeviceID -> Midi -> IO ()
> playM' :: Maybe OutputDeviceID -> Midi -> IO ()
playM' Maybe OutputDeviceID
devID Midi
midi = IO () -> IO ()
forall a. IO a -> IO a
handleCtrlC (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
>     IO (Either PMError PMSuccess)
initialize
>     ((Midi -> IO ())
-> (OutputDeviceID -> Midi -> IO ())
-> Maybe OutputDeviceID
-> Midi
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((OutputDeviceID -> Midi -> IO ()) -> Midi -> IO ()
forall a b. (OutputDeviceID -> a -> IO b) -> a -> IO b
defaultOutput OutputDeviceID -> Midi -> IO ()
playMidi) OutputDeviceID -> Midi -> IO ()
playMidi Maybe OutputDeviceID
devID) Midi
midi
>     IO (Either PMError PMSuccess)
terminate
>     () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () where
>     handleCtrlC :: IO a -> IO a
>     handleCtrlC :: forall a. IO a -> IO a
handleCtrlC IO a
op = IO a -> IO (Either PMError PMSuccess) -> IO a
forall a b. IO a -> IO b -> IO a
onException IO a
op IO (Either PMError PMSuccess)
terminate


Infinite playback: arbitrarily long music values can be played, although
with the compromise that timing may be imperfect due to lazy evaluation of
the Music value. Delays may happen if a section of the Music value is time-
consuming to compute. Infinite parallelism is not supported.

> playInf :: ToMusic1 a => PlayParams -> Music a -> IO ()
> playInf :: forall a. ToMusic1 a => PlayParams -> Music a -> IO ()
playInf PlayParams
p Music a
m = IO () -> IO ()
forall a. IO a -> IO a
handleCtrlC (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
>     IO ()
initializeMidi
>     (([(Time, MidiMessage)] -> IO ())
-> (OutputDeviceID -> [(Time, MidiMessage)] -> IO ())
-> Maybe OutputDeviceID
-> [(Time, MidiMessage)]
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((OutputDeviceID -> [(Time, MidiMessage)] -> IO ())
-> [(Time, MidiMessage)] -> IO ()
forall a b. (OutputDeviceID -> a -> IO b) -> a -> IO b
defaultOutput OutputDeviceID -> [(Time, MidiMessage)] -> IO ()
forall {a}.
RealFrac a =>
OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec) OutputDeviceID -> [(Time, MidiMessage)] -> IO ()
forall {a}.
RealFrac a =>
OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec (PlayParams -> Maybe OutputDeviceID
devID PlayParams
p)) ([(Time, MidiMessage)] -> IO ()) -> [(Time, MidiMessage)] -> IO ()
forall a b. (a -> b) -> a -> b
$ PlayParams -> Music a -> [(Time, MidiMessage)]
forall a.
ToMusic1 a =>
PlayParams -> Music a -> [(Time, MidiMessage)]
musicToMsgs' PlayParams
p Music a
m
>     Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Time -> Int
forall b. Integral b => Time -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (PlayParams -> Time
closeDelay PlayParams
p Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
1000000)
>     IO ()
terminateMidi
>     () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () where
>     handleCtrlC :: IO a -> IO a
>     handleCtrlC :: forall a. IO a -> IO a
handleCtrlC IO a
op = do
>         OutputDeviceID
dev <- Maybe OutputDeviceID -> IO OutputDeviceID
resolveOutDev (PlayParams -> Maybe OutputDeviceID
devID PlayParams
p)
>         IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
onException IO a
op (OutputDeviceID -> Int -> IO ()
stopMidiOut (OutputDeviceID
dev) Int
16)

Bug fix on Sept 24, 2018: on Mac, the default output device may not be zero.
In rare cases on Mac, there are outputs but the default ID is Nothing, but
in these cases the default always seems to be the first output in the list.

> resolveOutDev :: Maybe OutputDeviceID -> IO OutputDeviceID
resolveOutDev Maybe OutputDeviceID
Nothing = do
>    Maybe Int
outDevM <- IO (Maybe Int)
getDefaultOutputDeviceID
>    ([(InputDeviceID, DeviceInfo)]
ins,[(OutputDeviceID, DeviceInfo)]
outs) <- IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
getAllDevices
>    let allOutDevs :: [OutputDeviceID]
allOutDevs = ((OutputDeviceID, DeviceInfo) -> OutputDeviceID)
-> [(OutputDeviceID, DeviceInfo)] -> [OutputDeviceID]
forall a b. (a -> b) -> [a] -> [b]
map (OutputDeviceID, DeviceInfo) -> OutputDeviceID
forall a b. (a, b) -> a
fst [(OutputDeviceID, DeviceInfo)]
outs
>    let outDev :: OutputDeviceID
outDev = case Maybe Int
outDevM of
>                     Maybe Int
Nothing ->
>                            if [OutputDeviceID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OutputDeviceID]
allOutDevs then [Char] -> OutputDeviceID
forall a. HasCallStack => [Char] -> a
error [Char]
"No MIDI outputs!"
>                            else [OutputDeviceID] -> OutputDeviceID
forall a. HasCallStack => [a] -> a
head [OutputDeviceID]
allOutDevs
>                     Just Int
x -> Int -> OutputDeviceID
unsafeOutputID Int
x
>    OutputDeviceID -> IO OutputDeviceID
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputDeviceID
outDev
> resolveOutDev (Just OutputDeviceID
x) = OutputDeviceID -> IO OutputDeviceID
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputDeviceID
x

> stopMidiOut :: OutputDeviceID -> Channel -> IO ()
> stopMidiOut :: OutputDeviceID -> Int -> IO ()
stopMidiOut OutputDeviceID
dev Int
i = if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0 then Int -> IO ()
threadDelay Int
1000000 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
terminateMidi else do
>     OutputDeviceID -> (Time, MidiMessage) -> IO ()
deliverMidiEvent OutputDeviceID
dev (Time
0, Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Message
ControlChange Int
i Int
123 Int
0)
>     OutputDeviceID -> Int -> IO ()
stopMidiOut OutputDeviceID
dev (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

> playRec :: OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec OutputDeviceID
dev [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
> playRec OutputDeviceID
dev (x :: (a, MidiMessage)
x@(a
t,MidiMessage
m):[(a, MidiMessage)]
ms) =
>     if a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then Int -> IO ()
threadDelay (a -> Int
forall {a} {b}. (RealFrac a, Integral b) => a -> b
toMicroSec a
t) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec OutputDeviceID
dev ((a
0,MidiMessage
m)(a, MidiMessage) -> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. a -> [a] -> [a]
:[(a, MidiMessage)]
ms) else
>     let mNow :: [(a, MidiMessage)]
mNow = (a, MidiMessage)
x (a, MidiMessage) -> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. a -> [a] -> [a]
: ((a, MidiMessage) -> Bool)
-> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
0)(a -> Bool) -> ((a, MidiMessage) -> a) -> (a, MidiMessage) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, MidiMessage) -> a
forall a b. (a, b) -> a
fst) [(a, MidiMessage)]
ms
>         mLater :: [(a, MidiMessage)]
mLater = Int -> [(a, MidiMessage)] -> [(a, MidiMessage)]
forall a. Int -> [a] -> [a]
drop ([(a, MidiMessage)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, MidiMessage)]
mNow Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [(a, MidiMessage)]
ms
>     in  OutputDeviceID -> Maybe [(a, MidiMessage)] -> IO ()
forall {t :: * -> *} {a}.
Foldable t =>
OutputDeviceID -> Maybe (t (a, MidiMessage)) -> IO ()
doMidiOut OutputDeviceID
dev ([(a, MidiMessage)] -> Maybe [(a, MidiMessage)]
forall a. a -> Maybe a
Just ([(a, MidiMessage)] -> Maybe [(a, MidiMessage)])
-> [(a, MidiMessage)] -> Maybe [(a, MidiMessage)]
forall a b. (a -> b) -> a -> b
$ [(a, MidiMessage)]
mNow) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputDeviceID -> [(a, MidiMessage)] -> IO ()
playRec OutputDeviceID
dev [(a, MidiMessage)]
mLater where
>     doMidiOut :: OutputDeviceID -> Maybe (t (a, MidiMessage)) -> IO ()
doMidiOut OutputDeviceID
dev Maybe (t (a, MidiMessage))
Nothing = OutputDeviceID -> IO ()
outputMidi OutputDeviceID
dev
>     doMidiOut OutputDeviceID
dev (Just t (a, MidiMessage)
ms) = do
>         OutputDeviceID -> IO ()
outputMidi OutputDeviceID
dev
>         ((a, MidiMessage) -> IO ()) -> t (a, MidiMessage) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(a
t,MidiMessage
m) -> OutputDeviceID -> (Time, MidiMessage) -> IO ()
deliverMidiEvent OutputDeviceID
dev (Time
0, MidiMessage
m)) t (a, MidiMessage)
ms
>     toMicroSec :: a -> b
toMicroSec a
x = a -> b
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
1000000)


---------------------------------

 | Music to Message conversion |
---------------------------------


Music to message conversion will take place differently depending
on the channel assignment method. Using linearCP will assign the first
n instruments to channels 0 through n-1 (or 1 through n). Using
dynamicCP will fill up n channels and then replace the last-used
instrument's channel with the new instrument.

Some synthesizers only recognize 10 unique channels, others use the
full 16 allowed by general MIDI. Drums are usually on channel 9
(channel 10 when indexing from 1), but not always.  Sometimes drums
can be assigned to a custom channel.

A ChannelMap stores which instrument is assigned to which channel.
This table is built automatically when playing a Music value; the
user does not need to worry about constructing it.

> type ChannelMap = [(InstrumentName, Channel)]

Given an InstrumentName and a ChannelMap, a ChannelMapFun picks a new
channel to assign to the instrument and retruns both that and the
updated ChannelMap. This is done each time a new InstrumentName is
encountered (in other words, it is not in the current ChannelMap).

> type ChannelMapFun = InstrumentName -> ChannelMap -> (Channel, ChannelMap)

The function below first converts to ANote values and then to Std On/Off
pairs. This is needed to avoid timing issues associated with using ANote
and trying to call terminateMIDI, since if there is an ANote at the end
it will sometimes have its NoteOff lost, which can cause errors.

> musicToMsgs' :: (ToMusic1 a) => PlayParams -> Music a -> [(Time, MidiMessage)]
> musicToMsgs' :: forall a.
ToMusic1 a =>
PlayParams -> Music a -> [(Time, MidiMessage)]
musicToMsgs' PlayParams
p Music a
m =
>     let perf :: [MEvent]
perf = PlayParams -> Music1 -> [MEvent]
perfAlg PlayParams
p (Music1 -> [MEvent]) -> Music1 -> [MEvent]
forall a b. (a -> b) -> a -> b
$ Music a -> Music1
forall a. ToMusic1 a => Music a -> Music1
toMusic1 Music a
m -- obtain the performance

>         evsA :: [(Time, MidiMessage)]
evsA = ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
channelMap (PlayParams -> ChannelMapFun
chanPolicy PlayParams
p) [] [MEvent]
perf -- time-stamped ANote values

>         evs :: [(Time, MidiMessage)]
evs = [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge [(Time, MidiMessage)]
evsA -- merged On/Off events sorted by absolute time

>         times :: [Time]
times = ((Time, MidiMessage) -> Time) -> [(Time, MidiMessage)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time, MidiMessage) -> Time
forall a b. (a, b) -> a
fst [(Time, MidiMessage)]
evs -- absolute times in seconds

>         newTimes :: [Time]
newTimes = (Time -> Time -> Time) -> [Time] -> [Time] -> [Time]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Time -> Time -> Time
forall a. Num a => a -> a -> a
subtract ([Time] -> Time
forall a. HasCallStack => [a] -> a
head [Time]
times Time -> [Time] -> [Time]
forall a. a -> [a] -> [a]
: [Time]
times) [Time]
times -- relative times

>     in  [Time] -> [MidiMessage] -> [(Time, MidiMessage)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Time]
newTimes (((Time, MidiMessage) -> MidiMessage)
-> [(Time, MidiMessage)] -> [MidiMessage]
forall a b. (a -> b) -> [a] -> [b]
map (Time, MidiMessage) -> MidiMessage
forall a b. (a, b) -> b
snd [(Time, MidiMessage)]
evs) where
>     -- stdMerge: converts ANotes into a sorted list of On/Off events

>     stdMerge :: [(Time, MidiMessage)] -> [(Time, MidiMessage)]
>     stdMerge :: [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge [] = []
>     stdMerge ((Time
t,ANote Int
c Int
k Int
v Time
d):[(Time, MidiMessage)]
es) =
>         (Time
t, Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Message
NoteOn Int
c Int
k Int
v) (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
:
>         [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge (((Time, MidiMessage) -> (Time, MidiMessage) -> Ordering)
-> (Time, MidiMessage)
-> [(Time, MidiMessage)]
-> [(Time, MidiMessage)]
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy (\(Time
a,MidiMessage
b) (Time
x,MidiMessage
y) -> Time -> Time -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Time
a Time
x) (Time
tTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
d, Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Message
NoteOff Int
c Int
k Int
v) [(Time, MidiMessage)]
es)
>     stdMerge ((Time, MidiMessage)
e1:[(Time, MidiMessage)]
es) = (Time, MidiMessage)
e1 (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: [(Time, MidiMessage)] -> [(Time, MidiMessage)]
stdMerge [(Time, MidiMessage)]
es
>     -- channelMap: performs instrument assignment for a list of Events

>     channelMap :: ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
>     channelMap :: ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
channelMap ChannelMapFun
cf ChannelMap
cMap [] = []
>     channelMap ChannelMapFun
cf ChannelMap
cMap (MEvent
e:[MEvent]
es) =
>         let i :: InstrumentName
i = MEvent -> InstrumentName
eInst MEvent
e
>             ((Int
chan, ChannelMap
cMap'), Bool
newI) = case InstrumentName -> ChannelMap -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup InstrumentName
i ChannelMap
cMap of Maybe Int
Nothing -> (ChannelMapFun
cf InstrumentName
i ChannelMap
cMap, Bool
True)
>                                                           Just Int
x  -> ((Int
x, ChannelMap
cMap), Bool
False)
>             e' :: (Time, MidiMessage)
e' = (Rational -> Time
forall a. Fractional a => Rational -> a
fromRational (MEvent -> Rational
eTime MEvent
e),
>                   Int -> Int -> Int -> Time -> MidiMessage
ANote Int
chan (MEvent -> Int
ePitch MEvent
e) (MEvent -> Int
eVol MEvent
e) (Rational -> Time
forall a. Fractional a => Rational -> a
fromRational (Rational -> Time) -> Rational -> Time
forall a b. (a -> b) -> a -> b
$ MEvent -> Rational
eDur MEvent
e))
>             es' :: [(Time, MidiMessage)]
es' = ChannelMapFun -> ChannelMap -> [MEvent] -> [(Time, MidiMessage)]
channelMap ChannelMapFun
cf ChannelMap
cMap' [MEvent]
es
>             iNum :: Int
iNum = if InstrumentName
iInstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
==InstrumentName
Percussion then Int
0 else InstrumentName -> Int
forall a. Enum a => a -> Int
fromEnum InstrumentName
i
>         in  if Bool
newI then ((Time, MidiMessage) -> Time
forall a b. (a, b) -> a
fst (Time, MidiMessage)
e', Message -> MidiMessage
Std (Message -> MidiMessage) -> Message -> MidiMessage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Message
ProgramChange Int
chan Int
iNum) (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: (Time, MidiMessage)
e' (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: [(Time, MidiMessage)]
es'
>             else (Time, MidiMessage)
e' (Time, MidiMessage)
-> [(Time, MidiMessage)] -> [(Time, MidiMessage)]
forall a. a -> [a] -> [a]
: [(Time, MidiMessage)]
es'

The linearCP channel map just fills up channels left to right until it hits
the maximum number and then throws an error. Percussion is handled as a
special case.

> type NumChannels = Int -- maximum number of channels (i.e. 0-15 is 16 channels)

> type PercChan = Int -- percussion channel, using indexing from zero


> linearCP :: NumChannels -> PercChan -> ChannelMapFun
> linearCP :: Int -> Int -> ChannelMapFun
linearCP Int
cLim Int
pChan InstrumentName
i ChannelMap
cMap = if InstrumentName
iInstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
==InstrumentName
Percussion then (Int
pChan, (InstrumentName
i,Int
pChan)(InstrumentName, Int) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
:ChannelMap
cMap) else
>     let n :: Int
n = ChannelMap -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ChannelMap -> Int) -> ChannelMap -> Int
forall a b. (a -> b) -> a -> b
$ ((InstrumentName, Int) -> Bool) -> ChannelMap -> ChannelMap
forall a. (a -> Bool) -> [a] -> [a]
filter ((InstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
/=InstrumentName
Percussion)(InstrumentName -> Bool)
-> ((InstrumentName, Int) -> InstrumentName)
-> (InstrumentName, Int)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName, Int) -> InstrumentName
forall a b. (a, b) -> a
fst) ChannelMap
cMap
>         newChan :: Int
newChan = if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
pChan then Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 else Int
n -- step over the percussion channel

>     in if Int
newChan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cLim then (Int
newChan, (InstrumentName
i, Int
newChan) (InstrumentName, Int) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
: ChannelMap
cMap) else
>        [Char] -> (Int, ChannelMap)
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot use more than "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cLim[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" instruments.")

For the dynamicCP channel map, new assignements are added in the left side
of the channel map/list. This means that the item farthest to the right
is the oldest and should be replaced when the table is full. Percussion
is handled separately.

> dynamicCP :: NumChannels -> PercChan -> ChannelMapFun
> dynamicCP :: Int -> Int -> ChannelMapFun
dynamicCP Int
cLim Int
pChan InstrumentName
i ChannelMap
cMap =
>     if InstrumentName
iInstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
==InstrumentName
Percussion then (Int
pChan, (InstrumentName
i, Int
pChan)(InstrumentName, Int) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
:ChannelMap
cMap) else
>         let cMapNoP :: ChannelMap
cMapNoP = ((InstrumentName, Int) -> Bool) -> ChannelMap -> ChannelMap
forall a. (a -> Bool) -> [a] -> [a]
filter ((InstrumentName -> InstrumentName -> Bool
forall a. Eq a => a -> a -> Bool
/=InstrumentName
Percussion)(InstrumentName -> Bool)
-> ((InstrumentName, Int) -> InstrumentName)
-> (InstrumentName, Int)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstrumentName, Int) -> InstrumentName
forall a b. (a, b) -> a
fst) ChannelMap
cMap
>             extra :: ChannelMap
extra = if ChannelMap -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ChannelMap
cMapNoP Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ChannelMap -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ChannelMap
cMap then [] else [(InstrumentName
Percussion, Int
pChan)]
>             newChan :: Int
newChan = (InstrumentName, Int) -> Int
forall a b. (a, b) -> b
snd ((InstrumentName, Int) -> Int) -> (InstrumentName, Int) -> Int
forall a b. (a -> b) -> a -> b
$ ChannelMap -> (InstrumentName, Int)
forall a. HasCallStack => [a] -> a
last ChannelMap
cMapNoP
>         in  if ChannelMap -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ChannelMap
cMapNoP Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cLim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then Int -> Int -> ChannelMapFun
linearCP Int
cLim Int
pChan InstrumentName
i ChannelMap
cMap
>         else (Int
newChan, (InstrumentName
i, Int
newChan) (InstrumentName, Int) -> ChannelMap -> ChannelMap
forall a. a -> [a] -> [a]
: (Int -> ChannelMap -> ChannelMap
forall a. Int -> [a] -> [a]
take (ChannelMap -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ChannelMap
cMapNoP Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ChannelMap
cMapNoP)ChannelMap -> ChannelMap -> ChannelMap
forall a. [a] -> [a] -> [a]
++ChannelMap
extra)


A predefined policy will send instruments to user-defined channels. If new
instruments are found that are not accounted for, an error is thrown.

> predefinedCP :: ChannelMap -> ChannelMapFun
> predefinedCP :: ChannelMap -> ChannelMapFun
predefinedCP ChannelMap
cMapFixed InstrumentName
i ChannelMap
_ = case InstrumentName -> ChannelMap -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup InstrumentName
i ChannelMap
cMapFixed of
>     Maybe Int
Nothing -> [Char] -> (Int, ChannelMap)
forall a. HasCallStack => [Char] -> a
error (InstrumentName -> [Char]
forall a. Show a => a -> [Char]
show InstrumentName
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not included in the channel map.")
>     Just Int
c -> (Int
c, ChannelMap
cMapFixed)

-------------------------------

 | NFData instances for Midi |
-------------------------------


> instance NFData FileType where
>     rnf :: FileType -> ()
rnf FileType
x = ()

> instance NFData TimeDiv where
>     rnf :: TimeDiv -> ()
rnf (TicksPerBeat Int
i) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
i
>     rnf (TicksPerSecond Int
i Int
j) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
j () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
i

> instance NFData Midi where
>     rnf :: Midi -> ()
rnf (Midi FileType
ft TimeDiv
td [Track Int]
ts) = FileType -> ()
forall a. NFData a => a -> ()
rnf FileType
ft () -> () -> ()
forall a b. a -> b -> b
`seq` TimeDiv -> ()
forall a. NFData a => a -> ()
rnf TimeDiv
td () -> () -> ()
forall a b. a -> b -> b
`seq` [Track Int] -> ()
forall a. NFData a => a -> ()
rnf [Track Int]
ts

> instance NFData Message where
>     rnf :: Message -> ()
rnf (NoteOff Int
c Int
k Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
k () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (NoteOn Int
c Int
k Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
k () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (KeyPressure Int
c Int
k Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
k () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (ProgramChange Int
c Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (ChannelPressure Int
c Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (PitchWheel Int
c Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (TempoChange Int
t) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
t
>     rnf Message
x = () -- no other message types are currently used by Euterpea


> instance NFData MidiMessage where
>     rnf :: MidiMessage -> ()
rnf (Std Message
m) = Message -> ()
forall a. NFData a => a -> ()
rnf Message
m
>     rnf (ANote Int
c Int
k Int
v Time
d) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
c () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
k () -> () -> ()
forall a b. a -> b -> b
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
v () -> () -> ()
forall a b. a -> b -> b
`seq` Time -> ()
forall a. NFData a => a -> ()
rnf Time
d


--------------------------------

 | NFData instances for Music |
--------------------------------


> instance NFData a => NFData (Music a) where
>     rnf :: Music a -> ()
rnf (Music a
a :+: Music a
b) = Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
a () -> () -> ()
forall a b. a -> b -> b
`seq` Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
b
>     rnf (Music a
a :=: Music a
b) = Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
a () -> () -> ()
forall a b. a -> b -> b
`seq` Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
b
>     rnf (Prim Primitive a
p) = Primitive a -> ()
forall a. NFData a => a -> ()
rnf Primitive a
p
>     rnf (Modify Control
c Music a
m) = Control -> ()
forall a. NFData a => a -> ()
rnf Control
c () -> () -> ()
forall a b. a -> b -> b
`seq` Music a -> ()
forall a. NFData a => a -> ()
rnf Music a
m

> instance NFData a => NFData (Primitive a) where
>     rnf :: Primitive a -> ()
rnf (Note Rational
d a
a) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
d () -> () -> ()
forall a b. a -> b -> b
`seq` a -> ()
forall a. NFData a => a -> ()
rnf a
a
>     rnf (Rest Rational
d) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
d

> instance NFData Control where
>     rnf :: Control -> ()
rnf (Tempo Rational
t) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
t
>     rnf (Transpose Int
t) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
t
>     rnf (Instrument InstrumentName
i) = InstrumentName -> ()
forall a. NFData a => a -> ()
rnf InstrumentName
i
>     rnf (Phrase [PhraseAttribute]
xs) = [PhraseAttribute] -> ()
forall a. NFData a => a -> ()
rnf [PhraseAttribute]
xs
>     rnf (Custom [Char]
s) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
s
>     rnf (KeySig PitchClass
r Mode
m) = PitchClass -> ()
forall a. NFData a => a -> ()
rnf PitchClass
r () -> () -> ()
forall a b. a -> b -> b
`seq` Mode -> ()
forall a. NFData a => a -> ()
rnf Mode
m

> instance NFData PitchClass where
>     rnf :: PitchClass -> ()
rnf PitchClass
p = ()

> instance NFData Mode where
>     rnf :: Mode -> ()
rnf Mode
x = ()

> instance NFData PhraseAttribute where
>     rnf :: PhraseAttribute -> ()
rnf (Dyn Dynamic
d) = Dynamic -> ()
forall a. NFData a => a -> ()
rnf Dynamic
d
>     rnf (Tmp Tempo
t) = Tempo -> ()
forall a. NFData a => a -> ()
rnf Tempo
t
>     rnf (Art Articulation
a) = Articulation -> ()
forall a. NFData a => a -> ()
rnf Articulation
a
>     rnf (Orn Ornament
o) = Ornament -> ()
forall a. NFData a => a -> ()
rnf Ornament
o

> instance NFData Dynamic where
>     rnf :: Dynamic -> ()
rnf (Accent Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Crescendo Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Diminuendo Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (StdLoudness StdLoudness
x) = StdLoudness -> ()
forall a. NFData a => a -> ()
rnf StdLoudness
x
>     rnf (Loudness Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r

> instance NFData StdLoudness where
>     rnf :: StdLoudness -> ()
rnf StdLoudness
x = ()

> instance NFData Articulation where
>     rnf :: Articulation -> ()
rnf (Staccato Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Legato Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf Articulation
x = ()

> instance NFData Ornament where
>     rnf :: Ornament -> ()
rnf Ornament
x = ()

> instance NFData Tempo where
>     rnf :: Tempo -> ()
rnf (Ritardando Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r
>     rnf (Accelerando Rational
r) = Rational -> ()
forall a. NFData a => a -> ()
rnf Rational
r

> instance NFData InstrumentName where
>     rnf :: InstrumentName -> ()
rnf InstrumentName
x = ()

> instance NFData NoteAttribute where
>     rnf :: NoteAttribute -> ()
rnf (Volume Int
v) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
v
>     rnf (Fingering Integer
f) = Integer -> ()
forall a. NFData a => a -> ()
rnf Integer
f
>     rnf (Dynamics [Char]
d) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
d
>     rnf (Params [Time]
p) = [Time] -> ()
forall a. NFData a => a -> ()
rnf [Time]
p