> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> module Euterpea.IO.MIDI.MidiIO (
>   getAllDevices, --isValidInputDevice, isValidOutputDevice, -- Used only by Euterpea.IO.MUI.MidiWidgets

>   terminateMidi, initializeMidi, -- Used only by Euterpea.IO.MUI

>   outputMidi, deliverMidiEvent, -- Used only by Euterpea.IO.MUI.MidiWidgets (particularly by midiOut)

>   pollMidi, -- Used only by Euterpea.IO.MUI.MidiWidgets (particularly by midiIn)

>   defaultOutput, defaultInput,
>   playMidi,
>   MidiMessage (ANote, Std),
>   getTimeNow,
>   DeviceInfo(..), InputDeviceID, OutputDeviceID, Message(..), Time,
>   unsafeInputID, unsafeOutputID,
> ) where

> import Codec.Midi (Time, Channel, Key, Velocity,
>                    Message (..), Midi (..), Track,
>                    toRealTime, toAbsTime, toSingleTrack, isTrackEnd)
> import Sound.PortMidi (DeviceInfo (..), getDeviceInfo,
>                        DeviceID, countDevices, time,
>                        getDefaultOutputDeviceID, getDefaultInputDeviceID,
>                        openInput, openOutput, readEvents,
>                        close, writeShort, getErrorText, terminate, initialize,
>                        PMStream, PMError (..),
>                        PMEvent (..), PMMsg (PMMsg), 
>                        encodeMsg, decodeMsg,
>                        PMSuccess (..))
> import Control.Exception (finally)
> import Control.Concurrent
> import Control.Concurrent.STM.TChan
> import Control.Monad.STM (atomically)
> import Data.IORef

> import Data.Bits (shiftR, shiftL, (.|.), (.&.))
> import Data.List (findIndex)
> import Data.Maybe (mapMaybe)
> import qualified Data.Heap as Heap

> import System.IO (hPutStrLn, stderr)
> import System.IO.Unsafe (unsafePerformIO)
> import Control.DeepSeq (NFData)


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

 | Midi Type declarations |
----------------------------


> type MidiEvent = (Time, MidiMessage)

> data MidiMessage = ANote { MidiMessage -> Key
channel :: !Channel, MidiMessage -> Key
key :: !Key,
>                           MidiMessage -> Key
velocity :: !Velocity, MidiMessage -> Time
duration :: !Time }
>                  | Std Message
>   deriving Key -> MidiMessage -> ShowS
[MidiMessage] -> ShowS
MidiMessage -> String
(Key -> MidiMessage -> ShowS)
-> (MidiMessage -> String)
-> ([MidiMessage] -> ShowS)
-> Show MidiMessage
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> MidiMessage -> ShowS
showsPrec :: Key -> MidiMessage -> ShowS
$cshow :: MidiMessage -> String
show :: MidiMessage -> String
$cshowList :: [MidiMessage] -> ShowS
showList :: [MidiMessage] -> ShowS
Show

> newtype InputDeviceID  = InputDeviceID  DeviceID
>   deriving (InputDeviceID -> InputDeviceID -> Bool
(InputDeviceID -> InputDeviceID -> Bool)
-> (InputDeviceID -> InputDeviceID -> Bool) -> Eq InputDeviceID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InputDeviceID -> InputDeviceID -> Bool
== :: InputDeviceID -> InputDeviceID -> Bool
$c/= :: InputDeviceID -> InputDeviceID -> Bool
/= :: InputDeviceID -> InputDeviceID -> Bool
Eq, Key -> InputDeviceID -> ShowS
[InputDeviceID] -> ShowS
InputDeviceID -> String
(Key -> InputDeviceID -> ShowS)
-> (InputDeviceID -> String)
-> ([InputDeviceID] -> ShowS)
-> Show InputDeviceID
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> InputDeviceID -> ShowS
showsPrec :: Key -> InputDeviceID -> ShowS
$cshow :: InputDeviceID -> String
show :: InputDeviceID -> String
$cshowList :: [InputDeviceID] -> ShowS
showList :: [InputDeviceID] -> ShowS
Show, InputDeviceID -> ()
(InputDeviceID -> ()) -> NFData InputDeviceID
forall a. (a -> ()) -> NFData a
$crnf :: InputDeviceID -> ()
rnf :: InputDeviceID -> ()
NFData)
> newtype OutputDeviceID = OutputDeviceID DeviceID
>   deriving (OutputDeviceID -> OutputDeviceID -> Bool
(OutputDeviceID -> OutputDeviceID -> Bool)
-> (OutputDeviceID -> OutputDeviceID -> Bool) -> Eq OutputDeviceID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputDeviceID -> OutputDeviceID -> Bool
== :: OutputDeviceID -> OutputDeviceID -> Bool
$c/= :: OutputDeviceID -> OutputDeviceID -> Bool
/= :: OutputDeviceID -> OutputDeviceID -> Bool
Eq, Key -> OutputDeviceID -> ShowS
[OutputDeviceID] -> ShowS
OutputDeviceID -> String
(Key -> OutputDeviceID -> ShowS)
-> (OutputDeviceID -> String)
-> ([OutputDeviceID] -> ShowS)
-> Show OutputDeviceID
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> OutputDeviceID -> ShowS
showsPrec :: Key -> OutputDeviceID -> ShowS
$cshow :: OutputDeviceID -> String
show :: OutputDeviceID -> String
$cshowList :: [OutputDeviceID] -> ShowS
showList :: [OutputDeviceID] -> ShowS
Show, OutputDeviceID -> ()
(OutputDeviceID -> ()) -> NFData OutputDeviceID
forall a. (a -> ()) -> NFData a
$crnf :: OutputDeviceID -> ()
rnf :: OutputDeviceID -> ()
NFData)

> unsafeInputID :: Int -> InputDeviceID
> unsafeInputID :: Key -> InputDeviceID
unsafeInputID = Key -> InputDeviceID
InputDeviceID

> unsafeOutputID :: Int -> OutputDeviceID
> unsafeOutputID :: Key -> OutputDeviceID
unsafeOutputID = Key -> OutputDeviceID
OutputDeviceID

----------

 | Time |
----------


Is this the time we want?  This comes from PortMidi, but there's also the
function FRP.UISF.SOE.timeGetTime which uses time data from GLFW.

> getTimeNow :: IO Time
> getTimeNow :: IO Time
getTimeNow = do
>   Timestamp
t <- IO Timestamp
time
>   Time -> IO Time
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Timestamp -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Timestamp
t Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
1000)


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

 | Device Functions |
----------------------


getAllDevices returns a list of all of the DeviceInfos found.
It calls Port.Midi.getDeviceInfo over all device numbers

> getAllDevices :: IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
> getAllDevices :: IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
getAllDevices = do
>   Key
n <- IO Key
countDevices
>   [DeviceInfo]
deviceInfos <- (Key -> IO DeviceInfo) -> [Key] -> IO [DeviceInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Key -> IO DeviceInfo
getDeviceInfo [Key
0..Key
nKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1]
>   let devs :: [(Key, DeviceInfo)]
devs = [Key] -> [DeviceInfo] -> [(Key, DeviceInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
0..Key
nKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1] [DeviceInfo]
deviceInfos
>   ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
-> IO
     ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ (Key -> InputDeviceID
InputDeviceID  Key
d, DeviceInfo
i) | (Key
d,DeviceInfo
i) <- [(Key, DeviceInfo)]
devs, DeviceInfo -> Bool
input  DeviceInfo
i],
>           [ (Key -> OutputDeviceID
OutputDeviceID Key
d, DeviceInfo
i) | (Key
d,DeviceInfo
i) <- [(Key, DeviceInfo)]
devs, DeviceInfo -> Bool
output DeviceInfo
i])


