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

-- | Test MIDI bindings, automatically and manually.
module Midi.TestMidi where
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.STM as STM
import qualified Data.ByteString as ByteString
import qualified Data.Text.IO as Text.IO
import qualified Data.Time as Time

import qualified Numeric
import qualified System.Environment
import qualified System.IO as IO

import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Test as Test

import qualified Midi.Encode
import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi
import qualified Midi.MidiDriver as MidiDriver
import qualified Midi.Mmc as Mmc

import qualified Perform.RealTime as RealTime

import           Global


type Interface = Interface.RawInterface Midi.WriteMessage

main :: IO ()
main :: IO ()
main = forall a. Initialize a
MidiDriver.initialize [Char]
"test_midi" ByteString -> Bool
want_message Either Text Interface -> IO ()
test_midi
    where
    want_message :: ByteString -> Bool
want_message =
        (forall a. Eq a => a -> a -> Bool
/= Message -> ByteString
Midi.Encode.encode (RealtimeMessage -> Message
Midi.RealtimeMessage RealtimeMessage
Midi.ActiveSense))

type ReadMsg = IO (Maybe Midi.ReadMessage)
type WriteMsg = (RealTime.RealTime, Midi.Message) -> IO ()

test_midi :: Either Text Interface -> IO ()
test_midi :: Either Text Interface -> IO ()
test_midi (Left Text
err) = forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ Text
"initializing midi: " forall a. Semigroup a => a -> a -> a
<> Text
err
test_midi (Right Interface
interface) = do
    [(ReadDevice, [ReadDevice])]
rdevs <- forall write_message.
RawInterface write_message -> IO [(ReadDevice, [ReadDevice])]
Interface.read_devices Interface
interface
    [Char] -> IO ()
putStrLn [Char]
"read devs:"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"    " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) [(ReadDevice, [ReadDevice])]
rdevs
    [(WriteDevice, [WriteDevice])]
wdevs <- forall write_message.
RawInterface write_message -> IO [(WriteDevice, [WriteDevice])]
Interface.write_devices Interface
interface
    [Char] -> IO ()
putStrLn [Char]
"write devs:"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"    " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) [(WriteDevice, [WriteDevice])]
wdevs
    [ReadDevice]
rdevs <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ReadDevice, [ReadDevice])]
rdevs

    let open :: Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open = Interface
-> Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open_devices Interface
interface
    [[Char]]
args <- IO [[Char]]
System.Environment.getArgs
    case [[Char]]
args of
        [] -> do
            [Char] -> IO ()
putStrLn [Char]
"monitoring (pass arg 'help' for help)"
            (WriteMsg
_, ReadMsg
read_msg) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [ReadDevice]
rdevs forall a. Maybe a
Nothing
            ReadMsg -> IO ()
monitor ReadMsg
read_msg
        [[Char]
"record-sysex"] -> do
            (WriteMsg
_, ReadMsg
read_msg) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [ReadDevice]
rdevs forall a. Maybe a
Nothing
            ReadMsg -> IO ()
record_sysex ReadMsg
read_msg
        [[Char]
"send-sysex", [Char]
out_dev, [Char]
fname] -> do
            (WriteMsg
write_msg, ReadMsg
_) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [] (forall a. a -> Maybe a
Just [Char]
out_dev)
            WriteMsg -> [Char] -> IO ()
send_sysex WriteMsg
write_msg [Char]
fname
        [[Char]
"help"] -> [Char] -> IO ()
putStrLn [Char]
usage
        [[Char]
"melody", [Char]
out_dev] -> do
            [Char] -> IO ()
putStrLn [Char]
"playing melody"
            (WriteMsg
write_msg, ReadMsg
_) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [] (forall a. a -> Maybe a
Just [Char]
out_dev)
            Interface -> WriteMsg -> IO ()
melody Interface
interface WriteMsg
write_msg
            [Char] -> IO ()
putStrLn [Char]
"return to quit... "
            forall (f :: * -> *) a. Functor f => f a -> f ()
void IO [Char]
getLine
        [[Char]
"melody-thru", [Char]
out_dev] -> do
            [Char] -> IO ()
putStrLn [Char]
"playing melody + thru"
            (WriteMsg
write_msg, ReadMsg
read_msg) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [ReadDevice]
rdevs (forall a. a -> Maybe a
Just [Char]
out_dev)
            Interface -> WriteMsg -> ReadMsg -> IO ()
