-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# OPTIONS_GHC -funbox-strict-fields #-}
module Midi.Midi (
    WriteMessages, ReadMessages
    , WriteMessage(..), ReadMessage(..)

    -- * devices
    , ReadDevice, WriteDevice, read_device, write_device
    , read_device_text, write_device_text
    , peek_wdev, peek_rdev, with_wdev, with_rdev
    , add_timestamp, modify_timestamp

    -- * constructors
    , program_change, reset_channel
    , realtime_sysex
    -- ** rpn / nrpn
    , pitch_bend_range, nrpn_tuning
    , MpeZone(..), mpe_2_to_16
    , rpn, nrpn

    -- * modify
    , set_channel

    -- * predicates
    , valid_msg, valid_chan_msg, is_cc, is_sysex, is_note, is_note_on, is_state
    , is_pitched
    , channel_message, message_channel

    -- * types
    , Message(..), Channel, Velocity, Control, Program, ControlValue
    , PitchBendValue, Manufacturer
    , Key(..), from_key, to_key, to_closest_key
    , ChannelMessage(..), CommonMessage(..), RealtimeMessage(..)
    -- * MTC
    , Mtc(..), FrameRate(..), SmpteFragment(..), Smpte(..)
    , seconds_to_frame, frame_to_seconds, frame_to_smpte, seconds_to_smpte
    , generate_mtc
    , mtc_sync, mtc_fragments
    -- * tuning
    , NoteNumber
    , realtime_tuning

    -- * util
    , join14, split14, join4, split4
    -- ** manufacturer
    , manufacturer_name
    , yamaha_code, korg_code
) where
import qualified Control.DeepSeq as DeepSeq
import           Control.DeepSeq (rnf)
import qualified Data.Bits as Bits
import           Data.Bits ((.&.), (.|.))
import qualified Data.ByteString as ByteString
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text.Encoding as Encoding
import           Data.Word (Word8)

import qualified Foreign.C

import qualified Util.FFI as FFI
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import           Util.Pretty (format, (<+>))
import qualified Util.Seq as Seq
import qualified Util.Serialize as Serialize

import qualified Midi.CC as CC
import           Perform.RealTime (RealTime)

import           Global


-- | Declared abstract here so I can switch to a more compact representation
-- later.
type WriteMessages = [WriteMessage]
type ReadMessages = [ReadMessage]

data WriteMessage = WriteMessage {
    WriteMessage -> WriteDevice
wmsg_dev :: !WriteDevice
    , WriteMessage -> RealTime
wmsg_ts :: !RealTime
    , WriteMessage -> Message
wmsg_msg :: !Message
    } deriving (WriteMessage -> WriteMessage -> Bool
(WriteMessage -> WriteMessage -> Bool)
-> (WriteMessage -> WriteMessage -> Bool) -> Eq WriteMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteMessage -> WriteMessage -> Bool
$c/= :: WriteMessage -> WriteMessage -> Bool
== :: WriteMessage -> WriteMessage -> Bool
$c== :: WriteMessage -> WriteMessage -> Bool
Eq, Eq WriteMessage
Eq WriteMessage
-> (WriteMessage -> WriteMessage -> Ordering)
-> (WriteMessage -> WriteMessage -> Bool)
-> (WriteMessage -> WriteMessage -> Bool)
-> (WriteMessage -> WriteMessage -> Bool)
-> (WriteMessage -> WriteMessage -> Bool)
-> (WriteMessage -> WriteMessage -> WriteMessage)
-> (WriteMessage -> WriteMessage -> WriteMessage)
-> Ord WriteMessage
WriteMessage -> WriteMessage -> Bool
WriteMessage -> WriteMessage -> Ordering
WriteMessage -> WriteMessage -> WriteMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WriteMessage -> WriteMessage -> WriteMessage
$cmin :: WriteMessage -> WriteMessage -> WriteMessage
max :: WriteMessage -> WriteMessage -> WriteMessage
$cmax :: WriteMessage -> WriteMessage -> WriteMessage
>= :: WriteMessage -> WriteMessage -> Bool
$c>= :: WriteMessage -> WriteMessage -> Bool
> :: WriteMessage -> WriteMessage -> Bool
$c> :: WriteMessage -> WriteMessage -> Bool
<= :: WriteMessage -> WriteMessage -> Bool
$c<= :: WriteMessage -> WriteMessage -> Bool
< :: WriteMessage -> WriteMessage -> Bool
$c< :: WriteMessage -> WriteMessage -> Bool
compare :: WriteMessage -> WriteMessage -> Ordering
$ccompare :: WriteMessage -> WriteMessage -> Ordering
Ord, ReadPrec [WriteMessage]
ReadPrec WriteMessage
Int -> ReadS WriteMessage
ReadS [WriteMessage]
(Int -> ReadS WriteMessage)
-> ReadS [WriteMessage]
-> ReadPrec WriteMessage
-> ReadPrec [WriteMessage]
-> Read WriteMessage
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WriteMessage]
$creadListPrec :: ReadPrec [WriteMessage]
readPrec :: ReadPrec WriteMessage
$creadPrec :: ReadPrec WriteMessage
readList :: ReadS [WriteMessage]
$creadList :: ReadS [WriteMessage]
readsPrec :: Int -> ReadS WriteMessage
$creadsPrec :: Int -> ReadS WriteMessage
Read, Int -> WriteMessage -> ShowS
[WriteMessage] -> ShowS
WriteMessage -> String
(Int -> WriteMessage -> ShowS)
-> (WriteMessage -> String)
-> ([WriteMessage] -> ShowS)
-> Show WriteMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteMessage] -> ShowS
$cshowList :: [WriteMessage] -> ShowS
show :: WriteMessage -> String
$cshow :: WriteMessage -> String
showsPrec :: Int -> WriteMessage -> ShowS
$cshowsPrec :: Int -> WriteMessage -> ShowS
Show)
data ReadMessage = ReadMessage {
    ReadMessage -> ReadDevice
rmsg_dev :: !ReadDevice
    , ReadMessage -> RealTime
rmsg_ts :: !RealTime
    , ReadMessage -> Message
rmsg_msg :: !Message
    } deriving (ReadMessage -> ReadMessage -> Bool
(ReadMessage -> ReadMessage -> Bool)
-> (ReadMessage -> ReadMessage -> Bool) -> Eq ReadMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadMessage -> ReadMessage -> Bool
$c/= :: ReadMessage -> ReadMessage -> Bool
== :: ReadMessage -> ReadMessage -> Bool
$c== :: ReadMessage -> ReadMessage -> Bool
Eq, Eq ReadMessage
Eq ReadMessage
-> (ReadMessage -> ReadMessage -> Ordering)
-> (ReadMessage -> ReadMessage -> Bool)
-> (ReadMessage -> ReadMessage -> Bool)
-> (ReadMessage -> ReadMessage -> Bool)
-> (ReadMessage -> ReadMessage -> Bool)
-> (ReadMessage -> ReadMessage -> ReadMessage)
-> (ReadMessage -> ReadMessage -> ReadMessage)
-> Ord ReadMessage
ReadMessage -> ReadMessage -> Bool
ReadMessage -> ReadMessage -> Ordering
ReadMessage -> ReadMessage -> ReadMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReadMessage -> ReadMessage -> ReadMessage
$cmin :: ReadMessage -> ReadMessage -> ReadMessage
max :: ReadMessage -> ReadMessage -> ReadMessage
$cmax :: ReadMessage -> ReadMessage -> ReadMessage
>= :: ReadMessage -> ReadMessage -> Bool
$c>= :: ReadMessage -> ReadMessage -> Bool
> :: ReadMessage -> ReadMessage -> Bool
$c> :: ReadMessage -> ReadMessage -> Bool
<= :: ReadMessage -> ReadMessage -> Bool
$c<= :: ReadMessage -> ReadMessage -> Bool
< :: ReadMessage -> ReadMessage -> Bool
$c< :: ReadMessage -> ReadMessage -> Bool
compare :: ReadMessage -> ReadMessage -> Ordering
$ccompare :: ReadMessage -> ReadMessage -> Ordering
Ord, ReadPrec [ReadMessage]
ReadPrec ReadMessage
Int -> ReadS ReadMessage
ReadS [ReadMessage]
(Int -> ReadS ReadMessage)
-> ReadS [ReadMessage]
-> ReadPrec ReadMessage
-> ReadPrec [ReadMessage]
-> Read ReadMessage
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReadMessage]
$creadListPrec :: ReadPrec [ReadMessage]
readPrec :: ReadPrec ReadMessage
$creadPrec :: ReadPrec ReadMessage
readList :: ReadS [ReadMessage]
$creadList :: ReadS [ReadMessage]
readsPrec :: Int -> ReadS ReadMessage
$creadsPrec :: Int -> ReadS ReadMessage
Read, Int -> ReadMessage -> ShowS
[ReadMessage] -> ShowS
ReadMessage -> String
(Int -> ReadMessage -> ShowS)
-> (ReadMessage -> String)
-> ([ReadMessage] -> ShowS)
-> Show ReadMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadMessage] -> ShowS
$cshowList :: [ReadMessage] -> ShowS
show :: ReadMessage -> String
$cshow :: ReadMessage -> String
showsPrec :: Int -> ReadMessage -> ShowS
$cshowsPrec :: Int -> ReadMessage -> ShowS
Show)

-- Midi msgs are already strict so deepseq is unnecessary, but an NFData
-- instance will make deepseq work on things that contain msgs.
instance DeepSeq.NFData WriteMessage where rnf :: WriteMessage -> ()
rnf WriteMessage
_ = ()
instance DeepSeq.NFData ReadMessage where rnf :: ReadMessage -> ()
rnf ReadMessage
_ = ()

instance Pretty ReadMessage where
    pretty :: ReadMessage -> Text
pretty (ReadMessage ReadDevice
dev RealTime
ts Message
msg) =
        ReadDevice -> Text
forall a. Pretty a => a -> Text
pretty ReadDevice
dev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Message -> Text
forall a. Pretty a => a -> Text
pretty Message
msg
instance Pretty WriteMessage where
    pretty :: WriteMessage -> Text
