-- 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

module Midi.Encode (decode, encode, sox_byte, eox_byte) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as Unsafe
import Data.Word (Word8)

import Midi.Midi


type Word7 = Word8

decode :: B.ByteString -> Message
decode :: ByteString -> Message
decode ByteString
bytes = case ByteString -> Int
B.length ByteString
bytes of
        Int
0 -> Word7 -> Word7 -> Word7 -> Message
UnknownMessage Word7
0 Word7
0 Word7
0
        Int
1 -> Word7 -> Word7 -> Word7 -> ByteString -> Message
decode3 Word7
b0 Word7
0 Word7
0 ByteString
bytes
        Int
2 -> Word7 -> Word7 -> Word7 -> ByteString -> Message
decode3 Word7
b0 Word7
b1 Word7
0 ByteString
bytes
        Int
_ -> Word7 -> Word7 -> Word7 -> ByteString -> Message
decode3 Word7
b0 Word7
b1 Word7
b2 ByteString
bytes
    where
    b0 :: Word7
b0 = ByteString -> Int -> Word7
Unsafe.unsafeIndex ByteString
bytes Int
0
    b1 :: Word7
b1 = ByteString -> Int -> Word7
Unsafe.unsafeIndex ByteString
bytes Int
1
    b2 :: Word7
b2 = ByteString -> Int -> Word7
Unsafe.unsafeIndex ByteString
bytes Int
2

decode3 :: Word8 -> Word8 -> Word8 -> B.ByteString -> Message
decode3 :: Word7 -> Word7 -> Word7 -> ByteString -> Message
decode3 Word7
status Word7
d1 Word7
d2 ByteString
bytes
    | Word7
st forall a. Eq a => a -> a -> Bool
== Word7
0xf Bool -> Bool -> Bool
&& Word7
chan forall a. Ord a => a -> a -> Bool
< Word7
0x8 = CommonMessage -> Message
CommonMessage CommonMessage
common_msg
    | Word7
st forall a. Eq a => a -> a -> Bool
== Word7
0xf = RealtimeMessage -> Message
RealtimeMessage (Word7 -> RealtimeMessage
realtime_msg Word7
d1)
    | Word7
st forall a. Eq a => a -> a -> Bool
== Word7
0xb Bool -> Bool -> Bool
&& Word7
d1 forall a. Ord a => a -> a -> Bool
>= Word7
0x78 = Word7 -> ChannelMessage -> Message
ChannelMessage Word7
chan ChannelMessage
channel_mode_msg
    | Word7
st forall a. Ord a => a -> a -> Bool
>= Word7
0x8 = Word7 -> ChannelMessage -> Message
ChannelMessage Word7
chan ChannelMessage
channel_msg
    | Bool
otherwise = Word7 -> Word7 -> Word7 -> Message
UnknownMessage Word7
status Word7
d1 Word7
d2
    where
    (Word7
st, Word7
chan) = Word7 -> (Word7, Word7)
split4 Word7
status
    channel_msg :: ChannelMessage
channel_msg = case Word7
st of
        Word7
0x8 -> Key -> Word7 -> ChannelMessage
NoteOff (forall a. Integral a => a -> Key
to_key Word7
d1) Word7
d2
            -- Hide this bit of midi irregularity from clients.
        Word7
0x9 | Word7
d2 forall a. Eq a => a -> a -> Bool
== Word7
0 -> Key -> Word7 -> ChannelMessage
NoteOff (forall a. Integral a => a -> Key
to_key Word7
d1) Word7
d2
            | Bool
otherwise -> Key -> Word7 -> ChannelMessage
NoteOn (forall a. Integral a => a -> Key
to_key Word7
d1) Word7
d2
        Word7
0xa -> Key -> Word7 -> ChannelMessage
Aftertouch (forall a. Integral a => a -> Key
to_key Word7
d1) Word7
d2
        Word7
0xb -> Word7 -> Word7 -> ChannelMessage
ControlChange Word7
d1 Word7
d2
        Word7
0xc -> Word7 -> ChannelMessage
ProgramChange Word7
d1
        Word7
0xd -> Word7 -> ChannelMessage
ChannelPressure Word7
d1
        Word7
0xe -> PitchBendValue -> ChannelMessage
PitchBend (Word7 -> Word7 -> PitchBendValue
decode_pb Word7
d1 Word7
d2)
        Word7
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Midi decode: not reached: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word7
st
    channel_mode_msg :: ChannelMessage
channel_mode_msg = case Word7
d1 of
        Word7
0x78 -> ChannelMessage
AllSoundOff
        Word7
0x79 -> ChannelMessage
ResetAllControls
        Word7