thru_melody Interface
interface WriteMsg
write_msg ReadMsg
read_msg
        [[Char]
"mmc", [Char]
msg, [Char]
out_dev] -> do
            (WriteMsg
write_msg, ReadMsg
_) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [] (forall a. a -> Maybe a
Just [Char]
out_dev)
            WriteMsg -> [Char] -> IO ()
mmc WriteMsg
write_msg [Char]
msg
        ([Char]
"monitor" : mdevs :: [[Char]]
mdevs@([Char]
_:[[Char]]
_)) -> do
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"monitoring: " forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
", " [[Char]]
mdevs
            (WriteMsg
_, ReadMsg
read_msg) <-
                Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True (forall a b. (a -> b) -> [a] -> [b]
map (Text -> ReadDevice
Midi.read_device forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt) [[Char]]
mdevs) forall a. Maybe a
Nothing
            ReadMsg -> IO ()
monitor ReadMsg
read_msg
        [[Char]
"spam", [Char]
out_dev, [Char]
n_str] -> do
            [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"spamming " forall a. [a] -> [a] -> [a]
++ [Char]
n_str forall a. [a] -> [a] -> [a]
++ [Char]
" msgs"
            (WriteMsg
write_msg, ReadMsg
_) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [ReadDevice]
rdevs (forall a. a -> Maybe a
Just [Char]
out_dev)
            Int
n <- forall a. Read a => [Char] -> IO a
readIO [Char]
n_str
            Interface -> WriteMsg -> Int -> IO ()
spam Interface
interface WriteMsg
write_msg Int
n
            IO Char
getChar
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [[Char]
"pb-range", [Char]
out_dev, [Char]
semis] -> do
            Double
semis <- forall a. Read a => [Char] -> IO a
readIO [Char]
semis
            (WriteMsg
write_msg, ReadMsg
_) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [ReadDevice]
rdevs (forall a. a -> Maybe a
Just [Char]
out_dev)
            WriteMsg -> Double -> IO ()
pitch_bend_range WriteMsg
write_msg Double
semis
        [[Char]
"program", [Char]
out_dev] ->
            forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry WriteMsg -> ReadMsg -> IO ()
program_change forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
False [] (forall a. a -> Maybe a
Just [Char]
out_dev)
        [[Char]
"test", [Char]
loopback] -> do
            (WriteMsg
write_msg, ReadMsg
read_msg) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
False
                [Text -> ReadDevice
Midi.read_device ([Char] -> Text
txt [Char]
loopback)] (forall a. a -> Maybe a
Just [Char]
loopback)
            Interface -> WriteMsg -> ReadMsg -> IO ()
run_tests Interface
interface WriteMsg
write_msg ReadMsg
read_msg
        [[Char]
"thru", [Char]
out_dev] -> do
            [Char] -> IO ()
putStrLn [Char]
"playing thru"
            (WriteMsg
write_msg, ReadMsg
read_msg) <- Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open Bool
True [ReadDevice]
rdevs (forall a. a -> Maybe a
Just [Char]
out_dev)
            WriteMsg -> ReadMsg -> IO ()
thru_loop WriteMsg
write_msg ReadMsg
read_msg
        [[Char]]
_ -> do
            [Char] -> IO ()
putStrLn [Char]
"unknown command"
            [Char] -> IO ()
putStrLn [Char]
usage

open_devices :: Interface -> Bool -> [Midi.ReadDevice]
    -> Maybe String -> IO (WriteMsg, ReadMsg)
open_devices :: Interface
-> Bool -> [ReadDevice] -> Maybe [Char] -> IO (WriteMsg, ReadMsg)
open_devices Interface
interface Bool
blocking [ReadDevice]
rdevs Maybe [Char]
maybe_wdev = do
    [Bool]
oks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall write_message.
RawInterface write_message -> ReadDevice -> IO Bool
Interface.connect_read_device Interface
interface) [ReadDevice]
rdevs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ReadDevice
rdev | (ReadDevice
rdev, Bool
False) <- forall a b. [a] -> [b] -> [(a, b)]
zip [ReadDevice]
rdevs [Bool]
oks] forall a b. (a -> b) -> a -> b
$ \ReadDevice
missing ->
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"rdev not found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ReadDevice
missing
    let read_msg :: ReadMsg