pretty (WriteMessage WriteDevice
dev RealTime
ts Message
msg) =
        WriteDevice -> Text
forall a. Pretty a => a -> Text
pretty WriteDevice
dev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Message -> Text
forall a. Pretty a => a -> Text
pretty Message
msg

-- * devices

-- | Implementation independent representation of a MIDI Device.
--
-- This can be saved to and loaded from files without regard for the devices
-- actually installed or opened.
newtype ReadDevice = ReadDevice ByteString.ByteString
    deriving (ReadDevice -> ReadDevice -> Bool
(ReadDevice -> ReadDevice -> Bool)
-> (ReadDevice -> ReadDevice -> Bool) -> Eq ReadDevice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadDevice -> ReadDevice -> Bool
$c/= :: ReadDevice -> ReadDevice -> Bool
== :: ReadDevice -> ReadDevice -> Bool
$c== :: ReadDevice -> ReadDevice -> Bool
Eq, Eq ReadDevice
Eq ReadDevice
-> (ReadDevice -> ReadDevice -> Ordering)
-> (ReadDevice -> ReadDevice -> Bool)
-> (ReadDevice -> ReadDevice -> Bool)
-> (ReadDevice -> ReadDevice -> Bool)
-> (ReadDevice -> ReadDevice -> Bool)
-> (ReadDevice -> ReadDevice -> ReadDevice)
-> (ReadDevice -> ReadDevice -> ReadDevice)
-> Ord ReadDevice
ReadDevice -> ReadDevice -> Bool
ReadDevice -> ReadDevice -> Ordering
ReadDevice -> ReadDevice -> ReadDevice
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ReadDevice -> ReadDevice -> ReadDevice
$cmin :: ReadDevice -> ReadDevice -> ReadDevice
max :: ReadDevice -> ReadDevice -> ReadDevice
$cmax :: ReadDevice -> ReadDevice -> ReadDevice
>= :: ReadDevice -> ReadDevice -> Bool
$c>= :: ReadDevice -> ReadDevice -> Bool
> :: ReadDevice -> ReadDevice -> Bool
$c> :: ReadDevice -> ReadDevice -> Bool
<= :: ReadDevice -> ReadDevice -> Bool
$c<= :: ReadDevice -> ReadDevice -> Bool
< :: ReadDevice -> ReadDevice -> Bool
$c< :: ReadDevice -> ReadDevice -> Bool
compare :: ReadDevice -> ReadDevice -> Ordering
$ccompare :: ReadDevice -> ReadDevice -> Ordering
Ord, Int -> ReadDevice -> ShowS
[ReadDevice] -> ShowS
ReadDevice -> String
(Int -> ReadDevice -> ShowS)
-> (ReadDevice -> String)
-> ([ReadDevice] -> ShowS)
-> Show ReadDevice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadDevice] -> ShowS
$cshowList :: [ReadDevice] -> ShowS
show :: ReadDevice -> String
$cshow :: ReadDevice -> String
showsPrec :: Int -> ReadDevice -> ShowS
$cshowsPrec :: Int -> ReadDevice -> ShowS
Show, ReadPrec [ReadDevice]
ReadPrec ReadDevice
Int -> ReadS ReadDevice
ReadS [ReadDevice]
(Int -> ReadS ReadDevice)
-> ReadS [ReadDevice]
-> ReadPrec ReadDevice
-> ReadPrec [ReadDevice]
-> Read ReadDevice
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReadDevice]
$creadListPrec :: ReadPrec [ReadDevice]
readPrec :: ReadPrec ReadDevice
$creadPrec :: ReadPrec ReadDevice
readList :: ReadS [ReadDevice]
$creadList :: ReadS [ReadDevice]
readsPrec :: Int -> ReadS ReadDevice
$creadsPrec :: Int -> ReadS ReadDevice
Read, Get ReadDevice
Putter ReadDevice
Putter ReadDevice -> Get ReadDevice -> Serialize ReadDevice
forall a. Putter a -> Get a -> Serialize a
get :: Get ReadDevice
$cget :: Get ReadDevice
put :: Putter ReadDevice
$cput :: Putter ReadDevice
Serialize.Serialize)
    -- Storing these as ByteString gives a cheap marshal and unmarshal.  Not
    -- that it matters, but maybe it will someday for a different MIDI backend.
newtype WriteDevice = WriteDevice ByteString.ByteString
    deriving (WriteDevice -> WriteDevice -> Bool
(WriteDevice -> WriteDevice -> Bool)
-> (WriteDevice -> WriteDevice -> Bool) -> Eq WriteDevice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteDevice -> WriteDevice -> Bool
$c/= :: WriteDevice -> WriteDevice -> Bool
== :: WriteDevice -> WriteDevice -> Bool
$c== :: WriteDevice -> WriteDevice -> Bool
Eq, Eq WriteDevice
Eq WriteDevice
-> (WriteDevice -> WriteDevice -> Ordering)
-> (WriteDevice -> WriteDevice -> Bool)
-> (WriteDevice -> WriteDevice -> Bool)
-> (WriteDevice -> WriteDevice -> Bool)
-> (WriteDevice -> WriteDevice -> Bool)
-> (WriteDevice -> WriteDevice -> WriteDevice)
-> (WriteDevice -> WriteDevice -> WriteDevice)
-> Ord WriteDevice
WriteDevice -> WriteDevice -> Bool
WriteDevice -> WriteDevice -> Ordering
WriteDevice -> WriteDevice -> WriteDevice
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WriteDevice -> WriteDevice -> WriteDevice
$cmin :: WriteDevice -> WriteDevice -> WriteDevice
max :: WriteDevice -> WriteDevice -> WriteDevice
$cmax :: WriteDevice -> WriteDevice -> WriteDevice
>= :: WriteDevice -> WriteDevice -> Bool
$c>= :: WriteDevice -> WriteDevice -> Bool
> :: WriteDevice -> WriteDevice -> Bool
$c> :: WriteDevice -> WriteDevice -> Bool
<= :: WriteDevice -> WriteDevice -> Bool
$c<= :: WriteDevice -> WriteDevice -> Bool
< :: WriteDevice -> WriteDevice -> Bool
$c< :: WriteDevice -> WriteDevice -> Bool
compare :: WriteDevice -> WriteDevice -> Ordering
$ccompare :: WriteDevice -> WriteDevice -> Ordering
Ord, Int -> WriteDevice -> ShowS
[WriteDevice] -> ShowS
WriteDevice -> String
(Int -> WriteDevice -> ShowS)
-> (WriteDevice -> String)
-> ([WriteDevice] -> ShowS)
-> Show WriteDevice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteDevice] -> ShowS
$cshowList :: [WriteDevice] -> ShowS
show :: WriteDevice -> String
$cshow :: WriteDevice -> String
showsPrec :: Int -> WriteDevice -> ShowS
$cshowsPrec :: Int -> WriteDevice -> ShowS
Show, ReadPrec [WriteDevice]
ReadPrec WriteDevice
Int -> ReadS WriteDevice
ReadS [WriteDevice]
(Int -> ReadS WriteDevice)
-> ReadS [WriteDevice]
-> ReadPrec WriteDevice
-> ReadPrec [WriteDevice]
-> Read WriteDevice
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WriteDevice]
$creadListPrec :: ReadPrec [WriteDevice]
readPrec :: ReadPrec WriteDevice
$creadPrec :: ReadPrec WriteDevice
readList :: ReadS [WriteDevice]
$creadList :: ReadS [WriteDevice]
readsPrec :: Int -> ReadS WriteDevice
$creadsPrec :: Int -> ReadS WriteDevice
Read, Get WriteDevice
Putter WriteDevice
Putter WriteDevice -> Get WriteDevice -> Serialize WriteDevice
forall a. Putter a -> Get a -> Serialize a
get :: Get WriteDevice
$cget :: Get WriteDevice
put :: Putter WriteDevice
$cput :: Putter WriteDevice
Serialize.Serialize)

read_device :: Text -> ReadDevice
read_device :: Text -> ReadDevice
read_device = ByteString -> ReadDevice
ReadDevice (ByteString -> ReadDevice)
-> (Text -> ByteString) -> Text -> ReadDevice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8

write_device :: Text -> WriteDevice
write_device :: Text -> WriteDevice
write_device = ByteString -> WriteDevice
WriteDevice (ByteString -> WriteDevice)
-> (Text -> ByteString) -> Text -> WriteDevice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8

read_device_text :: ReadDevice -> Text
read_device_text :: ReadDevice -> Text
read_device_text (ReadDevice ByteString
bs) = ByteString -> Text
FFI.decodeUtf8 ByteString
bs

write_device_text :: WriteDevice -> Text
write_device_text :: WriteDevice -> Text
write_device_text (WriteDevice ByteString
bs) = ByteString -> Text
FFI.decodeUtf8 ByteString
bs

peek_wdev :: Foreign.C.CString -> IO WriteDevice
peek_wdev :: CString -> IO WriteDevice
peek_wdev = (ByteString -> WriteDevice) -> IO ByteString -> IO WriteDevice
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> WriteDevice
WriteDevice (IO ByteString -> IO WriteDevice)
-> (CString -> IO ByteString) -> CString -> IO WriteDevice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO ByteString
ByteString.packCString

peek_rdev :: Foreign.C.CString -> IO ReadDevice
peek_rdev :: CString -> IO ReadDevice
peek_rdev = (ByteString -> ReadDevice) -> IO ByteString -> IO ReadDevice
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ReadDevice
ReadDevice (IO ByteString -> IO ReadDevice)
-> (CString -> IO ByteString) -> CString -> IO ReadDevice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO ByteString
ByteString.packCString

with_wdev :: WriteDevice -> (Foreign.C.CString -> IO a) -> IO a
with_wdev :: forall a. WriteDevice -> (CString -> IO a) -> IO a
with_wdev (WriteDevice ByteString
dev) = ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.useAsCString ByteString
dev

with_rdev :: ReadDevice -> (Foreign.C.CString -> IO a) -> IO a
with_rdev :: forall a. ReadDevice -> (CString -> IO a) -> IO a
with_rdev (ReadDevice ByteString
dev) = ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.useAsCString ByteString
dev