0x7a -> Bool -> ChannelMessage
LocalControl (Word7
d2 forall a. Eq a => a -> a -> Bool
/= Word7
0)
        Word7
0x7b -> ChannelMessage
AllNotesOff
        Word7
_ -> Word7 -> Word7 -> ChannelMessage
UndefinedChannelMode Word7
d1 Word7
d2
    common_msg :: CommonMessage
common_msg = case Word7
chan of
        Word7
0x0 -> Word7 -> ByteString -> CommonMessage
SystemExclusive Word7
d1 forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
2 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
drop_eox ByteString
bytes
        Word7
0x2 -> Int -> CommonMessage
SongPositionPointer (Word7 -> Word7 -> Int
join14 Word7
d1 Word7
d2)
        Word7
0x3 -> Word7 -> CommonMessage
SongSelect Word7
d1
        Word7
0x6 -> CommonMessage
TuneRequest
        Word7
0x7 -> CommonMessage
EOX -- this shouldn't happen by itself
        Word7
_ -> Word7 -> CommonMessage
UndefinedCommon Word7
chan
    drop_eox :: ByteString -> ByteString
drop_eox ByteString
bytes
        | Bool -> Bool
not (ByteString -> Bool
B.null ByteString
bytes) Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word7
B.last ByteString
bytes forall a. Eq a => a -> a -> Bool
== Word7
eox_byte =
            Int -> ByteString -> ByteString
B.take (ByteString -> Int
B.length ByteString
bytes forall a. Num a => a -> a -> a
- Int
1) ByteString
bytes
        | Bool
otherwise = ByteString
bytes
    realtime_msg :: Word7 -> RealtimeMessage
realtime_msg Word7
byte = case Word7
chan of
        Word7
0x1 -> Mtc -> RealtimeMessage
MtcQuarterFrame (Word7 -> Mtc
decode_mtc Word7
byte)
        Word7
0x8 -> RealtimeMessage
TimingClock
        Word7
0xa -> RealtimeMessage
Start
        Word7
0xb -> RealtimeMessage
Continue
        Word7
0xc -> RealtimeMessage
Stop
        Word7
0xe -> RealtimeMessage
ActiveSense
        Word7
0xf -> RealtimeMessage
Reset
        Word7
_ -> Word7 -> RealtimeMessage
UndefinedRealtime Word7
chan

encode :: Message -> B.ByteString
encode :: Message -> ByteString
encode (ChannelMessage Word7
chan ChannelMessage
msg) = [Word7] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ [Word7] -> [Word7]
join1 forall a b. (a -> b) -> a -> b
$ case ChannelMessage
msg of
        NoteOff Key
key Word7
v -> [Word7
0x8, Key -> Word7
encode_key Key
key, Word7
v]
        NoteOn Key
key Word7
v -> [Word7
0x9, Key -> Word7
encode_key Key
key, Word7
v]
        Aftertouch Key
key Word7
v -> [Word7
0xa, Key -> Word7
encode_key Key
key, Word7
v]
        ControlChange Word7
c Word7
v -> [Word7
0xb, Word7
c, Word7
v]
        ProgramChange Word7
v -> [Word7
0xc, Word7
v]
        ChannelPressure Word7
v -> [Word7
0xd, Word7
v]
        PitchBend PitchBendValue
v -> let (Word7
d1, Word7
d2) = PitchBendValue -> (Word7, Word7)
encode_pb PitchBendValue
v in [Word7
0xe, Word7
d1, Word7
d2]
        PitchBendInt Word7
d1 Word7
d2 -> [Word7
0xe, Word7
d1, Word7
d2]
        -- channel mode msgs
        ChannelMessage
AllSoundOff -> [Word7
0xb, Word7
0x78, Word7
0]
        ChannelMessage
ResetAllControls -> [Word7
0xb, Word7
0x79, Word7
0]
        LocalControl Bool
on -> [Word7
0xb, Word7
0x7a, if Bool
on then Word7
0xff else Word7
0]
        ChannelMessage
AllNotesOff -> [Word7
0xb, Word7
0x7b, Word7
0]
        UndefinedChannelMode Word7
d1 Word7
d2 -> [Word7
0xb, Word7
d1, Word7
d2]
    where
    join1 :: [Word7] -> [Word7]
join1 (Word7
b:[Word7]
bs) = Word7 -> Word7 -> Word7
join4 Word7
b Word7
chan forall a. a -> [a] -> [a]
: [Word7]
bs
    join1 [] = []

encode (RealtimeMessage (MtcQuarterFrame Mtc
timing)) =
    [Word7] -> ByteString