read_msg = (if Bool
blocking then ReadChan -> ReadMsg
blocking_get else ReadChan -> ReadMsg
nonblocking_get)
            (forall write_message. RawInterface write_message -> ReadChan
Interface.read_channel Interface
interface)
    case Text -> WriteDevice
Midi.write_device forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
txt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
maybe_wdev of
        Maybe WriteDevice
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return
            (forall a b. a -> b -> a
const (forall a. Stack => [Char] -> a
error [Char]
"write device not opened"), ReadMsg
read_msg)
        Just WriteDevice
wdev -> do
            Bool
ok <- forall write_message.
RawInterface write_message -> WriteDevice -> IO Bool
Interface.connect_write_device Interface
interface WriteDevice
wdev
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$
                forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"required wdev " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show WriteDevice
wdev forall a. [a] -> [a] -> [a]
++ [Char]
" not found"
            forall (m :: * -> *) a. Monad m => a -> m a
return (Interface -> WriteDevice -> WriteMsg
make_write_msg Interface
interface WriteDevice
wdev, ReadMsg
read_msg)
    where
    make_write_msg :: Interface -> WriteDevice -> WriteMsg
make_write_msg Interface
interface WriteDevice
wdev (RealTime
ts, Message
msg) = do
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"write: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show RealTime
ts forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Message
msg
        Maybe Text
mb_err <- forall write_message.
RawInterface write_message -> write_message -> IO (Maybe Text)
Interface.write_message Interface
interface
            (WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
wdev RealTime
ts Message
msg)
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Text
mb_err forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"error: "<>)

nonblocking_get :: Interface.ReadChan -> ReadMsg
nonblocking_get :: ReadChan -> ReadMsg
nonblocking_get ReadChan
read_chan = forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. TChan a -> STM a
STM.readTChan ReadChan
read_chan) forall a. STM a -> STM a -> STM a
`STM.orElse` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

blocking_get :: Interface.ReadChan -> ReadMsg
blocking_get :: ReadChan -> ReadMsg
blocking_get ReadChan
read_chan = forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. TChan a -> STM a
STM.readTChan ReadChan
read_chan)

usage :: String
usage :: [Char]
usage =
    [Char]
"(no arg)             monitor all inputs\n\
    \record-sysex         save incoming sysex msgs to files\n\
    \send-sysex <out> fn  read a raw sysex from fn and send it to the port\n\
    \monitor <a> <b> ...  monitor input ports 'a' and 'b'\n\
    \help                 print this usage\n\
    \thru <out>           msgs from any input are relayed to <out>\n\
    \melody <out>         play a melody on <out>\n\
    \melody-thru <out>    play a melody on <out>, also relaying msgs thru\n\
    \spam <out> n         spam <out> with 'n' msgs in rapid succession\n\
    \test                 run some semi-automatic tests\n\
    \pb-range <out> n     send pitch bend range\n"


-- * program change

program_change :: WriteMsg -> ReadMsg -> IO ()
program_change :: WriteMsg -> ReadMsg -> IO ()
program_change WriteMsg
write_message ReadMsg
_read_message = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
putStr [Char]
"> "
    Handle -> IO ()
IO.hFlush Handle
IO.stdout
    [Char]
line <- IO [Char]
getLine
    let msg :: Message
msg = Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
0 forall a b. (a -> b) -> a -> b
$ Word8 -> ChannelMessage
Midi.ProgramChange (forall a. Read a => [Char] -> a
read [Char]
line)
    forall a. Show a => a -> IO ()
print Message
msg
    WriteMsg
write_message (RealTime
0, Message
msg)

-- * sysex

record_sysex :: ReadMsg -> IO ()
record_sysex :: ReadMsg -> IO ()
record_sysex ReadMsg
read_msg = forall {t} {b}. (Num t, Show t) => t -> IO b
loop Integer
0
    where
    loop :: t -> IO b
loop t
n = do
        Just (Midi.ReadMessage ReadDevice
_ RealTime
_ Message
msg) <- ReadMsg
read_msg
        Bool
wrote <- case Message
msg of
            Midi.CommonMessage (Midi.SystemExclusive Word8
manuf ByteString
bytes) -> do
                let fn :: [Char]