instance Pretty ReadDevice where pretty :: ReadDevice -> Text
pretty = ReadDevice -> Text
read_device_text
instance Pretty WriteDevice where pretty :: WriteDevice -> Text
pretty = WriteDevice -> Text
write_device_text

add_timestamp :: RealTime -> WriteMessage -> WriteMessage
add_timestamp :: RealTime -> WriteMessage -> WriteMessage
add_timestamp RealTime
ts WriteMessage
wmsg = WriteMessage
wmsg { wmsg_ts :: RealTime
wmsg_ts = WriteMessage -> RealTime
wmsg_ts WriteMessage
wmsg RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
ts }

modify_timestamp :: (RealTime -> RealTime) -> WriteMessage -> WriteMessage
modify_timestamp :: (RealTime -> RealTime) -> WriteMessage -> WriteMessage
modify_timestamp RealTime -> RealTime
f WriteMessage
wmsg = WriteMessage
wmsg { wmsg_ts :: RealTime
wmsg_ts = RealTime -> RealTime
f (WriteMessage -> RealTime
wmsg_ts WriteMessage
wmsg) }


-- * constructors

-- | Emit a program change with bank in [msb, lsb, pchange] order.
program_change :: Int -> Program -> [ChannelMessage]
program_change :: Int -> Manufacturer -> [ChannelMessage]
program_change Int
bank Manufacturer
program =
    [ Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.bank Manufacturer
msb, Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.bank_lsb Manufacturer
lsb
    , Manufacturer -> ChannelMessage
ProgramChange Manufacturer
program
    ]
    where (Manufacturer
lsb, Manufacturer
msb) = Int -> (Manufacturer, Manufacturer)
split14 Int
bank

reset_channel :: Channel -> [Message]
reset_channel :: Manufacturer -> [Message]
reset_channel Manufacturer
chan =
    -- There is also AllNotesOff, but AllSoundOff seems more widely supported.
    [ Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan ChannelMessage
AllSoundOff
    , Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan ChannelMessage
ResetAllControls
    ]

-- | This is a special kind of sysex which is meant to be interpreted in real
-- time.
realtime_sysex :: ByteString.ByteString -> Message
realtime_sysex :: ByteString -> Message
realtime_sysex = CommonMessage -> Message
CommonMessage (CommonMessage -> Message)
-> (ByteString -> CommonMessage) -> ByteString -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manufacturer -> ByteString -> CommonMessage
SystemExclusive Manufacturer
0x7f

-- ** rpn / nrpn

-- | Emit a pitch bend range RPN message for the given range.
pitch_bend_range :: Double -> [ChannelMessage]
pitch_bend_range :: Double -> [ChannelMessage]
pitch_bend_range Double
range = (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
rpn (Manufacturer
0, Manufacturer
0) (Manufacturer
semitones, Manufacturer
cents) [ChannelMessage] -> [ChannelMessage] -> [ChannelMessage]
forall a. [a] -> [a] -> [a]
++ [ChannelMessage]
cancel_rpn
    where
    (Manufacturer
semitones, Double
frac) = Double -> (Manufacturer, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
range
    cents :: Manufacturer
cents = Double -> Manufacturer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
frac Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100)

data MpeZone = Lower | Upper deriving (MpeZone -> MpeZone -> Bool
(MpeZone -> MpeZone -> Bool)
-> (MpeZone -> MpeZone -> Bool) -> Eq MpeZone
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MpeZone -> MpeZone -> Bool
$c/= :: MpeZone -> MpeZone -> Bool
== :: MpeZone -> MpeZone -> Bool
$c== :: MpeZone -> MpeZone -> Bool
Eq, Int -> MpeZone -> ShowS
[MpeZone] -> ShowS
MpeZone -> String
(Int -> MpeZone -> ShowS)
-> (MpeZone -> String) -> ([MpeZone] -> ShowS) -> Show MpeZone
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MpeZone] -> ShowS
$cshowList :: [MpeZone] -> ShowS
show :: MpeZone -> String
$cshow :: MpeZone -> String
showsPrec :: Int -> MpeZone -> ShowS
$cshowsPrec :: Int -> MpeZone -> ShowS
Show)

-- | MPE config where channel 0 is the useless master and 1-15 are used for
-- notes.  This is the one the MPE doc recommends MPE synths start up in.
mpe_2_to_16 :: [Message]
mpe_2_to_16 :: [Message]
mpe_2_to_16 = MpeZone -> Maybe Manufacturer -> [Message]
mpe_configure MpeZone
Lower (Manufacturer -> Maybe Manufacturer
forall a. a -> Maybe a
Just Manufacturer
15)