isValidInputDevice and isValideOutputDevice check whether the given
devices are respectively valid for input or output.

isValidInputDevice, isValidOutputDevice :: DeviceID -> IO Bool
isValidInputDevice = isValidDevice input
isValidOutputDevice = isValidDevice output
isValidDevice :: (DeviceInfo -> Bool) -> DeviceID -> IO Bool
isValidDevice pred i = do
  n <- countDevices
  info <- getAllDevices
  return $
    i >= 0 && i < n && pred (snd $ info !! i)


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

 | Default devices |
---------------------


Rather than export the deviceIDs directly, these two functions allow
the caller to use the DeviceID without directly controlling it.

They take a function (such as playMidi) and an auxiary argument and
apply them together with the default device.  If no default device
exists, an error is thrown.

> defaultOutput :: (OutputDeviceID -> a -> IO b) -> a -> IO b
> defaultOutput :: forall a b. (OutputDeviceID -> a -> IO b) -> a -> IO b
defaultOutput OutputDeviceID -> a -> IO b
f a
a = do
>   Maybe Key
i <- IO (Maybe Key)
getDefaultOutputDeviceID
>   case Maybe Key
i of
>     Maybe Key
Nothing -> String -> IO b
forall a. HasCallStack => String -> a
error String
"No MIDI output device found"
>     Just Key
i  -> OutputDeviceID -> a -> IO b
f (Key -> OutputDeviceID
OutputDeviceID Key
i) a
a
>
> defaultInput :: (InputDeviceID -> a -> IO b) -> a -> IO b
> defaultInput :: forall a b. (InputDeviceID -> a -> IO b) -> a -> IO b
defaultInput InputDeviceID -> a -> IO b
f a
a = do
>   Maybe Key
i <- IO (Maybe Key)
getDefaultInputDeviceID
>   case Maybe Key
i of
>     Maybe Key
Nothing -> String -> IO b
forall a. HasCallStack => String -> a
error String
"No MIDI input device found"
>     Just Key
i  -> InputDeviceID -> a -> IO b
f (Key -> InputDeviceID
InputDeviceID Key
i) a
a


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

 | Priority Channels |
-----------------------


The priority channel data type and a constructor for it will be used
by devices.  We define them here.

> data PrioChannel a b = PrioChannel
>     { forall a b. PrioChannel a b -> IO (MinPrioHeap a b)
get           :: IO (Heap.MinPrioHeap a b),
>       forall a b. PrioChannel a b -> a -> b -> IO ()
push          :: a -> b -> IO (),
>       forall a b. PrioChannel a b -> IO (a, b)
pop           :: IO (a,b),
>       forall a b. PrioChannel a b -> IO (Maybe (a, b))
peek          :: IO (Maybe (a,b)) }

> makePriorityChannel :: IO (PrioChannel Time Message)
> makePriorityChannel :: IO (PrioChannel Time Message)
makePriorityChannel = do
>   IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
heapRef <- HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
-> IO
     (IORef
        (HeapT
           (Prio FstMinPolicy (Time, Message))
           (Val FstMinPolicy (Time, Message))))
forall a. a -> IO (IORef a)
newIORef (HeapT (Prio FstMinPolicy (Time, Message)) Message
HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
forall prio val. HeapT prio val
Heap.empty :: Heap.MinPrioHeap Time Message)
>   let get :: IO
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
get = IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
-> IO
     (HeapT
        (Prio FstMinPolicy (Time, Message))
        (Val FstMinPolicy (Time, Message)))
forall a. IORef a -> IO a
readIORef IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
heapRef
>       push :: Time -> Message -> IO ()
push Time
a Message
b = IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
-> (HeapT
      (Prio FstMinPolicy (Time, Message))
      (Val FstMinPolicy (Time, Message))
    -> HeapT
         (Prio FstMinPolicy (Time, Message))
         (Val FstMinPolicy (Time, Message)))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
heapRef ((Time, Message)
-> HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message))
-> HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message))
forall pol item.
HeapItem pol item =>
item -> Heap pol item -> Heap pol item
Heap.insert (Time
a,Message
b))
>       pop :: IO (Time, Message)
pop = do
>         HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
h <- IO
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
get
>         let Just ((Time, Message)
a, HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
h') = HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
-> Maybe
     ((Time, Message),
      HeapT
        (Prio FstMinPolicy (Time, Message))
        (Val FstMinPolicy (Time, Message)))
forall pol item.
HeapItem pol item =>
Heap pol item -> Maybe (item, Heap pol item)
Heap.view HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
h
>         IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
-> (HeapT
      (Prio FstMinPolicy (Time, Message))
      (Val FstMinPolicy (Time, Message))
    -> HeapT
         (Prio FstMinPolicy (Time, Message))
         (Val FstMinPolicy (Time, Message)))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
heapRef (\HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
_ -> HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
h')
>         (Time, Message) -> IO (Time, Message)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Time, Message)
a
>       peek :: IO (Maybe (Time, Message))
peek = do
>         HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
h <- IO
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
get
>         Maybe (Time, Message) -> IO (Maybe (Time, Message))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Time, Message) -> IO (Maybe (Time, Message)))
-> Maybe (Time, Message) -> IO (Maybe (Time, Message))
forall a b. (a -> b) -> a -> b
$ HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
-> Maybe (Time, Message)
forall pol item. HeapItem pol item => Heap pol item -> Maybe item
Heap.viewHead HeapT
  (Prio FstMinPolicy (Time, Message))
  (Val FstMinPolicy (Time, Message))
h
>
>   PrioChannel Time Message -> IO (PrioChannel Time Message)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrioChannel Time Message -> IO (PrioChannel Time Message))
-> PrioChannel Time Message -> IO (PrioChannel Time Message)
forall a b. (a -> b) -> a -> b
$ IO
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
-> (Time -> Message -> IO ())
-> IO (Time, Message)
-> IO (Maybe (Time, Message))
-> PrioChannel Time Message
forall a b.
IO (MinPrioHeap a b)
-> (a -> b -> IO ())
-> IO (a, b)
-> IO (Maybe (a, b))
-> PrioChannel a b
PrioChannel IO
  (HeapT
     (Prio FstMinPolicy (Time, Message))
     (Val FstMinPolicy (Time, Message)))
get Time -> Message -> IO ()
push IO (Time, Message)
pop IO (Maybe (Time, Message))
peek


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

 | Global Device Data |
------------------------


We keep a mapping from DeviceID to the priority channel for keeping
track of future MIDI messages, an output function to produce sound,
and a stop function.  This mapping is stored in the global ref
outDevMap, and it is accessed by getOutDev (which looks up info
and adds associations if necessary) and terminateMidi (which calls
the stop function on all elements and clears the mapping).

outDevMap is the global mapping.

> outDevMap :: IORef [(OutputDeviceID,
>                      (PrioChannel Time Message, -- priority channel

>                       (Time, Message) -> IO (), -- sound output function

>                       IO ()))]                  -- stop/terminate function