fn = [Char]
"record-sysex" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t
n forall a. [a] -> [a] -> [a]
++ [Char]
".syx"
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"sysex " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
untxt (forall a. (Integral a, Show a) => Int -> a -> Text
Num.hex Int
2 Word8
manuf) forall a. [a] -> [a] -> [a]
++ [Char]
" "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ByteString -> Int
ByteString.length ByteString
bytes) forall a. [a] -> [a] -> [a]
++ [Char]
" bytes -> "
                    forall a. [a] -> [a] -> [a]
++ [Char]
fn
                [Char] -> ByteString -> IO ()
ByteString.writeFile [Char]
fn (Message -> ByteString
Midi.Encode.encode Message
msg)
                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Message
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        t -> IO b
loop (if Bool
wrote then t
nforall a. Num a => a -> a -> a
+t
1 else t
n)

send_sysex :: WriteMsg -> FilePath -> IO ()
send_sysex :: WriteMsg -> [Char] -> IO ()
send_sysex WriteMsg
write_msg [Char]
fname = do
    Message
msg <- ByteString -> Message
Midi.Encode.decode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
ByteString.readFile [Char]
fname
    WriteMsg
write_msg (RealTime
0, Message
msg)
    [Char] -> IO ()
putStrLn [Char]
"sending asynchronously, hit return when the blinkenlights stop"
    [Char]
_ <- IO [Char]
getLine
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * monitor

monitor :: ReadMsg -> IO ()
monitor :: ReadMsg -> IO ()
monitor ReadMsg
read_msg = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    Just (Midi.ReadMessage ReadDevice
dev RealTime
ts Message
msg) <- ReadMsg
read_msg
    forall a. Show a => a -> IO ()
print (RealTime
ts, ReadDevice
dev, Message
msg)


-- * thru

thru_loop :: WriteMsg -> ReadMsg -> IO ()
thru_loop :: WriteMsg -> ReadMsg -> IO ()
thru_loop WriteMsg
write_msg ReadMsg
read_msg = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    Just (Midi.ReadMessage ReadDevice
dev RealTime
ts Message
msg) <- ReadMsg
read_msg
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"thru: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (RealTime
ts, ReadDevice
dev, Message
msg)
    WriteMsg
write_msg (RealTime
0, Message
msg)


-- * melody

-- | Play a melody while also allowing msgs thru, to test merging.
thru_melody :: Interface -> WriteMsg -> ReadMsg -> IO ()
thru_melody :: Interface -> WriteMsg -> ReadMsg -> IO ()
thru_melody Interface
interface WriteMsg
write_msg ReadMsg
read_msg = do
    Interface -> WriteMsg -> IO ()
melody Interface
interface WriteMsg
write_msg
    WriteMsg -> ReadMsg -> IO ()
thru_loop WriteMsg
write_msg ReadMsg
read_msg

melody :: Interface -> WriteMsg -> IO ()
melody :: Interface -> WriteMsg -> IO ()
melody Interface
interface WriteMsg
write_msg = do
    RealTime
now <- forall write_message. RawInterface write_message -> IO RealTime
Interface.now Interface
interface
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WriteMsg
write_msg (RealTime -> [(RealTime, Message)]
notes RealTime
now)

-- | Write notes over time.
notes :: RealTime.RealTime -> [(RealTime.RealTime, Midi.Message)]
notes :: RealTime -> [(RealTime, Message)]
notes RealTime
start_ts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [[(RealTime
ts, Key -> Message
note_on Key
nn), (RealTime
ts forall a. Num a => a -> a -> a
+ Double -> RealTime
RealTime.seconds Double
0.4, Key -> Message
note_off Key
nn)]
        | (RealTime
ts, Key
nn) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
start_ts (Double -> RealTime
RealTime.seconds Double
0.5)) [Key]
score]
    where score :: [Key]
score = [Key
53, Key
55 .. Key
61]

-- * mmc

mmc :: WriteMsg -> String -> IO ()
mmc :: WriteMsg -> [Char] -> IO ()
mmc WriteMsg
write_msg [Char]
msg = WriteMsg
write_msg (RealTime
0, Word8 -> Mmc -> Message
Mmc.encode Word8
127 Mmc
mmc_msg)
    where
    mmc_msg :: Mmc