-- | MPE basically means "midi channels actually work."  Except we lose a
-- channel to be the master channel, where a channel message still affects all
-- the other channels too.  The MIDI backend doesn't support a separate master
-- channel, but it seems pretty useless because if I want to affect
-- all notes, I will send messages for all notes.
--
-- Still, MPE support is a good thing because at least 15 channels work
-- properly, and hopefully 'pitch_bend_range' is supported, though the default
-- of (-48, +48) is acceptable.
--
-- The other MPE innovation is that it might support cc 74, to do something
-- expressive.
mpe_configure :: MpeZone -> Maybe Channel -> [Message]
mpe_configure :: MpeZone -> Maybe Manufacturer -> [Message]
mpe_configure MpeZone
zone Maybe Manufacturer
channels =
    (ChannelMessage -> Message) -> [ChannelMessage] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan) ((Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
rpn (Manufacturer
0, Manufacturer
6) (Manufacturer -> Maybe Manufacturer -> Manufacturer
forall a. a -> Maybe a -> a
fromMaybe Manufacturer
0 Maybe Manufacturer
channels, Manufacturer
0))
    where
    chan :: Manufacturer
chan = case MpeZone
zone of
        MpeZone
Lower -> Manufacturer
0
        MpeZone
Upper -> Manufacturer
15

{- | This is an emulation of 'realtime_tuning' for Kontakt KSP, which
    understands NRPNs, but not sysex.

    Each key gets (50, 0) with the source key, (51, 0) with the destination,
    and (52, 0) with tenths of a cent as a 14-bit number.  I have to put
    source and destination NoteNumbers into separate NRPN numbers because
    msb and lsb arrive separately, so they pretty much have to be used as
    msb and lsb of a single number.

    The KSP for this is User/Elaforge/Instrument/Kontakt/ksp/nrpn_tuning.ksp.
-}
nrpn_tuning :: [(Key, NoteNumber)] -> [ChannelMessage]
nrpn_tuning :: [(Key, Double)] -> [ChannelMessage]
nrpn_tuning = ((Key, Double) -> [ChannelMessage])
-> [(Key, Double)] -> [ChannelMessage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Key, Double) -> [ChannelMessage]
forall {b}. RealFrac b => (Key, b) -> [ChannelMessage]
retune_key
    where
    retune_key :: (Key, b) -> [ChannelMessage]
retune_key (Key
key, b
nn) = [[ChannelMessage]] -> [ChannelMessage]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Manufacturer -> Manufacturer -> [ChannelMessage]
emit Manufacturer
50 (Key -> Manufacturer
forall a. Num a => Key -> a
from_key Key
key)
        , Manufacturer -> Manufacturer -> [ChannelMessage]
emit Manufacturer
51 Manufacturer
to_key
        , (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
nrpn (Manufacturer
0, Manufacturer
52) (Manufacturer
msb, Manufacturer
lsb)
        ]
        where
        emit :: Manufacturer -> Manufacturer -> [ChannelMessage]
emit Manufacturer
key Manufacturer
value = (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
nrpn (Manufacturer
0, Manufacturer
key) (Manufacturer
value, Manufacturer
0)
        (Manufacturer
lsb, Manufacturer
msb) = Int -> (Manufacturer, Manufacturer)
split14 (Int -> (Manufacturer, Manufacturer))
-> Int -> (Manufacturer, Manufacturer)
forall a b. (a -> b) -> a -> b
$ b -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (b -> Int) -> b -> Int
forall a b. (a -> b) -> a -> b
$ b
frac b -> b -> b
forall a. Num a => a -> a -> a
* b
centicent
        -- 2^14 = 16384, so I can fit 10000.  I think KSP only does integer
        -- math, so I can't properly rescale 2^14 to its millicents.
        centicent :: b
centicent = b
100 b -> b -> b
forall a. Num a => a -> a -> a
* b
100
        (Manufacturer
to_key, b
frac) = b -> (Manufacturer, b)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction b
nn

rpn :: (ControlValue, ControlValue) -> (ControlValue, ControlValue)
    -> [ChannelMessage]
rpn :: (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
rpn (Manufacturer
key_msb, Manufacturer
key_lsb) (Manufacturer
value_msb, Manufacturer
value_lsb) =
    [ Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_msb Manufacturer
key_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_lsb Manufacturer
key_lsb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry Manufacturer
value_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry_lsb Manufacturer
value_lsb
    ]

cancel_rpn :: [ChannelMessage]
cancel_rpn :: [ChannelMessage]
cancel_rpn = [Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_msb Manufacturer
127, Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.rpn_lsb Manufacturer
127]

nrpn :: (ControlValue, ControlValue) -> (ControlValue, ControlValue)
    -> [ChannelMessage]
nrpn :: (Manufacturer, Manufacturer)
-> (Manufacturer, Manufacturer) -> [ChannelMessage]
nrpn (Manufacturer
key_msb, Manufacturer
key_lsb) (Manufacturer
value_msb, Manufacturer
value_lsb) =
    [ Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.nrpn_msb Manufacturer
key_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.nrpn_lsb Manufacturer
key_lsb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry Manufacturer
value_msb
    , Manufacturer -> Manufacturer -> ChannelMessage
ControlChange Manufacturer
CC.data_entry_lsb Manufacturer
value_lsb
    ]

-- * modify

set_channel :: Channel -> Message -> Message
set_channel :: Manufacturer -> Message -> Message
set_channel Manufacturer
chan (ChannelMessage Manufacturer
_ ChannelMessage
msg) = Manufacturer -> ChannelMessage -> Message
ChannelMessage Manufacturer
chan ChannelMessage
msg
set_channel Manufacturer
_ Message
msg = Message
msg

-- * predicates

-- | Check to make sure midi msg vals are all in range.
valid_msg :: Message -> Bool
valid_msg :: Message -> Bool
valid_msg (ChannelMessage Manufacturer
chan ChannelMessage
msg) =
    Manufacturer
0 Manufacturer -> Manufacturer -> Bool
forall a. Ord a => a -> a -> Bool
<= Manufacturer
chan Bool -> Bool -> Bool
&& Manufacturer
chan Manufacturer -> Manufacturer -> Bool
forall a. Ord a => a -> a -> Bool
< Manufacturer
16 Bool -> Bool -> Bool
&& ChannelMessage -> Bool
valid_chan_msg ChannelMessage
msg
valid_msg Message
_ = Bool
True

valid_chan_msg :: ChannelMessage -> Bool
valid_chan_msg :: ChannelMessage -> Bool
valid_chan_msg ChannelMessage
msg = case ChannelMessage
msg of
    ControlChange Manufacturer
cc Manufacturer
val -> Manufacturer -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
cc Bool -> Bool -> Bool
&& Manufacturer -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
val
    NoteOn (Key Int
key) Manufacturer
vel -> Int -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
val7 Int
key Bool -> Bool -> Bool
&& Manufacturer -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
vel
    NoteOff (Key Int
key) Manufacturer
vel -> Int -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
val7 Int
key Bool -> Bool -> Bool
&& Manufacturer -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
val7 Manufacturer
vel
    PitchBend PitchBendValue
val -> -PitchBendValue
1 PitchBendValue -> PitchBendValue -> Bool
forall a. Ord a => a -> a -> Bool
<= PitchBendValue
val Bool -> Bool -> Bool
&& PitchBendValue
val PitchBendValue -> PitchBendValue -> Bool
forall a. Ord a => a -> a -> Bool
<= PitchBendValue
1
    ChannelMessage
_ -> Bool
True
    where val7 :: a -> Bool
val7 a
v = a
0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
v Bool -> Bool -> Bool
&& a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
128

is_cc :: Message -> Bool
is_cc :: Message -> Bool
is_cc (ChannelMessage Manufacturer
_ (ControlChange Manufacturer
_ Manufacturer
_)) = Bool
True
is_cc Message
_ = Bool
False

is_sysex :: Message -> Bool
is_sysex :: Message -> Bool
is_sysex (CommonMessage (SystemExclusive Manufacturer
_ ByteString
_)) = Bool
True
is_sysex Message
_ = Bool
False

is_note :: Message -> Bool
is_note :: Message -> Bool
is_note (ChannelMessage Manufacturer
_ (NoteOn Key
_ Manufacturer
_)) = Bool
True
is_note (ChannelMessage Manufacturer
_ (NoteOff Key
_ Manufacturer
_)) = Bool
True
is_note Message
_ = Bool
False

is_note_on :: Message -> Bool
is_note_on :: Message -> Bool
is_note_on (ChannelMessage Manufacturer
_ (NoteOn Key
_ Manufacturer
_)) = Bool
True
is_note_on Message
_ = Bool
False

-- | Is this a message that will change the channel state?  These are the
-- messages that will affect subsequent NoteOns.
is_state :: Message -> Bool
is_state :: Message -> Bool
is_state (ChannelMessage Manufacturer
_ ChannelMessage
msg) = case ChannelMessage
msg of
    NoteOn {} -> Bool
False
    NoteOff {} -> Bool
False
    ChannelMessage
_ -> Bool
True
is_state Message
_ = Bool
False

-- | True for messages with a pitch: NoteOn, NoteOff and PitchBend.
is_pitched :: Message -> Bool
is_pitched :: Message -> Bool
is_pitched Message
msg = Message -> Bool
is_note Message
msg Bool -> Bool -> Bool
|| case Message
msg of
    ChannelMessage Manufacturer
_ (PitchBend PitchBendValue
_) -> Bool
True
    Message
_ -> Bool
False

-- * projections

channel_message :: Message -> Maybe ChannelMessage
channel_message :: Message -> Maybe ChannelMessage
channel_message (ChannelMessage Manufacturer
_ ChannelMessage
m) = ChannelMessage -> Maybe ChannelMessage
forall a. a -> Maybe a
Just ChannelMessage
m
channel_message Message
_ = Maybe ChannelMessage
forall a. Maybe a
Nothing

message_channel :: Message -> Maybe Channel
message_channel :: Message -> Maybe Manufacturer
message_channel (ChannelMessage Manufacturer
chan ChannelMessage
_) = Manufacturer -> Maybe Manufacturer
forall a. a -> Maybe a
Just Manufacturer
chan
message_channel Message
_ = Maybe Manufacturer
forall a. Maybe a
Nothing

-- * types

data Message =
    ChannelMessage !Channel !ChannelMessage
    | CommonMessage !CommonMessage
    | RealtimeMessage !RealtimeMessage
    | UnknownMessage !Word8 !Word8 !Word8
    deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq, Eq Message
Eq Message
-> (Message -> Message -> Ordering)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Bool)
-> (Message -> Message -> Message)
-> (Message -> Message -> Message)
-> Ord Message
Message -> Message -> Bool
Message -> Message -> Ordering
Message -> Message -> Message
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Message -> Message -> Message
$cmin :: Message -> Message -> Message
max :: Message -> Message -> Message
$cmax :: Message -> Message -> Message
>= :: Message -> Message -> Bool
$c>= :: Message -> Message -> Bool
> :: Message -> Message -> Bool
$c> :: Message -> Message -> Bool
<= :: Message -> Message -> Bool
$c<= :: Message -> Message -> Bool
< :: Message -> Message -> Bool
$c< :: Message -> Message -> Bool
compare :: Message -> Message -> Ordering
$ccompare :: Message -> Message -> Ordering
Ord, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show, ReadPrec [Message]
ReadPrec Message
Int -> ReadS Message
ReadS [Message]
(Int -> ReadS Message)
-> ReadS [Message]
-> ReadPrec Message
-> ReadPrec [Message]
-> Read Message
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Message]
$creadListPrec :: ReadPrec [Message]
readPrec :: ReadPrec Message
$creadPrec :: ReadPrec Message
readList :: ReadS [Message]
$creadList :: ReadS [Message]
readsPrec :: Int -> ReadS Message
$creadsPrec :: Int -> ReadS Message
Read)

instance Pretty Message where
    pretty :: Message -> Text
pretty (CommonMessage (SystemExclusive Manufacturer
manuf ByteString
bytes)) =
        Text
"sysex " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Manufacturer -> Text
manufacturer_name Manufacturer
manuf
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt (ByteString -> Int
ByteString.length ByteString
bytes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes>"
    pretty (ChannelMessage Manufacturer
chan ChannelMessage
msg) =
        Text
"chan:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Manufacturer -> Text
forall a. Show a => a -> Text
showt Manufacturer
chan Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChannelMessage -> Text
forall a. Pretty a => a -> Text
pretty ChannelMessage
msg
    pretty Message
msg = Message -> Text
forall a. Show a => a -> Text
showt Message
msg

-- | These will be encoded with 7-bits, via the usual truncation.  It's not
-- exactly safe, but then it's not like haskell checks for overflow anywhere
-- else either.
type Word7 = Word8
type Word4 = Word8

type Channel = Word4
type Velocity = Word7
type Control = CC.Control
type Program = Word7
type ControlValue = Word7
-- | This is converted to and from the -0x2000 and +0x2000 range by the parser.
type PitchBendValue = Float
type Manufacturer = Word7

newtype Key = Key Int
    deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Eq Key
Eq Key
-> (Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
Ord, Integer -> Key
Key -> Key
Key -> Key -> Key
(Key -> Key -> Key)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> (Key -> Key)
-> (Key -> Key)
-> (Key -> Key)
-> (Integer -> Key)
-> Num Key
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Key
$cfromInteger :: Integer -> Key
signum :: Key -> Key
$csignum :: Key -> Key
abs :: Key -> Key
$cabs :: Key -> Key
negate :: Key -> Key
$cnegate :: Key -> Key
* :: Key -> Key -> Key
$c* :: Key -> Key -> Key
- :: Key -> Key -> Key
$c- :: Key -> Key -> Key
+ :: Key -> Key -> Key
$c+ :: Key -> Key -> Key
Num, Int -> Key
Key -> Int
Key -> [Key]
Key -> Key
Key -> Key -> [Key]
Key -> Key -> Key -> [Key]
(Key -> Key)
-> (Key -> Key)
-> (Int -> Key)
-> (Key -> Int)
-> (Key -> [Key])
-> (Key -> Key -> [Key])
-> (Key -> Key -> [Key])
-> (Key -> Key -> Key -> [Key])
-> Enum Key
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Key -> Key -> Key -> [Key]
$cenumFromThenTo :: Key -> Key -> Key -> [Key]
enumFromTo :: Key -> Key -> [Key]
$cenumFromTo :: Key -> Key -> [Key]
enumFromThen :: Key -> Key -> [Key]
$cenumFromThen :: Key -> Key -> [Key]
enumFrom :: Key -> [Key]
$cenumFrom :: Key -> [Key]
fromEnum :: Key -> Int
$cfromEnum :: Key -> Int
toEnum :: Int -> Key
$ctoEnum :: Int -> Key
pred :: Key -> Key
$cpred :: Key -> Key
succ :: Key -> Key
$csucc :: Key -> Key
Enum, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show, ReadPrec [Key]
ReadPrec Key
Int -> ReadS Key
ReadS [Key]
(Int -> ReadS Key)
-> ReadS [Key] -> ReadPrec Key -> ReadPrec [Key] -> Read Key
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Key]
$creadListPrec :: ReadPrec [Key]
readPrec :: ReadPrec Key
$creadPrec :: ReadPrec Key
readList :: ReadS [Key]
$creadList :: ReadS [Key]
readsPrec :: Int -> ReadS Key
$creadsPrec :: Int -> ReadS Key
Read, Key -> ()
(Key -> ()) -> NFData Key
forall a. (a -> ()) -> NFData a
rnf :: Key -> ()
$crnf :: Key -> ()
DeepSeq.NFData)
    -- This was initially a Word7 to match MIDI's range, but unlike the other
    -- types, I sometimes do math on these, and Word7's tiny range is kind of
    -- scary for that.