> outDevMap :: IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
outDevMap = IO
  (IORef
     [(OutputDeviceID,
       (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
-> IORef
     [(OutputDeviceID,
       (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
forall a. IO a -> a
unsafePerformIO (IO
   (IORef
      [(OutputDeviceID,
        (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
 -> IORef
      [(OutputDeviceID,
        (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
-> IO
     (IORef
        [(OutputDeviceID,
          (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
-> IORef
     [(OutputDeviceID,
       (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
forall a b. (a -> b) -> a -> b
$ [(OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> IO
     (IORef
        [(OutputDeviceID,
          (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
forall a. a -> IO (IORef a)
newIORef []


outPort and inPort are global memory refs that contain a mapping of
DeviceID to Port Midi Streams.  They are modified with addPort (which
adds a new mapping to the list) and lookupPort (which, given a DeviceID,
returns the Port Midi Stream associated with it).

> outPort :: IORef [(OutputDeviceID, PMStream)]
> inPort  :: IORef [(InputDeviceID,  PMStream)]
> outPort :: IORef [(OutputDeviceID, PMStream)]
outPort = IO (IORef [(OutputDeviceID, PMStream)])
-> IORef [(OutputDeviceID, PMStream)]
forall a. IO a -> a
unsafePerformIO ([(OutputDeviceID, PMStream)]
-> IO (IORef [(OutputDeviceID, PMStream)])
forall a. a -> IO (IORef a)
newIORef [])
> inPort :: IORef [(InputDeviceID, PMStream)]
inPort  = IO (IORef [(InputDeviceID, PMStream)])
-> IORef [(InputDeviceID, PMStream)]
forall a. IO a -> a
unsafePerformIO ([(InputDeviceID, PMStream)]
-> IO (IORef [(InputDeviceID, PMStream)])
forall a. a -> IO (IORef a)
newIORef [])

> lookupPort :: (Eq deviceid) => IORef [(deviceid, PMStream)] -> deviceid -> IO (Maybe PMStream)
> lookupPort :: forall deviceid.
Eq deviceid =>
IORef [(deviceid, PMStream)] -> deviceid -> IO (Maybe PMStream)
lookupPort IORef [(deviceid, PMStream)]
p deviceid
i = IORef [(deviceid, PMStream)] -> IO [(deviceid, PMStream)]
forall a. IORef a -> IO a
readIORef IORef [(deviceid, PMStream)]
p IO [(deviceid, PMStream)]
-> ([(deviceid, PMStream)] -> IO (Maybe PMStream))
-> IO (Maybe PMStream)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe PMStream -> IO (Maybe PMStream)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PMStream -> IO (Maybe PMStream))
-> ([(deviceid, PMStream)] -> Maybe PMStream)
-> [(deviceid, PMStream)]
-> IO (Maybe PMStream)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. deviceid -> [(deviceid, PMStream)] -> Maybe PMStream
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup deviceid
i)

> addPort :: IORef [(deviceid, PMStream)] -> (deviceid, PMStream) -> IO ()
> addPort :: forall deviceid.
IORef [(deviceid, PMStream)] -> (deviceid, PMStream) -> IO ()
addPort IORef [(deviceid, PMStream)]
p (deviceid, PMStream)
is = IORef [(deviceid, PMStream)]
-> ([(deviceid, PMStream)] -> [(deviceid, PMStream)]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(deviceid, PMStream)]
p ((deviceid, PMStream)
is(deviceid, PMStream)
-> [(deviceid, PMStream)] -> [(deviceid, PMStream)]
forall a. a -> [a] -> [a]
:)


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

 | Global Device Initialization and Termination |
--------------------------------------------------


initializeMidi just initializes PortMidi

> initializeMidi :: IO ()
> initializeMidi :: IO ()
initializeMidi = do
>   Either PMError PMSuccess
e <- IO (Either PMError PMSuccess)
initialize
>   case Either PMError PMSuccess
e of 
>       Right PMSuccess
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>       Left PMError
e' -> String -> PMError -> IO ()
reportError String
"initializeMidi" PMError
e'

terminateMidi calls the stop function on all elements of outDevMap
and clears the mapping entirely.  It also clears outPort and inPort.

> terminateMidi :: IO ()
> terminateMidi :: IO ()
terminateMidi = do
>   [(OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
inits <- IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> IO
     [(OutputDeviceID,
       (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
forall a. IORef a -> IO a
readIORef IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
outDevMap
>   ((OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))
 -> IO ())
-> [(OutputDeviceID,
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(OutputDeviceID
_, (PrioChannel Time Message
_,(Time, Message) -> IO ()
_out,IO ()
stop)) -> IO ()
stop) [(OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
inits
>   IO (Either PMError PMSuccess)
terminate
>   IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> ([(OutputDeviceID,
      (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
    -> [(OutputDeviceID,
         (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
outDevMap ([(OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> [(OutputDeviceID,
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> [(OutputDeviceID,
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
forall a b. a -> b -> a
const [])
>   IORef [(OutputDeviceID, PMStream)]
-> [(OutputDeviceID, PMStream)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [(OutputDeviceID, PMStream)]
outPort []
>   IORef [(InputDeviceID, PMStream)]
-> [(InputDeviceID, PMStream)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [(InputDeviceID, PMStream)]
inPort []


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

 | Device Lookup |
-------------------


getOutDev looks up info in outDevMap and adds associations if necessary.
It is accessed as a helper function for outputMidi and deliverMidiEvent.

> getOutDev :: OutputDeviceID -> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
> getOutDev :: OutputDeviceID
-> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
getOutDev OutputDeviceID
devId = do
>   [(OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
inits <- IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> IO
     [(OutputDeviceID,
       (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
forall a. IORef a -> IO a
readIORef IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
outDevMap
>   case OutputDeviceID
-> [(OutputDeviceID,
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> Maybe
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup OutputDeviceID
devId [(OutputDeviceID,
  (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
inits of
>     Just (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
f -> (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
-> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
f
>     Maybe (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
Nothing -> do
>         Maybe ((Time, Message) -> IO (), IO ())
x <- OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
midiOutRealTime' OutputDeviceID
devId -- Changes made by Donya Quick: this line used to pattern match against Just.

>         PrioChannel Time Message
pChan <- IO (PrioChannel Time Message)
makePriorityChannel
>         case Maybe ((Time, Message) -> IO (), IO ())
x of Just ((Time, Message) -> IO ()
mout,IO ()
stop) -> do -- Case statement added.

>         				IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> ([(OutputDeviceID,
      (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
    -> [(OutputDeviceID,
         (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef
  [(OutputDeviceID,
    (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
outDevMap ((OutputDeviceID
devId,(PrioChannel Time Message
pChan,(Time, Message) -> IO ()
mout,IO ()
stop))(OutputDeviceID,
 (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))
-> [(OutputDeviceID,
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
-> [(OutputDeviceID,
     (PrioChannel Time Message, (Time, Message) -> IO (), IO ()))]
forall a. a -> [a] -> [a]
:)
>         				(PrioChannel Time Message, (Time, Message) -> IO (), IO ())
-> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrioChannel Time Message
pChan,(Time, Message) -> IO ()
mout,IO ()
stop)
>                   Maybe ((Time, Message) -> IO (), IO ())
Nothing -> (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
-> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrioChannel Time Message
pChan, IO () -> (Time, Message) -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()), () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) -- Nothing case added



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

 | Midi Input |
----------------


pollMidi take an input device and a callback function and polls the device
for midi events.  Any events are sent, along with the current time, to
the callback function.
DWC NOTE: Why is the time even used?  All messages get the same time?

> pollMidiCB :: InputDeviceID -> ((Time, [Message]) -> IO ()) -> IO ()
> pollMidiCB :: InputDeviceID -> ((Time, [Message]) -> IO ()) -> IO ()
pollMidiCB idid :: InputDeviceID
idid@(InputDeviceID Key
devId) (Time, [Message]) -> IO ()
callback = do
>   Maybe PMStream
s <- IORef [(InputDeviceID, PMStream)]
-> InputDeviceID -> IO (Maybe PMStream)
forall deviceid.
Eq deviceid =>
IORef [(deviceid, PMStream)] -> deviceid -> IO (Maybe PMStream)
lookupPort IORef [(InputDeviceID, PMStream)]
inPort InputDeviceID
idid
>   case Maybe PMStream
s of
>     Maybe PMStream
Nothing -> do
>       Either PMError PMStream
r <- Key -> IO (Either PMError PMStream)
openInput Key
devId
>       case Either PMError PMStream
r of
>         Left  PMError
e -> String -> PMError -> IO ()
reportError String
"pollMidiCB" PMError
e
>         Right PMStream
s -> IORef [(InputDeviceID, PMStream)]
-> (InputDeviceID, PMStream) -> IO ()
forall deviceid.
IORef [(deviceid, PMStream)] -> (deviceid, PMStream) -> IO ()
addPort IORef [(InputDeviceID, PMStream)]
inPort (InputDeviceID
idid, PMStream
s) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PMStream -> IO ()
input PMStream
s
>     Just PMStream
s -> PMStream -> IO ()
input PMStream
s
>   where
>     input :: PMStream -> IO ()
>     input :: PMStream -> IO ()
input PMStream
s = do
>       Either PMError [PMEvent]
e <- PMStream -> IO (Either PMError [PMEvent])
readEvents PMStream
s
>       case Either PMError [PMEvent]
e of
>         Left  PMError
e -> String -> PMError -> IO ()
reportError String
"pollMidiCB" PMError
e
>         Right [PMEvent]
l -> do
>           Time
now <- IO Time
getTimeNow
>           case (PMEvent -> Maybe Message) -> [PMEvent] -> [Message]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PMMsg -> Maybe Message
msgToMidi (PMMsg -> Maybe Message)
-> (PMEvent -> PMMsg) -> PMEvent -> Maybe Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> PMMsg
decodeMsg (CLong -> PMMsg) -> (PMEvent -> CLong) -> PMEvent -> PMMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PMEvent -> CLong
message) [PMEvent]
l of
>             [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>             [Message]
ms -> (Time, [Message]) -> IO ()
callback (Time
now, [Message]
ms)

> pollMidi :: InputDeviceID -> IO (Maybe (Time, [Message]))
> pollMidi :: InputDeviceID -> IO (Maybe (Time, [Message]))
pollMidi idid :: InputDeviceID
idid@(InputDeviceID Key
devId) = do
>   Maybe PMStream
s <- IORef [(InputDeviceID, PMStream)]
-> InputDeviceID -> IO (Maybe PMStream)
forall deviceid.
Eq deviceid =>
IORef [(deviceid, PMStream)] -> deviceid -> IO (Maybe PMStream)
lookupPort IORef [(InputDeviceID, PMStream)]
inPort InputDeviceID
idid
>   case Maybe PMStream
s of
>     Maybe PMStream
Nothing -> do
>       Either PMError PMStream
r <- Key -> IO (Either PMError PMStream)
openInput Key
devId
>       case Either PMError PMStream
r of
>         Left  PMError
e -> String -> PMError -> IO ()
reportError String
"pollMIDI" PMError
e IO ()
-> IO (Maybe (Time, [Message])) -> IO (Maybe (Time, [Message]))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Time, [Message]) -> IO (Maybe (Time, [Message]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Time, [Message])
forall a. Maybe a
Nothing
>         Right PMStream
s -> IORef [(InputDeviceID, PMStream)]
-> (InputDeviceID, PMStream) -> IO ()
forall deviceid.
IORef [(deviceid, PMStream)] -> (deviceid, PMStream) -> IO ()
addPort IORef [(InputDeviceID, PMStream)]
inPort (InputDeviceID
idid, PMStream
s) IO ()
-> IO (Maybe (Time, [Message])) -> IO (Maybe (Time, [Message]))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PMStream -> IO (Maybe (Time, [Message]))
input PMStream
s
>     Just PMStream
s -> PMStream -> IO (Maybe (Time, [Message]))
input PMStream
s
>   where
>     input :: PMStream -> IO (Maybe (Time, [Message]))
>     input :: PMStream -> IO (Maybe (Time, [Message]))
input PMStream
s = do
>       Either PMError [PMEvent]
e <- PMStream -> IO (Either PMError [PMEvent])
readEvents PMStream
s
>       case Either PMError [PMEvent]
e of
>         Left  PMError
e -> String -> PMError -> IO ()
reportError String
"pollMIDI" PMError
e IO ()
-> IO (Maybe (Time, [Message])) -> IO (Maybe (Time, [Message]))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Time, [Message]) -> IO (Maybe (Time, [Message]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Time, [Message])
forall a. Maybe a
Nothing
>         Right [PMEvent]
l -> do
>           Time
now <- IO Time
getTimeNow
>           case (PMEvent -> Maybe Message) -> [PMEvent] -> [Message]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PMMsg -> Maybe Message
msgToMidi (PMMsg -> Maybe Message)
-> (PMEvent -> PMMsg) -> PMEvent -> Maybe Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> PMMsg
decodeMsg (CLong -> PMMsg) -> (PMEvent -> CLong) -> PMEvent -> PMMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PMEvent -> CLong
message) [PMEvent]
l of
>             [] -> Maybe (Time, [Message]) -> IO (Maybe (Time, [Message]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Time, [Message])
forall a. Maybe a
Nothing
>             [Message]
ms -> Maybe (Time, [Message]) -> IO (Maybe (Time, [Message]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Time, [Message]) -> IO (Maybe (Time, [Message])))
-> Maybe (Time, [Message]) -> IO (Maybe (Time, [Message]))
forall a b. (a -> b) -> a -> b
$ (Time, [Message]) -> Maybe (Time, [Message])
forall a. a -> Maybe a
Just (Time
now, [Message]
ms)


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

 | Midi Output for inidividual Midi events |
---------------------------------------------


The following two functions are for sending and playing individual
Midi events to devices.  Typically, usage will be to call outputMidi
to play anything that's ready to play and then send in the latest
messages with deliverMidiEvent.  Of course, if no new messages are
ready to be delivered, that step can be omitted.  Either way,
outputMidi should be called many times per second to assure that
all Midi messages are played approximately when scheduled.

deliverMidiEvent sends the given MidiEvent to the given device.  If
the event is scheduled to happen ``now'', then it is immediately
played.  Otherwise, it is queued for later.

> deliverMidiEvent :: OutputDeviceID -> MidiEvent -> IO ()
> deliverMidiEvent :: OutputDeviceID -> MidiEvent -> IO ()
deliverMidiEvent OutputDeviceID
devId (Time
t,MidiMessage
m) = do
>   (PrioChannel Time Message
pChan, (Time, Message) -> IO ()
out, IO ()
_stop) <- OutputDeviceID
-> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
getOutDev OutputDeviceID
devId
>   Time
now <- IO Time
getTimeNow
>   let deliver :: Time -> Message -> IO ()
deliver Time
t Message
m = do
>       if Time
t Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
0
>         then (Time, Message) -> IO ()
out (Time
now,Message
m)
>         else PrioChannel Time Message -> Time -> Message -> IO ()
forall a b. PrioChannel a b -> a -> b -> IO ()
push PrioChannel Time Message
pChan (Time
nowTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
t) Message
m
>
>   case MidiMessage
m of
>     Std Message
m -> Time -> Message -> IO ()
deliver Time
t Message
m
>     ANote Key
c Key
k Key
v Time
d -> do
>         Time -> Message -> IO ()
deliver Time
t     (Key -> Key -> Key -> Message
NoteOn Key
c Key
k Key
v)
>         Time -> Message -> IO ()
deliver (Time
tTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
d) (Key -> Key -> Key -> Message
NoteOff Key
c Key
k Key
v)


outputMidi plays all midi events that are waiting in this device's
priority queue whose time to play has come.

> outputMidi :: OutputDeviceID -> IO ()
> outputMidi :: OutputDeviceID -> IO ()
outputMidi OutputDeviceID
devId = do
>   (PrioChannel Time Message
pChan, (Time, Message) -> IO ()
out, IO ()
_stop) <- OutputDeviceID
-> IO (PrioChannel Time Message, (Time, Message) -> IO (), IO ())
getOutDev OutputDeviceID
devId
>   let loop :: IO ()
loop = do
>         Maybe (Time, Message)
r <- PrioChannel Time Message -> IO (Maybe (Time, Message))
forall a b. PrioChannel a b -> IO (Maybe (a, b))
peek PrioChannel Time Message
pChan
>         case Maybe (Time, Message)
r of
>           Maybe (Time, Message)
Nothing     -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>           Just (Time
t,Message
m)  -> do
>             Time
now <- IO Time
getTimeNow
>             if Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
now
>               then (Time, Message) -> IO ()
out (Time
now, Message
m) IO () -> IO (Time, Message) -> IO (Time, Message)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PrioChannel Time Message -> IO (Time, Message)
forall a b. PrioChannel a b -> IO (a, b)
pop PrioChannel Time Message
pChan IO (Time, Message) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
>               else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>   IO ()
loop
>   () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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

 | Midi Output for a complete Midi track |
-------------------------------------------


When an entire Midi track is ready to be played, the playMidi function
may be more appropriate than deliverMidiEvent and outputMidi.

playMidi will queue up the entire Midi track given to it and then close
the output device.

> playMidi :: OutputDeviceID -> Midi -> IO ()
> playMidi :: OutputDeviceID -> Midi -> IO ()
playMidi OutputDeviceID
device midi :: Midi
midi@(Midi FileType
_ TimeDiv
division [Track Key]
_) = do
>   let track :: Track Time
track = TimeDiv -> Track Key -> Track Time
toRealTime TimeDiv
division (Track Key -> Track Key
forall a. Num a => Track a -> Track a
toAbsTime ([Track Key] -> Track Key
forall a. HasCallStack => [a] -> a
head (Midi -> [Track Key]
tracks (Midi -> Midi
toSingleTrack Midi
midi))))
>   Maybe ((Time, Message) -> IO (), IO ())
out <- OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
midiOutRealTime OutputDeviceID
device
>   case Maybe ((Time, Message) -> IO (), IO ())
out of
>     Maybe ((Time, Message) -> IO (), IO ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>     Just ((Time, Message) -> IO ()
out, IO ()
stop) -> do
>       Time
t0 <- IO Time
getTimeNow
>       IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (Time -> Time -> ((Time, Message) -> IO ()) -> Track Time -> IO ()
forall {t} {m :: * -> *}.
(Num t, Monad m) =>
t -> t -> ((t, Message) -> m ()) -> [(t, Message)] -> m ()
playTrack Time
t0 Time
0 (Time, Message) -> IO ()
out Track Time
track) IO ()
stop
>   where
>     playTrack :: t -> t -> ((t, Message) -> m ()) -> [(t, Message)] -> m ()
playTrack t
t0 t
t' (t, Message) -> m ()
out [] = (t, Message) -> m ()
out (t
t0 t -> t -> t
forall a. Num a => a -> a -> a
+ t
t', Message
TrackEnd)
>     playTrack t
t0 t
t' (t, Message) -> m ()
out (e :: (t, Message)
e@(t
t, Message
m) : [(t, Message)]
s) = do
>       (t, Message) -> m ()
out (t
t0 t -> t -> t
forall a. Num a => a -> a -> a
+ t
t, Message
m)
>       if Message -> Bool
isTrackEnd Message
m
>         then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>         else t -> t -> ((t, Message) -> m ()) -> [(t, Message)] -> m ()
playTrack t
t0 t
t (t, Message) -> m ()
out [(t, Message)]
s


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

 | midiOutRealTime |
---------------------


The following two functions are used to open a device for Midi output.
They should only be called when the device hasn't yet been opened, and
they both return a ``play'' function and a ``stop'' function.

Currently, midiOutRealTime' is used for Midi output for inidividual
Midi events, and midiOutRealTime is used for Midi output for a complete
Midi track.

DWC Notes:
I'm not entirely sure how they both work yet.  midiOutRealTime'
actually looks pretty straightforward in that it just creates the process
and stop functions and adds this device to the outPort device list.  The
process function will look up the device in the outPort device list, and
if it finds it, it writes the message to it.  The stop function removes
the device from the outPort list and closes it.

On the other hand, midiOutRealTime spawns a new thread and does some
concurrent stuff.  Really, it looks similar, but I don't know when to
use one and when to use the other.

> midiOutRealTime' :: OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
> midiOutRealTime' :: OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
midiOutRealTime' odid :: OutputDeviceID
odid@(OutputDeviceID Key
devId) = do
>   Either PMError PMStream
s <- Key -> Key -> IO (Either PMError PMStream)
openOutput Key
devId Key
1
>   case Either PMError PMStream
s of
>     Left  PMError
e -> String -> PMError -> IO ()
reportError String
"Unable to open output device in midiOutRealTime'" PMError
e IO ()
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ((Time, Message) -> IO (), IO ())
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Time, Message) -> IO (), IO ())
forall a. Maybe a
Nothing
>     Right PMStream
s -> do
>       IORef [(OutputDeviceID, PMStream)]
-> (OutputDeviceID, PMStream) -> IO ()
forall deviceid.
IORef [(deviceid, PMStream)] -> (deviceid, PMStream) -> IO ()
addPort IORef [(OutputDeviceID, PMStream)]
outPort (OutputDeviceID
odid, PMStream
s)
>       Maybe ((Time, Message) -> IO (), IO ())
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ((Time, Message) -> IO (), IO ())
 -> IO (Maybe ((Time, Message) -> IO (), IO ())))
-> Maybe ((Time, Message) -> IO (), IO ())
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a b. (a -> b) -> a -> b
$ ((Time, Message) -> IO (), IO ())
-> Maybe ((Time, Message) -> IO (), IO ())
forall a. a -> Maybe a
Just (OutputDeviceID -> (Time, Message) -> IO ()
forall {a}. RealFrac a => OutputDeviceID -> (a, Message) -> IO ()
process OutputDeviceID
odid, OutputDeviceID -> IO ()
finalize OutputDeviceID
odid)
>   where
>     process :: OutputDeviceID -> (a, Message) -> IO ()
process OutputDeviceID
odid (a
t, Message
msg) = do
>       Maybe PMStream
s <- IORef [(OutputDeviceID, PMStream)]
-> OutputDeviceID -> IO (Maybe PMStream)
forall deviceid.
Eq deviceid =>
IORef [(deviceid, PMStream)] -> deviceid -> IO (Maybe PMStream)
lookupPort IORef [(OutputDeviceID, PMStream)]
outPort OutputDeviceID
odid
>       case Maybe PMStream
s of
>         Maybe PMStream
Nothing -> String -> IO ()
forall a. HasCallStack => String -> a
error (String
"midiOutRealTime': port " String -> ShowS
forall a. [a] -> [a] -> [a]
++ OutputDeviceID -> String
forall a. Show a => a -> String
show OutputDeviceID
odid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not open for output")
>         Just PMStream
s -> do
>           if Message -> Bool
isTrackEnd Message
msg
>               then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>               else case Message -> Maybe PMMsg
midiEvent Message
msg of
>                 Just PMMsg
m  -> PMStream -> a -> CLong -> IO ()
forall {a}. RealFrac a => PMStream -> a -> CLong -> IO ()
writeMsg PMStream
s a
t (CLong -> IO ()) -> CLong -> IO ()
forall a b. (a -> b) -> a -> b
$ PMMsg -> CLong
encodeMsg PMMsg
m
>                 Maybe PMMsg
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>     writeMsg :: PMStream -> a -> CLong -> IO ()
writeMsg PMStream
s a
t CLong
m = do
>               Either PMError PMSuccess
e <- PMStream -> PMEvent -> IO (Either PMError PMSuccess)
writeShort PMStream
s (CLong -> Timestamp -> PMEvent
PMEvent CLong
m (a -> Timestamp
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
1e3)))
>               case Either PMError PMSuccess
e of
>                 Left PMError
e' -> String -> PMError -> IO ()
reportError String
"midiOutRealTime'" PMError
e'
>                 Right PMSuccess
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>     finalize :: OutputDeviceID -> IO ()
finalize OutputDeviceID
odid = do
>       Maybe PMStream
s <- IORef [(OutputDeviceID, PMStream)]
-> OutputDeviceID -> IO (Maybe PMStream)
forall deviceid.
Eq deviceid =>
IORef [(deviceid, PMStream)] -> deviceid -> IO (Maybe PMStream)
lookupPort IORef [(OutputDeviceID, PMStream)]
outPort OutputDeviceID
odid
>       Either PMError PMSuccess
e <- IO (Either PMError PMSuccess)
-> (PMStream -> IO (Either PMError PMSuccess))
-> Maybe PMStream
-> IO (Either PMError PMSuccess)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either PMError PMSuccess -> IO (Either PMError PMSuccess)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PMSuccess -> Either PMError PMSuccess
forall a b. b -> Either a b
Right PMSuccess
NoError'NoData)) PMStream -> IO (Either PMError PMSuccess)
close Maybe PMStream
s
>       case Either PMError PMSuccess
e of
>         Left PMError
e' -> String -> PMError -> IO ()
reportError String
"midiOutRealTime'" PMError
e'
>         Right PMSuccess
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


> midiOutRealTime :: OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
> midiOutRealTime :: OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
midiOutRealTime odid :: OutputDeviceID
odid@(OutputDeviceID Key
devId) = do
>   Either PMError PMStream
s <- Key -> Key -> IO (Either PMError PMStream)
openOutput Key
devId Key
1
>   case Either PMError PMStream
s of
>     Left  PMError
e -> String -> PMError -> IO ()
reportError String
"outputMidi" PMError
e IO ()
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ((Time, Message) -> IO (), IO ())
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((Time, Message) -> IO (), IO ())
forall a. Maybe a
Nothing
>     Right PMStream
s -> do
>       TChan (Maybe (Time, Message))
ch <- STM (TChan (Maybe (Time, Message)))
-> IO (TChan (Maybe (Time, Message)))
forall a. STM a -> IO a
atomically STM (TChan (Maybe (Time, Message)))
forall a. STM (TChan a)
newTChan
>       MVar ()
wait <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
>       MVar ()
fin <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
>       IO () -> IO ThreadId
forkIO (PMStream
-> TChan (Maybe (Time, Message)) -> MVar () -> MVar () -> IO ()
pump PMStream
s TChan (Maybe (Time, Message))
ch MVar ()
wait MVar ()
fin)
>       Maybe ((Time, Message) -> IO (), IO ())
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ((Time, Message) -> IO (), IO ())
 -> IO (Maybe ((Time, Message) -> IO (), IO ())))
-> Maybe ((Time, Message) -> IO (), IO ())
-> IO (Maybe ((Time, Message) -> IO (), IO ()))
forall a b. (a -> b) -> a -> b
$ ((Time, Message) -> IO (), IO ())
-> Maybe ((Time, Message) -> IO (), IO ())
forall a. a -> Maybe a
Just (PMStream
-> TChan (Maybe (Time, Message))
-> MVar ()
-> (Time, Message)
-> IO ()
forall {p} {a}.
p -> TChan (Maybe (a, Message)) -> MVar () -> (a, Message) -> IO ()
output PMStream
s TChan (Maybe (Time, Message))
ch MVar ()
wait, TChan (Maybe (Time, Message)) -> MVar () -> IO ()
forall {a} {b}. TChan (Maybe a) -> MVar b -> IO b
stop TChan (Maybe (Time, Message))
ch MVar ()
fin)
>   where
>     stop :: TChan (Maybe a) -> MVar b -> IO b
stop TChan (Maybe a)
ch MVar b
fin = STM () -> IO ()
forall a. STM a -> IO a
atomically (TChan (Maybe a) -> Maybe a -> STM ()
forall a. TChan a -> a -> STM ()
unGetTChan TChan (Maybe a)
ch Maybe a
forall a. Maybe a
Nothing) IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar b -> IO b
forall a. MVar a -> IO a
takeMVar MVar b
fin
>     output :: p -> TChan (Maybe (a, Message)) -> MVar () -> (a, Message) -> IO ()
output p
s TChan (Maybe (a, Message))
ch MVar ()
wait evt :: (a, Message)
evt@(a
_, Message
m) = do
>       STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (Maybe (a, Message)) -> Maybe (a, Message) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Maybe (a, Message))
ch ((a, Message) -> Maybe (a, Message)
forall a. a -> Maybe a
Just (a, Message)
evt)
>       if Message -> Bool
isTrackEnd Message
m then MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
wait else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>     pump :: PMStream
-> TChan (Maybe (Time, Message)) -> MVar () -> MVar () -> IO ()
pump PMStream
s TChan (Maybe (Time, Message))
ch MVar ()
wait MVar ()
fin = IO ()
loop
>       where
>         loop :: IO ()
loop = do
>           Maybe (Time, Message)
e <- STM (Maybe (Time, Message)) -> IO (Maybe (Time, Message))
forall a. STM a -> IO a
atomically (STM (Maybe (Time, Message)) -> IO (Maybe (Time, Message)))
-> STM (Maybe (Time, Message)) -> IO (Maybe (Time, Message))
forall a b. (a -> b) -> a -> b
$ TChan (Maybe (Time, Message)) -> STM (Maybe (Time, Message))
forall a. TChan a -> STM a
readTChan TChan (Maybe (Time, Message))
ch
>           case Maybe (Time, Message)
e of
>             Maybe (Time, Message)
Nothing -> PMStream -> IO (Either PMError PMSuccess)
close PMStream
s IO (Either PMError PMSuccess) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
fin ()
>             Just (Time
t, Message
msg) -> do
>               Time
now <- IO Time
getTimeNow
>               if (Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
now Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
5)
>                 then STM () -> IO ()
forall a. STM a -> IO a
atomically (TChan (Maybe (Time, Message)) -> Maybe (Time, Message) -> STM ()
forall a. TChan a -> a -> STM ()
unGetTChan TChan (Maybe (Time, Message))
ch Maybe (Time, Message)
e) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Key -> IO ()
threadDelay Key
10000 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 ()
loop
>                 else do
>                   Bool
done <- Time -> Message -> IO Bool
forall {t}. RealFrac t => t -> Message -> IO Bool
process Time
t Message
msg
>                   if Bool
done
>                     then Time -> IO ()
waitUntil (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1)
>                     else IO ()
loop
>           where
>             waitUntil :: Time -> IO ()
waitUntil Time
t = do
>               Time
now <- IO Time
getTimeNow
>               if Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
now
>                 then do
>                   Key -> IO ()
threadDelay (Key -> IO ()) -> Key -> IO ()
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
10000 (Time -> Key
forall b. Integral b => Time -> b
forall a b. (RealFrac a, Integral b) => a -> b
round((Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
now) Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
1E6))
>                   Bool
empty <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TChan (Maybe (Time, Message)) -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan (Maybe (Time, Message))
ch
>                   if Bool
empty
>                     then Time -> IO ()
waitUntil Time
t
>                     else do
>                       Maybe (Time, Message)
e <- STM (Maybe (Time, Message)) -> IO (Maybe (Time, Message))
forall a. STM a -> IO a
atomically (STM (Maybe (Time, Message)) -> IO (Maybe (Time, Message)))
-> STM (Maybe (Time, Message)) -> IO (Maybe (Time, Message))
forall a b. (a -> b) -> a -> b
$ TChan (Maybe (Time, Message)) -> STM (Maybe (Time, Message))
forall a. TChan a -> STM a
readTChan TChan (Maybe (Time, Message))
ch
>                       case Maybe (Time, Message)
e of
>                         Maybe (Time, Message)
Nothing -> IO ()
finishup
>                         Maybe (Time, Message)
_ -> Time -> IO ()
waitUntil Time
t
>                 else IO ()
finishup
>             finishup :: IO ()
finishup = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
wait () IO ()
-> IO (Either PMError PMSuccess) -> IO (Either PMError PMSuccess)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PMStream -> IO (Either PMError PMSuccess)
close PMStream
s IO (Either PMError PMSuccess) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
fin ()
>             process :: t -> Message -> IO Bool
process t
t Message
msg = if Message -> Bool
isTrackEnd Message
msg
>               then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
>               else case Message -> Maybe PMMsg
midiEvent Message
msg of
>                 Just PMMsg
m  -> t -> CLong -> IO Bool
forall {t}. RealFrac t => t -> CLong -> IO Bool
writeMsg t
t (CLong -> IO Bool) -> CLong -> IO Bool
forall a b. (a -> b) -> a -> b
$ PMMsg -> CLong
encodeMsg PMMsg
m
>                 Maybe PMMsg
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
>             writeMsg :: t -> CLong -> IO Bool
writeMsg t
t CLong
m = do
>               Either PMError PMSuccess
e <- PMStream -> PMEvent -> IO (Either PMError PMSuccess)
writeShort PMStream
s (CLong -> Timestamp -> PMEvent
PMEvent CLong
m (t -> Timestamp
forall b. Integral b => t -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (t
t t -> t -> t
forall a. Num a => a -> a -> a
* t
1e3)))
>               case Either PMError PMSuccess
e of
>                 Left PMError
BufferOverflow -> String -> IO ()
putStrLn String
"overflow" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Key -> IO ()
threadDelay Key
10000 IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> CLong -> IO Bool
writeMsg t
t CLong
m
>                 Left PMError
e' -> String -> PMError -> IO ()
reportError String
"outputMidi" PMError
e' IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
>                 Right PMSuccess
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False


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

 | MIDI Conversion |
---------------------


A conversion function from Codec.Midi Messages to PortMidi PMMsgs.

> midiEvent :: Message -> Maybe PMMsg
> midiEvent :: Message -> Maybe PMMsg
midiEvent (NoteOff Key
c Key
p Key
v)         = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
128 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
p) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
v)
> midiEvent (NoteOn Key
c Key
p Key
v)          = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
144 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
p) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
v)
> midiEvent (KeyPressure Key
c Key
p Key
pr)    = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
160 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
p) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
pr)
> midiEvent (ControlChange Key
c Key
cn Key
cv) = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
176 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
cn) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
cv)
> midiEvent (ProgramChange Key
c Key
pn)    = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
192 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
pn) CLong
0
> midiEvent (ChannelPressure Key
c Key
pr)  = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
208 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
pr) CLong
0
> midiEvent (PitchWheel Key
c Key
pb)       = PMMsg -> Maybe PMMsg
forall a. a -> Maybe a
Just (PMMsg -> Maybe PMMsg) -> PMMsg -> Maybe PMMsg
forall a b. (a -> b) -> a -> b
$ CLong -> CLong -> CLong -> PMMsg
PMMsg (CLong
224 CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.|. (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
c CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF)) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
lo) (Key -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
hi)
>  where (Key
hi,Key
lo) = (Key
pb Key -> Key -> Key
forall a. Bits a => a -> Key -> a
`shiftR` Key
8, Key
pb Key -> Key -> Key
forall a. Bits a => a -> a -> a
.&. Key
0xFF)
> midiEvent Message
_ = Maybe PMMsg
forall a. Maybe a
Nothing


A conversion function from PortMidi PMMsgs to Codec.Midi Messages.

> msgToMidi :: PMMsg -> Maybe Message
> msgToMidi :: PMMsg -> Maybe Message
msgToMidi (PMMsg CLong
m CLong
d1 CLong
d2) =
>   let k :: CLong
k = (CLong
m CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0xF0) CLong -> Key -> CLong
forall a. Bits a => a -> Key -> a
`shiftR` Key
4
>       c :: Key
c = CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong
m CLong -> CLong -> CLong
forall a. Bits a => a -> a -> a
.&. CLong
0x0F)
>   in case CLong
k of
>     CLong
0x8 -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Message
NoteOff Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d1) (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d2)
>     CLong
0x9 -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Message
NoteOn  Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d1) (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d2)
>     CLong
0xA -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Message
KeyPressure Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d1) (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d2)
>     CLong
0xB -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Message
ControlChange Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d1) (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d2)
>     CLong
0xC -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Message
ProgramChange Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d1)
>     CLong
0xD -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Message
ChannelPressure Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
d1)
>     CLong
0xE -> Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Message
PitchWheel Key
c (CLong -> Key
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong
d1 CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
+ CLong
d2 CLong -> Key -> CLong
forall a. Bits a => a -> Key -> a
`shiftL` Key
8))
>     CLong
0xF -> Maybe Message
forall a. Maybe a
Nothing -- SysEx event not handled

>     CLong
_   -> Maybe Message
forall a. Maybe a
Nothing


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

 | Error Reporting |
---------------------


> reportError :: String -> PMError -> IO ()
> reportError :: String -> PMError -> IO ()
reportError String
prompt PMError
e = do
>   String
err <- PMError -> IO String
getErrorText PMError
e
>   Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prompt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
err





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

 | Unused Functions |
----------------------


> -- Prints all DeviceInfo found by getAllDevices.

> printAllDeviceInfo :: IO ()
> printAllDeviceInfo :: IO ()
printAllDeviceInfo = do
>   ([(InputDeviceID, DeviceInfo)]
indevs, [(OutputDeviceID, DeviceInfo)]
outdevs) <- IO ([(InputDeviceID, DeviceInfo)], [(OutputDeviceID, DeviceInfo)])
getAllDevices
>   ((InputDeviceID, DeviceInfo) -> IO ())
-> [(InputDeviceID, DeviceInfo)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DeviceInfo -> IO ()
forall a. Show a => a -> IO ()
print (DeviceInfo -> IO ())
-> ((InputDeviceID, DeviceInfo) -> DeviceInfo)
-> (InputDeviceID, DeviceInfo)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InputDeviceID, DeviceInfo) -> DeviceInfo
forall a b. (a, b) -> b
snd) [(InputDeviceID, DeviceInfo)]
indevs
>   ((OutputDeviceID, DeviceInfo) -> IO ())
-> [(OutputDeviceID, DeviceInfo)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DeviceInfo -> IO ()
forall a. Show a => a -> IO ()
print (DeviceInfo -> IO ())
-> ((OutputDeviceID, DeviceInfo) -> DeviceInfo)
-> (OutputDeviceID, DeviceInfo)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputDeviceID, DeviceInfo) -> DeviceInfo
forall a b. (a, b) -> b
snd) [(OutputDeviceID, DeviceInfo)]
outdevs

-- Given whether the device is an input device and the device name,

-- returns the DeviceID.

 getDeviceId :: Bool -> String -> IO (Maybe DeviceID)
 getDeviceId isInput n = do
   devs <- getAllDevices
   return $ findIndex (\(_,d) -> name d == n && input d == isInput) devs

> playTrackRealTime :: OutputDeviceID -> [(t, Message)] -> IO ()
> playTrackRealTime :: forall t. OutputDeviceID -> [(t, Message)] -> IO ()
playTrackRealTime OutputDeviceID
device [(t, Message)]
track = do
>   Maybe ((Time, Message) -> IO (), IO ())
out <- OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
midiOutRealTime OutputDeviceID
device
>   case Maybe ((Time, Message) -> IO (), IO ())
out of
>     Maybe ((Time, Message) -> IO (), IO ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>     Just ((Time, Message) -> IO ()
out, IO ()
stop) -> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (((Time, Message) -> IO ()) -> [(t, Message)] -> IO ()
forall {a}. ((Time, Message) -> IO ()) -> [(a, Message)] -> IO ()
playTrack (Time, Message) -> IO ()
out [(t, Message)]
track) IO ()
stop
>   where
>     playTrack :: ((Time, Message) -> IO ()) -> [(a, Message)] -> IO ()
playTrack (Time, Message) -> IO ()
out [] = do
>       Time
t <- IO Time
getTimeNow
>       (Time, Message) -> IO ()
out (Time
t, Message
TrackEnd)
>     playTrack (Time, Message) -> IO ()
out (e :: (a, Message)
e@(a
_, Message
m) : [(a, Message)]
s) = do
>       Time
t <- IO Time
getTimeNow
>       (Time, Message) -> IO ()
out (Time
t, Message
m)
>       if Message -> Bool
isTrackEnd Message
m
>         then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>         else ((Time, Message) -> IO ()) -> [(a, Message)] -> IO ()
playTrack (Time, Message) -> IO ()
out [(a, Message)]
s
> {-
>     ticksPerBeat = case division of
>       TicksPerBeat n -> n
>       TicksPerSecond mode nticks -> (256 - mode - 128) * nticks `div` 2
> -}
> {-
> runTrack tpb = runTrack' 0 0 120                 -- 120 beat/s is the default tempo
>   where
>     runTrack' t t0 bps ((_, TempoChange tempo) : l) =
>       let bps' = 1000000 `div` fromIntegral tempo
>       in runTrack' t t0 bps' l
>     runTrack' t t0 bps ((t1, m) : l) =
>       let t' = t + 1000 * fromIntegral (t1 - t0) `div` (tpb * bps)
>       in (t', m) : runTrack' t' t1 bps l
>     runTrack' _ _ _ [] = []
>
> playTrack s ch t0 = playTrack' 0
>   where
>     playTrack' t [] = putStrLn "done" >> putMVar ch Nothing >> return (round (t * 1.0E3))
>     playTrack' _ ((t, e):es) = putMVar ch (Just io) >> playTrack' t es
>       where
>         io = case midiEvent e of
>           Just m  -> writeShort s (PMEvent m (t0 + round (t * 1.0E3)))
>           Nothing -> return NoError
> -}
> recordMidi :: DeviceID -> (Track Time -> IO ()) -> IO ()
> recordMidi :: Key -> (Track Time -> IO ()) -> IO ()
recordMidi Key
device Track Time -> IO ()
f = do
>   Chan (Time, Message)
ch <- IO (Chan (Time, Message))
forall a. IO (Chan a)
newChan
>   Maybe (IO ())
final <- Key -> ((Time, Message) -> IO Bool) -> IO (Maybe (IO ()))
midiInRealTime Key
device (\(Time, Message)
e -> Chan (Time, Message) -> (Time, Message) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Time, Message)
ch (Time, Message)
e IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
>   case Maybe (IO ())
final of
>     Maybe (IO ())
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>     Just IO ()
fin -> do
>       Track Time
track <- Chan (Time, Message) -> IO (Track Time)
forall a. Chan a -> IO [a]
getChanContents Chan (Time, Message)
ch
>       MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
>       IO () -> IO ThreadId
forkIO (Track Time -> IO ()
f Track Time
track IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
>       String -> IO ()
putStrLn String
"Start recording, hit ENTER when you are done."
>       IO String
getLine
>       IO ()
fin
>       MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done
>       () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
> midiInRealTime :: DeviceID -> ((Time, Message) -> IO Bool) -> IO (Maybe (IO ()))
> midiInRealTime :: Key -> ((Time, Message) -> IO Bool) -> IO (Maybe (IO ()))
midiInRealTime Key
device (Time, Message) -> IO Bool
callback = do
>   Either PMError PMStream
r <- Key -> IO (Either PMError PMStream)
openInput Key
device
>   case Either PMError PMStream
r of
>     Left PMError
e -> String -> PMError -> IO ()
reportError String
"midiInRealTime" PMError
e IO () -> IO (Maybe (IO ())) -> IO (Maybe (IO ()))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (IO ()) -> IO (Maybe (IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
forall a. Maybe a
Nothing
>     Right PMStream
s -> do
>       MVar ()
fin <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
>       IO () -> IO ThreadId
forkIO (Maybe Timestamp -> PMStream -> MVar () -> IO ()
forall {a}. Maybe Timestamp -> PMStream -> MVar a -> IO ()
loop Maybe Timestamp
forall a. Maybe a
Nothing PMStream
s MVar ()
fin)
>       Maybe (IO ()) -> IO (Maybe (IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
fin () IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
fin ()))
>   where
>     loop :: Maybe Timestamp -> PMStream -> MVar a -> IO ()
loop Maybe Timestamp
start PMStream
s MVar a
fin = do
>       Maybe a
done <- MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar a
fin
>       Time
t <- IO Time
getTimeNow
>       case Maybe a
done of
>         Just a
_ -> PMStream -> IO (Either PMError PMSuccess)
close PMStream
s IO (Either PMError PMSuccess) -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Time, Message) -> IO Bool
callback (Time
t, Message
TrackEnd) IO Bool -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
fin IO a -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>         Maybe a
Nothing -> do
>           Either PMError [PMEvent]
e <- PMStream -> IO (Either PMError [PMEvent])
readEvents PMStream
s
>           case Either PMError [PMEvent]
e of
>             Left PMError
e -> do
>                 String -> PMError -> IO ()
reportError String
"midiInRealTime" PMError
e
>                 (Time, Message) -> IO Bool
callback (Time
t, Message
TrackEnd)
>                 () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
>             Right [PMEvent]
l -> do
>               Time
t <- IO Time
getTimeNow
>               Maybe Timestamp -> Time -> [PMEvent] -> IO ()
sendEvts Maybe Timestamp
start Time
t [PMEvent]
l
>       where
>         sendEvts :: Maybe Timestamp -> Time -> [PMEvent] -> IO ()
sendEvts Maybe Timestamp
start Time
now [] = Maybe Timestamp -> PMStream -> MVar a -> IO ()
loop Maybe Timestamp
start PMStream
s MVar a
fin
>         sendEvts Maybe Timestamp
start Time
now (e :: PMEvent
e@(PMEvent CLong
m Timestamp
t):[PMEvent]
l) = do
>           let t0 :: Timestamp
t0 = Timestamp
-> (Timestamp -> Timestamp) -> Maybe Timestamp -> Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Timestamp
t Timestamp -> Timestamp
forall a. a -> a
id Maybe Timestamp
start
>           case PMMsg -> Maybe Message
msgToMidi (PMMsg -> Maybe Message) -> PMMsg -> Maybe Message
forall a b. (a -> b) -> a -> b
$ CLong -> PMMsg
decodeMsg CLong
m of
>             Just Message
m' -> do
>               Bool
done <- (Time, Message) -> IO Bool
callback (Time
now Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Timestamp -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Timestamp
t Timestamp -> Timestamp -> Timestamp
forall a. Num a => a -> a -> a
- Timestamp
t0) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
1E3, Message
m')
>               if Bool
done then PMStream -> IO (Either PMError PMSuccess)
close PMStream
s IO (Either PMError PMSuccess) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else Maybe Timestamp -> Time -> [PMEvent] -> IO ()
sendEvts (Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
t0) Time
now [PMEvent]
l
>             Maybe Message
Nothing -> Maybe Timestamp -> Time -> [PMEvent] -> IO ()
sendEvts (Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
t0) Time
now [PMEvent]
l