mmc_msg
        | Just Smpte
smpte <- [Char] -> Maybe Smpte
parse_smpte [Char]
msg = Smpte -> Word8 -> Mmc
Mmc.Goto Smpte
smpte Word8
0
        | [Char]
msg forall a. Eq a => a -> a -> Bool
== [Char]
"play" = Mmc
Mmc.Play
        | [Char]
msg forall a. Eq a => a -> a -> Bool
== [Char]
"stop" = Mmc
Mmc.Stop
        | Bool
otherwise = forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"unknown msg: " forall a. [a] -> [a] -> [a]
++ [Char]
msg

parse_smpte :: String -> Maybe Midi.Smpte
parse_smpte :: [Char] -> Maybe Smpte
parse_smpte [Char]
txt = do
    [[Char]
h, [Char]
m, [Char]
s] <- forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split [Char]
":" [Char]
txt
    Word8 -> Word8 -> Word8 -> Word8 -> Smpte
Midi.Smpte forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. (Eq a, Num a) => [Char] -> Maybe a
int [Char]
h forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. (Eq a, Num a) => [Char] -> Maybe a
int [Char]
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a}. (Eq a, Num a) => [Char] -> Maybe a
int [Char]
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Word8
0
    where
    int :: [Char] -> Maybe a
int [Char]
s = case forall a. (Eq a, Num a) => ReadS a
Numeric.readDec [Char]
s of
        (a
n, [Char]
"") : [(a, [Char])]
_ -> forall a. a -> Maybe a
Just a
n
        [(a, [Char])]
_ -> forall a. Maybe a
Nothing


-- * spam

spam :: Interface -> WriteMsg -> Int -> IO ()
spam :: Interface -> WriteMsg -> Int -> IO ()
spam Interface
interface WriteMsg
write_msg Int
n = do
    RealTime
now <- forall write_message. RawInterface write_message -> IO RealTime
Interface.now Interface
interface
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WriteMsg
write_msg [(RealTime
now forall a. Num a => a -> a -> a
+ Integer -> RealTime
RealTime.milliseconds (Integer
iforall a. Num a => a -> a -> a
*Integer
10), Message
msg)
        | (Integer
i, Message
msg) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Message]
msgs]
    where
    msgs :: [Message]
msgs = forall a. Int -> [a] -> [a]
take Int
n [Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
0 ChannelMessage
msg | Key
nn <- forall a. [a] -> [a]
cycle [Key
0..Key
127],
        ChannelMessage
msg <- [Key -> Word8 -> ChannelMessage
Midi.NoteOn Key
nn Word8
127, Key -> Word8 -> ChannelMessage
Midi.NoteOff Key
nn Word8
127]]

-- * pitch bend range

pitch_bend_range :: WriteMsg -> Double -> IO ()
pitch_bend_range :: WriteMsg -> Double -> IO ()
pitch_bend_range WriteMsg
write_msg Double
semis = do
    let msgs :: [Message]
msgs = forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
0) (Double -> [ChannelMessage]
Midi.pitch_bend_range Double
semis)
    forall a. Show a => a -> IO ()
Test.pprint [Message]
msgs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WriteMsg
write_msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) RealTime
0) [Message]
msgs

-- * tests

-- | Test a few things by writing and reading both ends of the same port.
run_tests :: Interface -> WriteMsg -> ReadMsg -> IO ()
run_tests :: Interface -> WriteMsg -> ReadMsg -> IO ()
run_tests Interface
interface WriteMsg
write_msg ReadMsg
read_msg = do
    [Char] -> IO ()
putStrLn [Char]
"---- abort"
    Interface -> WriteMsg -> ReadMsg -> IO ()
test_abort Interface
interface WriteMsg
write_msg ReadMsg
read_msg
    [Char] -> IO ()
putStrLn [Char]
"---- merge"
    Interface -> WriteMsg -> ReadMsg -> IO ()
test_merge Interface
interface WriteMsg
write_msg ReadMsg
read_msg
    [Char] -> IO ()
putStrLn [Char]
"---- sysex"
    WriteMsg -> ReadMsg -> IO ()
test_sysex WriteMsg
write_msg ReadMsg
read_msg