instance Serialize.Serialize Key where
    -- The old encoding used Word8, so keep that for compatibility.
    put :: Putter Key
put Key
key = Putter Manufacturer
forall a. Serialize a => Putter a
Serialize.put (Key -> Manufacturer
forall a. Num a => Key -> a
from_key Key
key :: Word8)
    get :: Get Key
get = (Manufacturer -> Key
forall a. Integral a => a -> Key
to_key :: Word8 -> Key) (Manufacturer -> Key) -> Get Manufacturer -> Get Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Manufacturer
forall a. Serialize a => Get a
Serialize.get

instance Pretty Key where
    pretty :: Key -> Text
pretty (Key Int
key) = Text
note Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt (Int
oct Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        where
        (Int
oct, Int
k) = Int
key Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
12
        note :: Text
note = case Int
k of
            Int
0 -> Text
"c"; Int
1 -> Text
"cs"
            Int
2 -> Text
"d"; Int
3 -> Text
"ds"
            Int
4 -> Text
"e"
            Int
5 -> Text
"f"; Int
6 -> Text
"fs"
            Int
7 -> Text
"g"; Int
8 -> Text
"gs"
            Int
9 -> Text
"a"; Int
10 -> Text
"as"
            Int
11 -> Text
"b"
            Int
_ -> Text
""

from_key :: Num a => Key -> a
from_key :: forall a. Num a => Key -> a
from_key (Key Int
k) = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k

to_key :: Integral a => a -> Key
to_key :: forall a. Integral a => a -> Key
to_key = Int -> Key
Key (Int -> Key) -> (a -> Int) -> a -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int) -> (a -> a) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a. Ord a => a -> a -> a
min a
127 (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a. Ord a => a -> a -> a
max a
0

to_closest_key :: RealFrac a => a -> (Key, a)
to_closest_key :: forall a. RealFrac a => a -> (Key, a)
to_closest_key a
nn
    | a
frac a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0.5 = (Integer -> Key
forall a. Integral a => a -> Key
to_key (Integer
dInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1), a
frac a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
    | Bool
otherwise = (Integer -> Key
forall a. Integral a => a -> Key
to_key Integer
d, a
frac)
    where (Integer
d, a
frac) = a -> (Integer, a)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
nn

data ChannelMessage =
    NoteOff !Key !Velocity
    | NoteOn !Key !Velocity
    | Aftertouch !Key !ControlValue
    | ControlChange !Control !ControlValue
    | ProgramChange !Program
    | ChannelPressure !ControlValue
    | PitchBend !PitchBendValue
    -- | This is PitchBend, but with precise control over the bytes sent.
    | PitchBendInt !Word7 !Word7
    -- | channel mode messages (special control values)
    | AllSoundOff
    | ResetAllControls
    | LocalControl !Bool
    | AllNotesOff
    -- | There are a few values in the ChannelMode range left undefined.
    | UndefinedChannelMode !Word7 !Word7
    deriving (ChannelMessage -> ChannelMessage -> Bool
(ChannelMessage -> ChannelMessage -> Bool)
-> (ChannelMessage -> ChannelMessage -> Bool) -> Eq ChannelMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChannelMessage -> ChannelMessage -> Bool
$c/= :: ChannelMessage -> ChannelMessage -> Bool
== :: ChannelMessage -> ChannelMessage -> Bool
$c== :: ChannelMessage -> ChannelMessage -> Bool
Eq, Eq ChannelMessage
Eq ChannelMessage
-> (ChannelMessage -> ChannelMessage -> Ordering)
-> (ChannelMessage -> ChannelMessage -> Bool)
-> (ChannelMessage -> ChannelMessage -> Bool)
-> (ChannelMessage -> ChannelMessage -> Bool)
-> (ChannelMessage -> ChannelMessage -> Bool)
-> (ChannelMessage -> ChannelMessage -> ChannelMessage)
-> (ChannelMessage -> ChannelMessage -> ChannelMessage)
-> Ord ChannelMessage
ChannelMessage -> ChannelMessage -> Bool
ChannelMessage -> ChannelMessage -> Ordering
ChannelMessage -> ChannelMessage -> ChannelMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ChannelMessage -> ChannelMessage -> ChannelMessage
$cmin :: ChannelMessage -> ChannelMessage -> ChannelMessage
max :: ChannelMessage -> ChannelMessage -> ChannelMessage
$cmax :: ChannelMessage -> ChannelMessage -> ChannelMessage
>= :: ChannelMessage -> ChannelMessage -> Bool
$c>= :: ChannelMessage -> ChannelMessage -> Bool
> :: ChannelMessage -> ChannelMessage -> Bool
$c> :: ChannelMessage -> ChannelMessage -> Bool
<= :: ChannelMessage -> ChannelMessage -> Bool
$c<= :: ChannelMessage -> ChannelMessage -> Bool
< :: ChannelMessage -> ChannelMessage -> Bool
$c< :: ChannelMessage -> ChannelMessage -> Bool
compare :: ChannelMessage -> ChannelMessage -> Ordering
$ccompare :: ChannelMessage -> ChannelMessage -> Ordering
Ord, Int -> ChannelMessage -> ShowS
[ChannelMessage] -> ShowS
ChannelMessage -> String
(Int -> ChannelMessage -> ShowS)
-> (ChannelMessage -> String)
-> ([ChannelMessage] -> ShowS)
-> Show ChannelMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChannelMessage] -> ShowS
$cshowList :: [ChannelMessage] -> ShowS
show :: ChannelMessage -> String
$cshow :: ChannelMessage -> String
showsPrec :: Int -> ChannelMessage -> ShowS
$cshowsPrec :: Int -> ChannelMessage -> ShowS
Show, ReadPrec [ChannelMessage]
ReadPrec ChannelMessage
Int -> ReadS ChannelMessage
ReadS [ChannelMessage]
(Int -> ReadS ChannelMessage)
-> ReadS [ChannelMessage]
-> ReadPrec ChannelMessage
-> ReadPrec [ChannelMessage]
-> Read ChannelMessage
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ChannelMessage]
$creadListPrec :: ReadPrec [ChannelMessage]
readPrec :: ReadPrec ChannelMessage
$creadPrec :: ReadPrec ChannelMessage
readList :: ReadS [ChannelMessage]
$creadList :: ReadS [ChannelMessage]
readsPrec :: Int -> ReadS ChannelMessage
$creadsPrec :: Int -> ReadS ChannelMessage
Read)

data CommonMessage =
    -- | manufacturer id, data including eox
    SystemExclusive !Manufacturer !ByteString.ByteString
    | SongPositionPointer !Int
    | SongSelect !Word8
    | TuneRequest
    | EOX
    | UndefinedCommon !Word8
    deriving (CommonMessage -> CommonMessage -> Bool
(CommonMessage -> CommonMessage -> Bool)
-> (CommonMessage -> CommonMessage -> Bool) -> Eq CommonMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommonMessage -> CommonMessage -> Bool
$c/= :: CommonMessage -> CommonMessage -> Bool
== :: CommonMessage -> CommonMessage -> Bool
$c== :: CommonMessage -> CommonMessage -> Bool
Eq, Eq CommonMessage
Eq CommonMessage
-> (CommonMessage -> CommonMessage -> Ordering)
-> (CommonMessage -> CommonMessage -> Bool)
-> (CommonMessage -> CommonMessage -> Bool)
-> (CommonMessage -> CommonMessage -> Bool)
-> (CommonMessage -> CommonMessage -> Bool)
-> (CommonMessage -> CommonMessage -> CommonMessage)
-> (CommonMessage -> CommonMessage -> CommonMessage)
-> Ord CommonMessage
CommonMessage -> CommonMessage -> Bool
CommonMessage -> CommonMessage -> Ordering
CommonMessage -> CommonMessage -> CommonMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommonMessage -> CommonMessage -> CommonMessage
$cmin :: CommonMessage -> CommonMessage -> CommonMessage
max :: CommonMessage -> CommonMessage -> CommonMessage
$cmax :: CommonMessage -> CommonMessage -> CommonMessage
>= :: CommonMessage -> CommonMessage -> Bool
$c>= :: CommonMessage -> CommonMessage -> Bool
> :: CommonMessage -> CommonMessage -> Bool
$c> :: CommonMessage -> CommonMessage -> Bool
<= :: CommonMessage -> CommonMessage -> Bool
$c<= :: CommonMessage -> CommonMessage -> Bool
< :: CommonMessage -> CommonMessage -> Bool
$c< :: CommonMessage -> CommonMessage -> Bool
compare :: CommonMessage -> CommonMessage -> Ordering
$ccompare :: CommonMessage -> CommonMessage -> Ordering
Ord, Int -> CommonMessage -> ShowS
[CommonMessage] -> ShowS
CommonMessage -> String
(Int -> CommonMessage -> ShowS)
-> (CommonMessage -> String)
-> ([CommonMessage] -> ShowS)
-> Show CommonMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommonMessage] -> ShowS
$cshowList :: [CommonMessage] -> ShowS
show :: CommonMessage -> String
$cshow :: CommonMessage -> String
showsPrec :: Int -> CommonMessage -> ShowS
$cshowsPrec :: Int -> CommonMessage -> ShowS
Show, ReadPrec [CommonMessage]
ReadPrec CommonMessage
Int -> ReadS CommonMessage
ReadS [CommonMessage]
(Int -> ReadS CommonMessage)
-> ReadS [CommonMessage]
-> ReadPrec CommonMessage
-> ReadPrec [CommonMessage]
-> Read CommonMessage
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CommonMessage]
$creadListPrec :: ReadPrec [CommonMessage]
readPrec :: ReadPrec CommonMessage
$creadPrec :: ReadPrec CommonMessage
readList :: ReadS [CommonMessage]
$creadList :: ReadS [CommonMessage]
readsPrec :: Int -> ReadS CommonMessage
$creadsPrec :: Int -> ReadS CommonMessage
Read)

