{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Main where
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as B
import qualified Data.Attoparsec.ByteString as A
import Data.ByteString.Lazy (toStrict)
import Data.Word
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.Hspec
import Test.Hspec.Attoparsec
import Sound.MIDI
import Sound.MIDI.Types
import qualified Sound.MIDI.Serialize as S
import qualified Sound.MIDI.Parser as P
main :: IO ()
main = do
st <- specTests
defaultMain (testGroup "Tests" [ tests, st ])
tests :: TestTree
tests = testGroup "QuickCheck"
[ testProperty "word14: parse . serialize == id" $
\(w16 :: Word16) ->
let w14 = to14Bit w16
w14' = A.parseOnly P.anyWord14 . toStrict . B.toLazyByteString
. S.word14 $ w14
in Right w14 == w14'
, testProperty "parse . serialize == id" $
\(msg :: MidiMessage) ->
decodeMidi1 (encodeMidi1' msg) == Right msg
, testProperty "parse . serialize == id (long)" $
\(msg :: NonEmptyList MidiMessage) ->
let msg' = getNonEmpty msg
in fmap mergeEOX (decodeMidi (encodeMidi' msg')) == Right msg'
]
-- | The parser will separate EOXs by design, hence they need to be merged back
-- into the exclusive message during property testing.
mergeEOX :: [MidiMessage] -> [MidiMessage]
mergeEOX [] = []
mergeEOX (x@(SystemExclusive _) : SystemCommon EOX : xs) = x : mergeEOX xs
mergeEOX (x:xs) = x : mergeEOX xs
specTests :: IO TestTree
specTests = testSpec "Hspec" . sequence_ . map go $ specCases
where go (SC n msg str) =
describe n $ do
it "parses" $ decodeMidi1 str `shouldParse` msg
it "serializes" $ encodeMidi1' msg `shouldBe` str
data SpecCase = SC String MidiMessage B.ByteString
specCases :: [SpecCase]
specCases =
[ -- Channel Voice tests
SC "Note Off"
(ChannelVoice (NoteOff (Channel 0) (Pitch 60) (Velocity 127)))
"\x80\x3c\x7f"
, SC "Note On"
(ChannelVoice (NoteOn (Channel 0) (Pitch 60) (Velocity 0)))
"\x90\x3c\x00"
, SC "Aftertouch"
(ChannelVoice (Aftertouch (Channel 1) (Pitch 0) (Touch 64)))
"\xa1\x00\x40"
, SC "Control Change"
(ChannelVoice (ControlChange (Channel 0) (Controller 4) (to7Bit 0)))
"\xb0\x04\x00"
, SC "Patch Change"
(ChannelVoice (PatchChange (Channel 4) (Patch 8)))
"\xc4\x08"
, SC "Channel Pressure"
(ChannelVoice (ChannelPressure (Channel 4) (Touch 64)))
"\xd4\x40"
, SC "Pitch Bend"
(ChannelVoice (PitchBend (Channel 0) (to14Bit 8)))
"\xe0\x08\x00"
-- Channel Mode test
, SC "All Sound Off"
(ChannelMode (AllSoundOff (Channel 0)))
"\xb0\x78\x00"
, SC "Reset Controllers"
(ChannelMode (ResetAllControllers (Channel 0)))
"\xb0\x79\x00"
, SC "LocalControl True"
(ChannelMode (LocalControl (Channel 1) True))
"\xb1\x7a\x7f"
, SC "LocalControl False"
(ChannelMode (LocalControl (Channel 1) False))
"\xb1\x7a\x00"
, SC "All Notes Off"
(ChannelMode (AllNotesOff (Channel 0)))
"\xb0\x7b\x00"
, SC "Omni Off"
(ChannelMode (OmniOff (Channel 0)))
"\xb0\x7c\x00"
, SC "Omni On"
(ChannelMode (OmniOn (Channel 0)))
"\xb0\x7d\x00"
, SC "Mono On"
(ChannelMode (MonoOn (Channel 0) (to7Bit 3)))
"\xb0\x7e\x03"
, SC "Poly On"
(ChannelMode (PolyOn (Channel 0)))
"\xb0\x7f\x00"
-- System Common
, SC "MTC Quarter"
(SystemCommon (MTCQuarter (to7Bit 0)))
"\xf1\x00"
, SC "Song Position"
(SystemCommon (SongPosition (mkPositionPointer 8)))
"\xf2\x08\x00"
, SC "Song Select"
(SystemCommon (SongSelect (to7Bit 0)))
"\xf3\x00"
, SC "Tune Request"
(SystemCommon TuneRequest)
"\xf6"
, SC "EOX"
(SystemCommon EOX)
"\xf7"
-- System Real Time
, SC "Timing Clock"
(SystemRealTime TimingClock)
"\xf8"
, SC "Start"
(SystemRealTime Start)
"\xfa"
, SC "Continue"
(SystemRealTime Continue)
"\xfb"
, SC "Stop"
(SystemRealTime Stop)
"\xfc"
, SC "Active Sensing"
(SystemRealTime ActiveSensing)
"\xfe"
, SC "System Reset"
(SystemRealTime SystemReset)
"\xff"
-- System Exclusive
, SC "System Exclusive, short vendor"
(SystemExclusive (Exclusive (VendorIdShort (to7Bit 8)) "000"))
"\xf0\x08\x30\x30\x30\xf7"
, SC "System Exclusive, long vendor"
(SystemExclusive (Exclusive (VendorIdLong (to7Bit 8) (to7Bit 8)) "000"))
"\xf0\x00\x08\x08\x30\x30\x30\xf7"
]
{- Arbitrary instances for MidiMessage -}
instance Arbitrary MidiMessage where
arbitrary = oneof [ ChannelVoice <$> arbitrary
, ChannelMode <$> arbitrary
, SystemCommon <$> arbitrary
, SystemRealTime <$> arbitrary
, SystemExclusive <$> arbitrary ]
instance Arbitrary ChannelVoice where
arbitrary = oneof [ NoteOff <$> arbitrary <*> arbitrary <*> arbitrary
, NoteOn <$> arbitrary <*> arbitrary <*> arbitrary
, Aftertouch <$> arbitrary <*> arbitrary <*> arbitrary
, ControlChange <$> arbitrary <*> arbitrary
<*> (to7Bit <$> (arbitrary :: Gen Word8))
, PatchChange <$> arbitrary <*> arbitrary
, ChannelPressure <$> arbitrary <*> arbitrary
, PitchBend <$> arbitrary <*>
(to14Bit <$> (arbitrary :: Gen Word16)) ]
instance Arbitrary ChannelMode where
arbitrary = oneof [ AllSoundOff <$> arbitrary
, ResetAllControllers <$> arbitrary
, LocalControl <$> arbitrary <*> arbitrary
, AllNotesOff <$> arbitrary
, OmniOff <$> arbitrary
, OmniOn <$> arbitrary
, MonoOn <$> arbitrary
<*> (to7Bit <$> (arbitrary :: Gen Word8))
, PolyOn <$> arbitrary ]
instance Arbitrary SystemCommon where
arbitrary = oneof [ MTCQuarter <$> (to7Bit <$> (arbitrary :: Gen Word8))
, SongPosition <$> arbitrary
, SongSelect <$> (to7Bit <$> (arbitrary :: Gen Word8))
, pure TuneRequest
, pure EOX ]
instance Arbitrary SystemExclusive where
arbitrary = Exclusive <$> arbitrary <*>
(B.pack . map to7Bit . getNonEmpty
<$> (arbitrary :: Gen (NonEmptyList Word8)))
instance Arbitrary SystemRealTime where
arbitrary = elements [ TimingClock, Start, Continue, Stop
, ActiveSensing, SystemReset ]
instance Arbitrary VendorId where
arbitrary = oneof [ VendorIdShort <$> (to7Bit' <$> (arbitrary :: Gen Word8))
, VendorIdLong <$> (to7Bit <$> (arbitrary :: Gen Word8))
<*> (to7Bit' <$> (arbitrary :: Gen Word8))
]
where to7Bit' x = if to7Bit x == 0 then 1 else to7Bit x
instance Arbitrary Channel where
arbitrary = mkChannel <$> (arbitrary :: Gen Word8)
instance Arbitrary Pitch where
arbitrary = mkPitch <$> (arbitrary :: Gen Word8)
instance Arbitrary Velocity where
arbitrary = mkVelocity <$> (arbitrary :: Gen Word8)
instance Arbitrary Touch where
arbitrary = mkTouch <$> (arbitrary :: Gen Word8)
instance Arbitrary Controller where
arbitrary = do
x <- to7Bit <$> (arbitrary :: Gen Word8)
let x' = if x >= 0x78 && x <= 0x7F
then 0x00
else x
pure $ mkController x'
instance Arbitrary Patch where
arbitrary = mkPatch <$> (arbitrary :: Gen Word8)
instance Arbitrary PositionPointer where
arbitrary = mkPositionPointer <$> (arbitrary :: Gen Word16)