B.pack [Word7
0xf1, Mtc -> Word7
encode_mtc Mtc
timing]
encode (RealtimeMessage RealtimeMessage
msg) = [Word7] -> ByteString
B.pack [Word7 -> Word7 -> Word7
join4 Word7
0xf Word7
st]
    where
    st :: Word7
st = case RealtimeMessage
msg of
        RealtimeMessage
TimingClock -> Word7
0x8
        RealtimeMessage
Start -> Word7
0xa
        RealtimeMessage
Continue -> Word7
0xb
        RealtimeMessage
Stop -> Word7
0xc
        RealtimeMessage
ActiveSense -> Word7
0xe
        RealtimeMessage
Reset -> Word7
0xf
        UndefinedRealtime Word7
_ ->
            forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Midi encode: unknown RealtimeMessage " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RealtimeMessage
msg

encode (CommonMessage CommonMessage
msg) = case CommonMessage
msg of
    SystemExclusive Word7
manuf ByteString
bytes ->
        [Word7] -> ByteString
B.pack [Word7
sox_byte, Word7
manuf] forall a. Semigroup a => a -> a -> a
<> ByteString
bytes forall a. Semigroup a => a -> a -> a
<> [Word7] -> ByteString
B.pack [Word7
eox_byte]
    SongPositionPointer Int
d ->
        let (Word7
d1, Word7
d2) = Int -> (Word7, Word7)
split14 Int
d in [Word7] -> ByteString
B.pack [Word7
0xf2, Word7
d1, Word7
d2]
    SongSelect Word7
d -> [Word7] -> ByteString
B.pack [Word7
0xf3, Word7
d]
    CommonMessage
TuneRequest -> [Word7] -> ByteString
B.pack [Word7
0xf6]
    CommonMessage
EOX -> [Word7] -> ByteString
B.pack [Word7
eox_byte] -- this should have been in SystemExclusive
    CommonMessage
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Midi encode: unknown CommonMessage " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show CommonMessage
msg

encode (UnknownMessage Word7
st Word7
d1 Word7
d2) =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Midi encode: UnknownMessage: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Word7
st, Word7
d1, Word7
d2)

sox_byte, eox_byte :: Word7
sox_byte :: Word7
sox_byte = Word7
0xf0
eox_byte :: Word7
eox_byte = Word7
0xf7

-- * util

decode_mtc :: Word7 -> Mtc
decode_mtc :: Word7 -> Mtc
decode_mtc Word7
byte = SmpteFragment -> Word7 -> Mtc
Mtc (forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word7
frag)) Word7
val
    where (Word7
frag, Word7
val) = Word7 -> (Word7, Word7)
split4 Word7
byte

encode_mtc :: Mtc -> Word7
encode_mtc :: Mtc -> Word7
encode_mtc (Mtc SmpteFragment
frag Word7
val) = Word7 -> Word7 -> Word7
join4 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum SmpteFragment
frag)) Word7
val

-- | I map a 2s complement range to inclusive -1--1, so this is a little
-- tricky.
decode_pb :: Word7 -> Word7 -> PitchBendValue
decode_pb :: Word7 -> Word7 -> PitchBendValue
decode_pb Word7
d1 Word7
d2
    | PitchBendValue
v forall a. Ord a => a -> a -> Bool
< PitchBendValue
0x2000 = (PitchBendValue
v forall a. Num a => a -> a -> a
- PitchBendValue
0x2000) forall a. Fractional a => a -> a -> a
/ PitchBendValue
0x2000
    | Bool
otherwise = (PitchBendValue
v forall a. Num a => a -> a -> a
- PitchBendValue
0x2000) forall a. Fractional a => a -> a -> a
/ (PitchBendValue
0x2000forall a. Num a => a -> a -> a
-PitchBendValue
1)
    where v :: PitchBendValue
v = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word7 -> Word7 -> Int
join14 Word7
d1 Word7
d2)

encode_pb :: PitchBendValue -> (Word7, Word7)
encode_pb :: PitchBendValue -> (Word7, Word7)
encode_pb PitchBendValue
v = Int -> (Word7, Word7)
split14 (forall a b. (RealFrac a, Integral b) => a -> b
floor (PitchBendValue
vforall a. Num a => a -> a -> a
*PitchBendValue
m forall a. Num a => a -> a -> a
+ PitchBendValue
0x2000))
    where m :: PitchBendValue
m = if PitchBendValue
v forall a. Ord a => a -> a -> Bool
< PitchBendValue
0 then PitchBendValue
0x2000 else PitchBendValue
0x2000 forall a. Num a => a -> a -> a
- PitchBendValue
1

encode_key :: Key -> Word7
encode_key :: Key -> Word7
encode_key = forall a. Num a => Key -> a
from_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Key
127 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Key
0