data RealtimeMessage = MtcQuarterFrame !Mtc | TimingClock | Start | Continue
    | Stop | ActiveSense | Reset | UndefinedRealtime !Word8
    deriving (RealtimeMessage -> RealtimeMessage -> Bool
(RealtimeMessage -> RealtimeMessage -> Bool)
-> (RealtimeMessage -> RealtimeMessage -> Bool)
-> Eq RealtimeMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RealtimeMessage -> RealtimeMessage -> Bool
$c/= :: RealtimeMessage -> RealtimeMessage -> Bool
== :: RealtimeMessage -> RealtimeMessage -> Bool
$c== :: RealtimeMessage -> RealtimeMessage -> Bool
Eq, Eq RealtimeMessage
Eq RealtimeMessage
-> (RealtimeMessage -> RealtimeMessage -> Ordering)
-> (RealtimeMessage -> RealtimeMessage -> Bool)
-> (RealtimeMessage -> RealtimeMessage -> Bool)
-> (RealtimeMessage -> RealtimeMessage -> Bool)
-> (RealtimeMessage -> RealtimeMessage -> Bool)
-> (RealtimeMessage -> RealtimeMessage -> RealtimeMessage)
-> (RealtimeMessage -> RealtimeMessage -> RealtimeMessage)
-> Ord RealtimeMessage
RealtimeMessage -> RealtimeMessage -> Bool
RealtimeMessage -> RealtimeMessage -> Ordering
RealtimeMessage -> RealtimeMessage -> RealtimeMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
$cmin :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
max :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
$cmax :: RealtimeMessage -> RealtimeMessage -> RealtimeMessage
>= :: RealtimeMessage -> RealtimeMessage -> Bool
$c>= :: RealtimeMessage -> RealtimeMessage -> Bool
> :: RealtimeMessage -> RealtimeMessage -> Bool
$c> :: RealtimeMessage -> RealtimeMessage -> Bool
<= :: RealtimeMessage -> RealtimeMessage -> Bool
$c<= :: RealtimeMessage -> RealtimeMessage -> Bool
< :: RealtimeMessage -> RealtimeMessage -> Bool
$c< :: RealtimeMessage -> RealtimeMessage -> Bool
compare :: RealtimeMessage -> RealtimeMessage -> Ordering
$ccompare :: RealtimeMessage -> RealtimeMessage -> Ordering
Ord, Int -> RealtimeMessage -> ShowS
[RealtimeMessage] -> ShowS
RealtimeMessage -> String
(Int -> RealtimeMessage -> ShowS)
-> (RealtimeMessage -> String)
-> ([RealtimeMessage] -> ShowS)
-> Show RealtimeMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RealtimeMessage] -> ShowS
$cshowList :: [RealtimeMessage] -> ShowS
show :: RealtimeMessage -> String
$cshow :: RealtimeMessage -> String
showsPrec :: Int -> RealtimeMessage -> ShowS
$cshowsPrec :: Int -> RealtimeMessage -> ShowS
Show, ReadPrec [RealtimeMessage]
ReadPrec RealtimeMessage
Int -> ReadS RealtimeMessage
ReadS [RealtimeMessage]
(Int -> ReadS RealtimeMessage)
-> ReadS [RealtimeMessage]
-> ReadPrec RealtimeMessage
-> ReadPrec [RealtimeMessage]
-> Read RealtimeMessage
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RealtimeMessage]
$creadListPrec :: ReadPrec [RealtimeMessage]
readPrec :: ReadPrec RealtimeMessage
$creadPrec :: ReadPrec RealtimeMessage
readList :: ReadS [RealtimeMessage]
$creadList :: ReadS [RealtimeMessage]
readsPrec :: Int -> ReadS RealtimeMessage
$creadsPrec :: Int -> ReadS RealtimeMessage
Read)

instance DeepSeq.NFData Message where rnf :: Message -> ()
rnf Message
_ = ()
instance DeepSeq.NFData ChannelMessage where rnf :: ChannelMessage -> ()
rnf ChannelMessage
_ = ()
instance DeepSeq.NFData CommonMessage where rnf :: CommonMessage -> ()
rnf CommonMessage
_ = ()
instance DeepSeq.NFData RealtimeMessage where rnf :: RealtimeMessage -> ()
rnf RealtimeMessage
_ = ()

instance Pretty ChannelMessage where
    format :: ChannelMessage -> Doc
format ChannelMessage
msg = case ChannelMessage
msg of
        NoteOff Key
key Manufacturer
vel -> Doc
"NoteOff" Doc -> Doc -> Doc
<+> Key -> Doc
forall a. Pretty a => a -> Doc
format Key
key Doc -> Doc -> Doc
<+> Manufacturer -> Doc
forall a. Pretty a => a -> Doc
format Manufacturer
vel
        NoteOn Key
key Manufacturer
vel -> Doc
"NoteOn" Doc -> Doc -> Doc
<+> Key -> Doc
forall a. Pretty a => a -> Doc
format Key
key Doc -> Doc -> Doc
<+> Manufacturer -> Doc
forall a. Pretty a => a -> Doc
format Manufacturer
vel
        Aftertouch Key
key Manufacturer
vel -> Doc
"Aftertouch" Doc -> Doc -> Doc
<+> Key -> Doc
forall a. Pretty a => a -> Doc
format Key
key Doc -> Doc -> Doc
<+> Manufacturer -> Doc
forall a. Pretty a => a -> Doc
format Manufacturer
vel
        ChannelMessage
_ -> Text -> Doc
Pretty.text (ChannelMessage -> Text
forall a. Show a => a -> Text
showt ChannelMessage
msg)

-- * MTC