-- | Ensure that aborts really cancel pending msgs.
test_abort :: Interface -> WriteMsg -> ReadMsg -> IO ()
test_abort :: Interface -> WriteMsg -> ReadMsg -> IO ()
test_abort Interface
interface WriteMsg
write_msg ReadMsg
read_msg = do
    RealTime
now <- forall write_message. RawInterface write_message -> IO RealTime
Interface.now Interface
interface
    let msgs :: [Message]
msgs = [Key -> Message
note_on Key
10, Key -> Message
note_on Key
20, ChannelMessage -> Message
chan_msg (PitchBendValue -> ChannelMessage
Midi.PitchBend PitchBendValue
42)]
    -- Msgs start from now + 0.5 so the abort should cancel all of them.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WriteMsg
write_msg [(RealTime
now forall a. Num a => a -> a -> a
+ Double -> RealTime
RealTime.seconds (Double
i forall a. Num a => a -> a -> a
* Double
0.5), Message
msg)
        | (Double
i, Message
msg) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Double
5..] [Message]
msgs]
    Double -> IO ()
sleep Double
0.2
    forall write_message. RawInterface write_message -> IO ()
Interface.abort Interface
interface
    Double -> IO ()
sleep Double
1
    [ReadMessage]
msgs <- ReadMsg -> IO [ReadMessage]
read_all ReadMsg
read_msg
    -- OS X used to have a bug that emitted weird pitchbend after an abort.
    -- It's been fixed but now it emits pb0, presumably because they can't
    -- be totally sure a pitchbend hasn't been emitted when the abort is
    -- received.
    forall a. (Stack, Show a, Eq a) => a -> a -> IO ()
Test.equal (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadMessage -> Bool
is_pb0) [ReadMessage]
msgs) []
    [Char] -> IO ()
putStrLn [Char]
"msgs after abort (pitchbend 0 expected on CoreMIDI):"
    forall a. Show a => a -> IO ()
Test.pprint [ReadMessage]
msgs
    where
    is_pb0 :: ReadMessage -> Bool
is_pb0 ReadMessage
msg = case ReadMessage -> Message
Midi.rmsg_msg ReadMessage
msg of
        Midi.ChannelMessage Word8
_ (Midi.PitchBend PitchBendValue
0) -> Bool
True
        Message
_ -> Bool
False

-- | Ensure that timestamp 0 msgs get merged in ahead of timed msgs, as per
-- 'Interface.write_message'.
test_merge :: Interface -> WriteMsg -> ReadMsg -> IO ()
test_merge :: Interface -> WriteMsg -> ReadMsg -> IO ()
test_merge Interface
interface WriteMsg
write_msg ReadMsg
read_msg = do
    RealTime
now <- forall write_message. RawInterface write_message -> IO RealTime
Interface.now Interface
interface
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WriteMsg
write_msg
        [ (RealTime
now, Key -> Message
note_on Key
10)
        , (RealTime
now forall a. Num a => a -> a -> a
+ Double -> RealTime
RealTime.seconds Double
0.25, Key -> Message
note_on Key
11)
        , (RealTime
now forall a. Num a => a -> a -> a
+ Double -> RealTime
RealTime.seconds Double
0.5, Key -> Message
note_on Key
12)
        ]
    Double -> IO ()
sleep Double
0.1
    WriteMsg
write_msg (RealTime
0, Key -> Message
note_on Key
100)
    Double -> IO ()
sleep Double
1
    [ReadMessage]
msgs <- ReadMsg -> IO [ReadMessage]
read_all ReadMsg
read_msg
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. (Stack, Show a, Eq a) => a -> a -> IO ()
Test.equal (forall a b. (a -> b) -> [a] -> [b]
map ReadMessage -> Message
Midi.rmsg_msg [ReadMessage]
msgs)
        [Key -> Message
note_on Key
10, Key -> Message
note_on Key
100, Key -> Message
note_on Key
11, Key -> Message
note_on Key
12]

test_sysex :: WriteMsg -> ReadMsg -> IO ()
test_sysex :: WriteMsg -> ReadMsg -> IO ()
test_sysex WriteMsg
write_msg ReadMsg
read_msg = do
    let size :: Int
size = Int
20
    let msg :: Message