data Mtc = Mtc !SmpteFragment !Word4
    deriving (Mtc -> Mtc -> Bool
(Mtc -> Mtc -> Bool) -> (Mtc -> Mtc -> Bool) -> Eq Mtc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mtc -> Mtc -> Bool
$c/= :: Mtc -> Mtc -> Bool
== :: Mtc -> Mtc -> Bool
$c== :: Mtc -> Mtc -> Bool
Eq, Eq Mtc
Eq Mtc
-> (Mtc -> Mtc -> Ordering)
-> (Mtc -> Mtc -> Bool)
-> (Mtc -> Mtc -> Bool)
-> (Mtc -> Mtc -> Bool)
-> (Mtc -> Mtc -> Bool)
-> (Mtc -> Mtc -> Mtc)
-> (Mtc -> Mtc -> Mtc)
-> Ord Mtc
Mtc -> Mtc -> Bool
Mtc -> Mtc -> Ordering
Mtc -> Mtc -> Mtc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Mtc -> Mtc -> Mtc
$cmin :: Mtc -> Mtc -> Mtc
max :: Mtc -> Mtc -> Mtc
$cmax :: Mtc -> Mtc -> Mtc
>= :: Mtc -> Mtc -> Bool
$c>= :: Mtc -> Mtc -> Bool
> :: Mtc -> Mtc -> Bool
$c> :: Mtc -> Mtc -> Bool
<= :: Mtc -> Mtc -> Bool
$c<= :: Mtc -> Mtc -> Bool
< :: Mtc -> Mtc -> Bool
$c< :: Mtc -> Mtc -> Bool
compare :: Mtc -> Mtc -> Ordering
$ccompare :: Mtc -> Mtc -> Ordering
Ord, Int -> Mtc -> ShowS
[Mtc] -> ShowS
Mtc -> String
(Int -> Mtc -> ShowS)
-> (Mtc -> String) -> ([Mtc] -> ShowS) -> Show Mtc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mtc] -> ShowS
$cshowList :: [Mtc] -> ShowS
show :: Mtc -> String
$cshow :: Mtc -> String
showsPrec :: Int -> Mtc -> ShowS
$cshowsPrec :: Int -> Mtc -> ShowS
Show, ReadPrec [Mtc]
ReadPrec Mtc
Int -> ReadS Mtc
ReadS [Mtc]
(Int -> ReadS Mtc)
-> ReadS [Mtc] -> ReadPrec Mtc -> ReadPrec [Mtc] -> Read Mtc
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Mtc]
$creadListPrec :: ReadPrec [Mtc]
readPrec :: ReadPrec Mtc
$creadPrec :: ReadPrec Mtc
readList :: ReadS [Mtc]
$creadList :: ReadS [Mtc]
readsPrec :: Int -> ReadS Mtc
$creadsPrec :: Int -> ReadS Mtc
Read)
data FrameRate = Frame24 | Frame25 | Frame29_97df | Frame30
    deriving (Int -> FrameRate
FrameRate -> Int
FrameRate -> [FrameRate]
FrameRate -> FrameRate
FrameRate -> FrameRate -> [FrameRate]
FrameRate -> FrameRate -> FrameRate -> [FrameRate]
(FrameRate -> FrameRate)
-> (FrameRate -> FrameRate)
-> (Int -> FrameRate)
-> (FrameRate -> Int)
-> (FrameRate -> [FrameRate])
-> (FrameRate -> FrameRate -> [FrameRate])
-> (FrameRate -> FrameRate -> [FrameRate])
-> (FrameRate -> FrameRate -> FrameRate -> [FrameRate])
-> Enum FrameRate
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: FrameRate -> FrameRate -> FrameRate -> [FrameRate]
$cenumFromThenTo :: FrameRate -> FrameRate -> FrameRate -> [FrameRate]
enumFromTo :: FrameRate -> FrameRate -> [FrameRate]
$cenumFromTo :: FrameRate -> FrameRate -> [FrameRate]
enumFromThen :: FrameRate -> FrameRate -> [FrameRate]
$cenumFromThen :: FrameRate -> FrameRate -> [FrameRate]
enumFrom :: FrameRate -> [FrameRate]
$cenumFrom :: FrameRate -> [FrameRate]
fromEnum :: FrameRate -> Int
$cfromEnum :: FrameRate -> Int
toEnum :: Int -> FrameRate
$ctoEnum :: Int -> FrameRate
pred :: FrameRate -> FrameRate
$cpred :: FrameRate -> FrameRate
succ :: FrameRate -> FrameRate
$csucc :: FrameRate -> FrameRate
Enum, Int -> FrameRate -> ShowS
[FrameRate] -> ShowS
FrameRate -> String
(Int -> FrameRate -> ShowS)
-> (FrameRate -> String)
-> ([FrameRate] -> ShowS)
-> Show FrameRate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FrameRate] -> ShowS
$cshowList :: [FrameRate] -> ShowS
show :: FrameRate -> String
$cshow :: FrameRate -> String
showsPrec :: Int -> FrameRate -> ShowS
$cshowsPrec :: Int -> FrameRate -> ShowS
Show)
data SmpteFragment = FrameLsb | FrameMsb | SecondLsb | SecondMsb
    | MinuteLsb | MinuteMsb | HourLsb | RateHourMsb
    deriving (Int -> SmpteFragment
SmpteFragment -> Int
SmpteFragment -> [SmpteFragment]
SmpteFragment -> SmpteFragment
SmpteFragment -> SmpteFragment -> [SmpteFragment]
SmpteFragment -> SmpteFragment -> SmpteFragment -> [SmpteFragment]
(SmpteFragment -> SmpteFragment)
-> (SmpteFragment -> SmpteFragment)
-> (Int -> SmpteFragment)
-> (SmpteFragment -> Int)
-> (SmpteFragment -> [SmpteFragment])
-> (SmpteFragment -> SmpteFragment -> [SmpteFragment])
-> (SmpteFragment -> SmpteFragment -> [SmpteFragment])
-> (SmpteFragment
    -> SmpteFragment -> SmpteFragment -> [SmpteFragment])
-> Enum SmpteFragment
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SmpteFragment -> SmpteFragment -> SmpteFragment -> [SmpteFragment]
$cenumFromThenTo :: SmpteFragment -> SmpteFragment -> SmpteFragment -> [SmpteFragment]
enumFromTo :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
$cenumFromTo :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
enumFromThen :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
$cenumFromThen :: SmpteFragment -> SmpteFragment -> [SmpteFragment]
enumFrom :: SmpteFragment -> [SmpteFragment]
$cenumFrom :: SmpteFragment -> [SmpteFragment]
fromEnum :: SmpteFragment -> Int
$cfromEnum :: SmpteFragment -> Int
toEnum :: Int -> SmpteFragment
$ctoEnum :: Int -> SmpteFragment
pred :: SmpteFragment -> SmpteFragment
$cpred :: SmpteFragment -> SmpteFragment
succ :: SmpteFragment -> SmpteFragment
$csucc :: SmpteFragment -> SmpteFragment
Enum, SmpteFragment -> SmpteFragment -> Bool
(SmpteFragment -> SmpteFragment -> Bool)
-> (SmpteFragment -> SmpteFragment -> Bool) -> Eq SmpteFragment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SmpteFragment -> SmpteFragment -> Bool
$c/= :: SmpteFragment -> SmpteFragment -> Bool
== :: SmpteFragment -> SmpteFragment -> Bool
$c== :: SmpteFragment -> SmpteFragment -> Bool
Eq, Eq SmpteFragment
Eq SmpteFragment
-> (SmpteFragment -> SmpteFragment -> Ordering)
-> (SmpteFragment -> SmpteFragment -> Bool)
-> (SmpteFragment -> SmpteFragment -> Bool)
-> (SmpteFragment -> SmpteFragment -> Bool)
-> (SmpteFragment -> SmpteFragment -> Bool)
-> (SmpteFragment -> SmpteFragment -> SmpteFragment)
-> (SmpteFragment -> SmpteFragment -> SmpteFragment)
-> Ord SmpteFragment
SmpteFragment -> SmpteFragment -> Bool
SmpteFragment -> SmpteFragment -> Ordering
SmpteFragment -> SmpteFragment -> SmpteFragment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SmpteFragment -> SmpteFragment -> SmpteFragment
$cmin :: SmpteFragment -> SmpteFragment -> SmpteFragment
max :: SmpteFragment -> SmpteFragment -> SmpteFragment
$cmax :: SmpteFragment -> SmpteFragment -> SmpteFragment
>= :: SmpteFragment -> SmpteFragment -> Bool
$c>= :: SmpteFragment -> SmpteFragment -> Bool
> :: SmpteFragment -> SmpteFragment -> Bool
$c> :: SmpteFragment -> SmpteFragment -> Bool
<= :: SmpteFragment -> SmpteFragment -> Bool
$c<= :: SmpteFragment -> SmpteFragment -> Bool
< :: SmpteFragment -> SmpteFragment -> Bool
$c< :: SmpteFragment -> SmpteFragment -> Bool
compare :: SmpteFragment -> SmpteFragment -> Ordering
$ccompare :: SmpteFragment -> SmpteFragment -> Ordering
Ord, Int -> SmpteFragment -> ShowS
[SmpteFragment] -> ShowS
SmpteFragment -> String
(Int -> SmpteFragment -> ShowS)
-> (SmpteFragment -> String)
-> ([SmpteFragment] -> ShowS)
-> Show SmpteFragment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SmpteFragment] -> ShowS
$cshowList :: [SmpteFragment] -> ShowS
show :: SmpteFragment -> String
$cshow :: SmpteFragment -> String
showsPrec :: Int -> SmpteFragment -> ShowS
$cshowsPrec :: Int -> SmpteFragment -> ShowS
Show, ReadPrec [SmpteFragment]
ReadPrec SmpteFragment
Int -> ReadS SmpteFragment
ReadS [SmpteFragment]
(Int -> ReadS SmpteFragment)
-> ReadS [SmpteFragment]
-> ReadPrec SmpteFragment
-> ReadPrec [SmpteFragment]
-> Read SmpteFragment
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SmpteFragment]
$creadListPrec :: ReadPrec [SmpteFragment]
readPrec :: ReadPrec SmpteFragment
$creadPrec :: ReadPrec SmpteFragment
readList :: ReadS [SmpteFragment]
$creadList :: ReadS [SmpteFragment]
readsPrec :: Int -> ReadS SmpteFragment
$creadsPrec :: Int -> ReadS SmpteFragment
Read)

rate_fps :: FrameRate -> Double
rate_fps :: FrameRate -> Double
rate_fps FrameRate
Frame24 = Double
24
rate_fps FrameRate
Frame25 = Double
25
rate_fps FrameRate
Frame29_97df = Double
29.97
rate_fps FrameRate
Frame30 = Double
30

data Smpte = Smpte {
    Smpte -> Manufacturer
smpte_hours :: !Word8
    , Smpte -> Manufacturer
smpte_minutes :: !Word8
    , Smpte -> Manufacturer
smpte_seconds :: !Word8
    , Smpte -> Manufacturer
smpte_frames :: !Word8
    } deriving (Smpte -> Smpte -> Bool
(Smpte -> Smpte -> Bool) -> (Smpte -> Smpte -> Bool) -> Eq Smpte
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Smpte -> Smpte -> Bool
$c/= :: Smpte -> Smpte -> Bool
== :: Smpte -> Smpte -> Bool
$c== :: Smpte -> Smpte -> Bool
Eq, Int -> Smpte -> ShowS
[Smpte] -> ShowS
Smpte -> String
(Int -> Smpte -> ShowS)
-> (Smpte -> String) -> ([Smpte] -> ShowS) -> Show Smpte
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Smpte] -> ShowS
$cshowList :: [Smpte] -> ShowS
show :: Smpte -> String
$cshow :: Smpte -> String
showsPrec :: Int -> Smpte -> ShowS
$cshowsPrec :: Int -> Smpte -> ShowS
Show)

type Seconds = Double
type Frames = Int

seconds_to_frame :: FrameRate -> Seconds -> Frames
seconds_to_frame :: FrameRate -> Double -> Int
seconds_to_frame FrameRate
rate = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> (Double -> Double) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* FrameRate -> Double
rate_fps FrameRate
rate)

frame_to_seconds :: FrameRate -> Frames -> Seconds
frame_to_seconds :: FrameRate -> Int -> Double
frame_to_seconds FrameRate
rate = (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ FrameRate -> Double
rate_fps FrameRate
rate) (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral

frame_to_smpte :: FrameRate -> Frames -> Smpte
frame_to_smpte :: FrameRate -> Int -> Smpte
frame_to_smpte FrameRate
rate Int
frame = Manufacturer
-> Manufacturer -> Manufacturer -> Manufacturer -> Smpte
Smpte (Int -> Manufacturer
w7 Int
hours) (Int -> Manufacturer
w7 Int
mins) (Int -> Manufacturer
w7 Int
secs) (Int -> Manufacturer
w7 Int
t3)
    where
    fps :: Int
fps = case FrameRate
rate of
        FrameRate
Frame29_97df -> Int
30
        FrameRate
_ -> Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (FrameRate -> Double
rate_fps FrameRate
rate)
    (Int
hours, Int
t1) = FrameRate -> Int -> Int
undrop_frames FrameRate
rate Int
frame Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
fps)
    (Int
mins, Int
t2) = Int
t1 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
fps)
    (Int
secs, Int
t3) = Int
t2 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
fps
    w7 :: Int -> Word7
    w7 :: Int -> Manufacturer
w7 = Int -> Manufacturer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Manufacturer) -> (Int -> Int) -> Int -> Manufacturer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
Num.clamp Int
0 Int
0x7f

seconds_to_smpte :: FrameRate -> Seconds -> Smpte
seconds_to_smpte :: FrameRate -> Double -> Smpte
seconds_to_smpte FrameRate
rate = FrameRate -> Int -> Smpte
frame_to_smpte FrameRate
rate (Int -> Smpte) -> (Double -> Int) -> Double -> Smpte
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameRate -> Double -> Int
seconds_to_frame FrameRate
rate

-- | Add dropped frames back in.  When converted back into SMPTE the effect is
-- that the dropped frames are skipped.
undrop_frames :: FrameRate -> Frames -> Frames
undrop_frames :: FrameRate -> Int -> Int
undrop_frames FrameRate
Frame29_97df Int
frames =
    Int
frames Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
frames Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
frames Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60))
undrop_frames FrameRate
_ Int
frames = Int
frames

-- | Send full MTC sync code.  This is supposed to happen every time there is
-- a time dicontinuity.
mtc_sync :: FrameRate -> Smpte -> Message
mtc_sync :: FrameRate -> Smpte -> Message
mtc_sync FrameRate
rate (Smpte Manufacturer
hours Manufacturer
mins Manufacturer
secs Manufacturer
frames) =
    ByteString -> Message
realtime_sysex (ByteString -> Message) -> ByteString -> Message
forall a b. (a -> b) -> a -> b
$ [Manufacturer] -> ByteString
ByteString.pack
        [Manufacturer
chan, Manufacturer
01, Manufacturer
01, Manufacturer
rate_code Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.|. Manufacturer
hours, Manufacturer
mins, Manufacturer
secs, Manufacturer
frames]
    where
    chan :: Manufacturer
chan = Manufacturer
0x7f -- send to all devices
    rate_code :: Manufacturer
rate_code = Manufacturer -> Int -> Manufacturer
forall a. Bits a => a -> Int -> a
Bits.shiftL (Int -> Manufacturer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FrameRate -> Int
forall a. Enum a => a -> Int
fromEnum FrameRate
rate)) Int
5
    -- TODO is chan the same as MMC DeviceId?

-- | Generate MTC starting at the given time and going on until the well of
-- time runs dry.  Or 7 bits overflow.
--
-- Since MTC can only start on a frame, the first returned time might be
-- slightly before the requested time.
--
-- One MtcQuarterFrame is transmitted per quarter frame.  Since it takes 8
-- to make a complete SMPTE frame, you wind up getting every other frame.
generate_mtc :: FrameRate -> Frames -> [(Double, Message)]
generate_mtc :: FrameRate -> Int -> [(Double, Message)]
generate_mtc FrameRate
rate Int
frame = [Double] -> [Message] -> [(Double, Message)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
times ((Int -> [Message]) -> [Int] -> [Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Message]
msgs (Int -> Int -> [Int]
forall a. Num a => a -> a -> [a]
Seq.range_ Int
frame Int
2))
    where
    -- Round up to the previous whole frame, then step forward frames and time
    -- together.  frame_to_smpte will take care of drop frame.
    msgs :: Int -> [Message]
msgs Int
frame = (Mtc -> Message) -> [Mtc] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (RealtimeMessage -> Message
RealtimeMessage (RealtimeMessage -> Message)
-> (Mtc -> RealtimeMessage) -> Mtc -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mtc -> RealtimeMessage
MtcQuarterFrame) ([Mtc] -> [Message]) -> [Mtc] -> [Message]
forall a b. (a -> b) -> a -> b
$
        FrameRate -> Smpte -> [Mtc]
mtc_fragments FrameRate
rate (FrameRate -> Int -> Smpte
frame_to_smpte FrameRate
rate Int
frame)
    times :: [Double]
times = Double -> Double -> [Double]
forall a. Num a => a -> a -> [a]
Seq.range_ Double
start Double
fragment
    start :: Double
start = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
frame Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ FrameRate -> Double
rate_fps FrameRate
rate
    fragment :: Double
fragment = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ FrameRate -> Double
rate_fps FrameRate
rate Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
4

mtc_fragments :: FrameRate -> Smpte -> [Mtc]
mtc_fragments :: FrameRate -> Smpte -> [Mtc]
mtc_fragments FrameRate
rate (Smpte Manufacturer
hours Manufacturer
minutes Manufacturer
seconds Manufacturer
frames) = ((SmpteFragment, Manufacturer) -> Mtc)
-> [(SmpteFragment, Manufacturer)] -> [Mtc]
forall a b. (a -> b) -> [a] -> [b]
map ((SmpteFragment -> Manufacturer -> Mtc)
-> (SmpteFragment, Manufacturer) -> Mtc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SmpteFragment -> Manufacturer -> Mtc
Mtc)
    [ (SmpteFragment
FrameLsb, Manufacturer
frame_lsb), (SmpteFragment
FrameMsb, Manufacturer
frame_msb)
    , (SmpteFragment
SecondLsb, Manufacturer
sec_lsb), (SmpteFragment
SecondMsb, Manufacturer
sec_msb)
    , (SmpteFragment
MinuteLsb, Manufacturer
min_lsb), (SmpteFragment
MinuteMsb, Manufacturer
min_msb)
    , (SmpteFragment
HourLsb, Manufacturer
hour_lsb), (SmpteFragment
RateHourMsb, Manufacturer
rate_code Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.|. Manufacturer
hour_msb)
    ]
    where
    (Manufacturer
frame_msb, Manufacturer
frame_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
frames
    (Manufacturer
sec_msb, Manufacturer
sec_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
seconds
    (Manufacturer
min_msb, Manufacturer
min_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
minutes
    (Manufacturer
hour_msb, Manufacturer
hour_lsb) = Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
hours
    rate_code :: Manufacturer
rate_code = Manufacturer -> Int -> Manufacturer
forall a. Bits a => a -> Int -> a
Bits.shiftL (Int -> Manufacturer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FrameRate -> Int
forall a. Enum a => a -> Int
fromEnum FrameRate
rate)) Int
1

-- * tuning

type NoteNumber = Double

-- | Create a realtime tuning msg.  Few synthesizers support this.
--
-- Based on <http://www.midi.org/techspecs/midituning.php>
realtime_tuning :: [(Key, NoteNumber)] -> Message
realtime_tuning :: [(Key, Double)] -> Message
realtime_tuning [(Key, Double)]
nns = ByteString -> Message
realtime_sysex (ByteString -> Message) -> ByteString -> Message
forall a b. (a -> b) -> a -> b
$ [Manufacturer] -> ByteString
ByteString.pack ([Manufacturer] -> ByteString) -> [Manufacturer] -> ByteString
forall a b. (a -> b) -> a -> b
$
    [Manufacturer
generic_device, Manufacturer
8, Manufacturer
2, Manufacturer
0, Int -> Manufacturer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Key, Double)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, Double)]
nns)]
        [Manufacturer] -> [Manufacturer] -> [Manufacturer]
forall a. [a] -> [a] -> [a]
++ ((Key, Double) -> [Manufacturer])
-> [(Key, Double)] -> [Manufacturer]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Key -> Double -> [Manufacturer])
-> (Key, Double) -> [Manufacturer]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Double -> [Manufacturer]
retune_key) [(Key, Double)]
nns
    where
    retune_key :: Key -> NoteNumber -> [Word7]
    retune_key :: Key -> Double -> [Manufacturer]
retune_key Key
key Double
nn = [Key -> Manufacturer
forall a. Num a => Key -> a
from_key Key
key, Manufacturer
nn_key, Manufacturer
msb, Manufacturer
lsb]
        where
        (Manufacturer
lsb, Manufacturer
msb) = Int -> (Manufacturer, Manufacturer)
split14 (Int -> (Manufacturer, Manufacturer))
-> Int -> (Manufacturer, Manufacturer)
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
frac Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
14
        (Manufacturer
nn_key, Double
frac) = Double -> (Manufacturer, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
nn

-- * util

-- | Split an Int into two 7 bit words.
split14 :: Int -> (Word7, Word7) -- ^ (LSB, MSB)
split14 :: Int -> (Manufacturer, Manufacturer)
split14 Int
i = (Int -> Manufacturer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7f), Int -> Manufacturer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bits.shiftR Int
i Int
7 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7f))

-- | Join (LSB, MSB) 7-bit words into an int.
join14 :: Word7 -> Word7 -> Int
join14 :: Manufacturer -> Manufacturer -> Int
join14 Manufacturer
lsb Manufacturer
msb =
    Int -> Int -> Int
forall a. Bits a => a -> Int -> a
Bits.shiftL (Manufacturer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Manufacturer
msb Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7f) Int
7 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Manufacturer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Manufacturer
lsb Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7f)

-- | Split a Word8 into nibbles.
split4 :: Word8 -> (Word4, Word4) -- ^ (MSB, LSB)
split4 :: Manufacturer -> (Manufacturer, Manufacturer)
split4 Manufacturer
word = (Manufacturer -> Int -> Manufacturer
forall a. Bits a => a -> Int -> a
Bits.shiftR Manufacturer
word Int
4 Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.&. Manufacturer
0xf, Manufacturer
word Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.&. Manufacturer
0xf)

-- | Join (MSB, LSB) into a Word7.
join4 :: Word4 -> Word4 -> Word7
join4 :: Manufacturer -> Manufacturer -> Manufacturer
join4 Manufacturer
d1 Manufacturer
d2 = (Manufacturer -> Int -> Manufacturer
forall a. Bits a => a -> Int -> a
Bits.shiftL Manufacturer
d1 Int
4 Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.&. Manufacturer
0xf0) Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.|. (Manufacturer
d2 Manufacturer -> Manufacturer -> Manufacturer
forall a. Bits a => a -> a -> a
.&. Manufacturer
0x0f)

-- * constants

-- | Softsynths don't care about device ID, so use this.
generic_device :: Word7
generic_device :: Manufacturer
generic_device = Manufacturer
0x7f

manufacturer_name :: Manufacturer -> Text
manufacturer_name :: Manufacturer -> Text
manufacturer_name Manufacturer
code = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe (Manufacturer -> Text
forall a. Show a => a -> Text
showt Manufacturer
code) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
    Manufacturer -> Map Manufacturer Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Manufacturer
code Map Manufacturer Text
manufacturer_codes

korg_code, yamaha_code :: Manufacturer
korg_code :: Manufacturer
korg_code = Manufacturer
0x42
yamaha_code :: Manufacturer
yamaha_code = Manufacturer
0x43

-- | TODO get a more complete list
manufacturer_codes :: Map Manufacturer Text
manufacturer_codes :: Map Manufacturer Text
manufacturer_codes = [(Manufacturer, Text)] -> Map Manufacturer Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [(Manufacturer
korg_code, Text
"korg"), (Manufacturer
yamaha_code, Text
"yamaha")]