msg = CommonMessage -> Message
Midi.CommonMessage forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> CommonMessage
Midi.SystemExclusive Word8
42
            ([Word8] -> ByteString
ByteString.pack (forall a. Int -> [a] -> [a]
take (Int
sizeforall a. Num a => a -> a -> a
*Int
1024) (forall a. [a] -> [a]
cycle [Word8
0..Word8
9]) forall a. [a] -> [a] -> [a]
++ [Word8
0xf7]))
    WriteMsg
write_msg (RealTime
0, Message
msg)
    [Char] -> IO ()
putStrLn [Char]
"waiting for sysex to arrive..."
    Maybe (ReadMessage, NominalDiffTime)
result <- NominalDiffTime
-> ReadMsg -> IO (Maybe (ReadMessage, NominalDiffTime))
read_until NominalDiffTime
10 ReadMsg
read_msg
    (ReadMessage
out, NominalDiffTime
secs) <- case Maybe (ReadMessage, NominalDiffTime)
result of
        Maybe (ReadMessage, NominalDiffTime)
Nothing -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"no sysex arrived!"
        Just (ReadMessage, NominalDiffTime)
val -> forall (m :: * -> *) a. Monad m => a -> m a
return (ReadMessage, NominalDiffTime)
val
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NominalDiffTime
secs forall a. [a] -> [a] -> [a]
++ [Char]
" seconds for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
size forall a. [a] -> [a] -> [a]
++ [Char]
" bytes"
    let out_msg :: Message
out_msg = ReadMessage -> Message
Midi.rmsg_msg ReadMessage
out
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ if Message
out_msg forall a. Eq a => a -> a -> Bool
== Message
msg
        then Stack => Text -> IO ()
Test.success Text
"sysex equal"
        else Stack => Text -> IO ()
Test.failure forall a b. (a -> b) -> a -> b
$ Text
"got sysex: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Message
out_msg


-- * util

chan_msg :: ChannelMessage -> Message
chan_msg = Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
0
note_on :: Key -> Message
note_on Key
nn = ChannelMessage -> Message
chan_msg (Key -> Word8 -> ChannelMessage
Midi.NoteOn Key
nn Word8
70)
note_off :: Key -> Message
note_off Key
nn = ChannelMessage -> Message
chan_msg (Key -> Word8 -> ChannelMessage
Midi.NoteOff Key
nn Word8
70)

sleep :: Double -> IO ()
sleep :: Double -> IO ()
sleep = Int -> IO ()
Concurrent.threadDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Double
1000000)

read_until :: Time.NominalDiffTime -> ReadMsg
    -> IO (Maybe (Midi.ReadMessage, Time.NominalDiffTime))
read_until :: NominalDiffTime
-> ReadMsg -> IO (Maybe (ReadMessage, NominalDiffTime))
read_until NominalDiffTime
timeout ReadMsg
read_msg = do
    UTCTime
started <- IO UTCTime
Time.getCurrentTime
    let abort_at :: UTCTime
abort_at = NominalDiffTime
timeout NominalDiffTime -> UTCTime -> UTCTime
`Time.addUTCTime` UTCTime
started
    let go :: IO (Maybe (ReadMessage, NominalDiffTime))
go = do
            Maybe ReadMessage
msg <- ReadMsg
read_msg
            UTCTime
now <- IO UTCTime
Time.getCurrentTime
            case Maybe ReadMessage
msg of
                Just ReadMessage
m -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (ReadMessage
m, UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`Time.diffUTCTime` UTCTime
started))
                Maybe ReadMessage
Nothing -> do
                    if UTCTime
now forall a. Ord a => a -> a -> Bool
> UTCTime
abort_at
                        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        else Double -> IO ()
sleep Double
0.25 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe (ReadMessage, NominalDiffTime))
go
    IO (Maybe (ReadMessage, NominalDiffTime))
go

read_all :: ReadMsg -> IO [Midi.ReadMessage]
read_all :: ReadMsg -> IO [ReadMessage]
read_all ReadMsg
read_msg = do
    Maybe ReadMessage
msg <- ReadMsg
read_msg
    case Maybe ReadMessage
msg of
        Just ReadMessage
m -> do
            [ReadMessage]
rest <- ReadMsg -> IO [ReadMessage]
read_all ReadMsg
read_msg
            forall (m :: * -> *) a. Monad m => a -> m a
return (ReadMessage
mforall a. a -> [a] -> [a]
:[ReadMessage]
rest)
        Maybe ReadMessage
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []