diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/README.rst b/README.rst new file mode 100644 --- /dev/null +++ b/README.rst @@ -0,0 +1,28 @@ +midi-simple +=========== + +A simple and minimal MIDI library for Haskell, written with real-time +applications in mind. It provides fast decoding and encoding of (normalized) +MIDI messages as output by e.g. JACK. + +Currently, the MIDI 1.0 specification is supported. No extensions (e.g. General +MIDI) are implemented at the moment, but may be added in the future. + +In particular, timing information, relative or absolute, is out of scope for +this project, as it messages are timed in the way they arrive in a real-time +setting. There are currently also no plans to support MIDI files, although this +library can be used as a base for building support for such a use case. + +Usage +~~~~~ + +Most intended use cases should be covered by the `Sound.MIDI` module. The +modules `Sound.MIDI.Parser` and `Sound.MIDI.Serialize` export the innards of the +parser/serializer respectively for when they are needed. + +Performance +~~~~~~~~~~~ + +In my benchmarks, the library has proven to be sufficient for real-time use. +Parsing of common MIDI events such as Note On/Off or Pitch Bend runs at around +50-60ns per event. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Sound.MIDI +import Sound.MIDI.Types +import Criterion.Main +import Data.ByteString (ByteString) + +pchannelVoice, ppitchBend, pmonoOn, pexclusive :: ByteString +pchannelVoice = "\x80\x3c\x7f" +ppitchBend = "\xe0\x08\x00" +pmonoOn = "\xb0\x7e\x03" +pexclusive = "\xf0\x00\x08\x08\x30\x30\x30\xf7" + +pmulti :: ByteString +pmulti = "\x80\x3c\x7f\xf0\x00\x08\x08\x30\x30\x30\xf7\xe0\x08\x00\xb0\x7e\x03" + +schannelVoice, spitchBend, smonoOn, sexclusive :: MidiMessage +schannelVoice = ChannelVoice (NoteOff (Channel 0) (Pitch 60) (Velocity 127)) +spitchBend = ChannelVoice (PitchBend (Channel 0) (to14Bit 8)) +smonoOn = ChannelMode (MonoOn (Channel 0) (to7Bit 3)) +sexclusive = + SystemExclusive (Exclusive (VendorIdLong (to7Bit 8) (to7Bit 8)) "000") + +smulti = [ schannelVoice, spitchBend, smonoOn, sexclusive ] + +main :: IO () +main = defaultMain + [ bgroup "parsing" + [ bench "channelVoice" $ whnf decodeMidi1 pchannelVoice + , bench "pitchBend" $ whnf decodeMidi1 ppitchBend + , bench "monoOn" $ whnf decodeMidi1 pmonoOn + , bench "exclusive" $ whnf decodeMidi1 pexclusive + , bench "multi" $ whnf decodeMidi pmulti + ] + , bgroup "serializing" + [ bench "channelVoice" $ whnf encodeMidi1' schannelVoice + , bench "pitchBend" $ whnf encodeMidi1' spitchBend + , bench "monoOn" $ whnf encodeMidi1' smonoOn + , bench "exclusive" $ whnf encodeMidi1' sexclusive + , bench "multi" $ whnf encodeMidi' smulti + ] + ] diff --git a/example/MidiDump.hs b/example/MidiDump.hs new file mode 100644 --- /dev/null +++ b/example/MidiDump.hs @@ -0,0 +1,19 @@ +module Main where + +import Sound.MIDI +import Pipes +import qualified Pipes.Prelude as P +import qualified Pipes.ByteString as B +import Pipes.Attoparsec +import System.IO +import System.Environment + +main :: IO () +main = do + [fp] <- getArgs + fd <- openFile fp ReadMode + + runEffect $ + void (parsed midiParser (B.fromHandle fd)) >-> P.map show >-> P.stdoutLn + + return () diff --git a/example/Reencode.hs b/example/Reencode.hs new file mode 100644 --- /dev/null +++ b/example/Reencode.hs @@ -0,0 +1,21 @@ +module Main where + +import Sound.MIDI +import Pipes +import qualified Pipes.Prelude as P +import qualified Pipes.ByteString as B +import Pipes.Attoparsec +import System.IO +import System.Environment + +main :: IO () +main = do + [fp] <- getArgs + fd <- openFile fp ReadMode + fdo <- openFile (fp ++ "-re") WriteMode + + runEffect $ + void (parsed midiParser (B.fromHandle fd)) + >-> P.map encodeMidi1' >-> B.toHandle fdo + + return () diff --git a/midi-simple.cabal b/midi-simple.cabal new file mode 100644 --- /dev/null +++ b/midi-simple.cabal @@ -0,0 +1,72 @@ +name: midi-simple +version: 0.1.0.0 +synopsis: A simple and fast library for working with MIDI messages +description: Please see README.rst +homepage: https://github.com/tsahyt/midi-simple#readme +license: LGPL-3 +license-file: LICENSE +author: Paul Ogris +maintainer: paul@tsahyt.com +copyright: 2017 Paul Ogris +category: Sound +build-type: Simple +extra-source-files: README.rst +cabal-version: >=1.10 + +flag examples + description: Build examples + default: False + +library + hs-source-dirs: src + ghc-options: -Wall -O2 + exposed-modules: Sound.MIDI + Sound.MIDI.Types + Sound.MIDI.Parser + Sound.MIDI.Serialize + Sound.MIDI.Controllers + build-depends: base >= 4.7 && < 5, + attoparsec >= 0.13.1.0 && < 0.14, + bytestring >= 0.10.8.1 && < 0.11 + default-language: Haskell2010 + +executable midi-dump + if flag(examples) + build-depends: base >= 4.7 && < 5, midi-simple, pipes, + pipes-bytestring, pipes-attoparsec + else + buildable: False + hs-source-dirs: example + ghc-options: -Wall -O2 + main-is: MidiDump.hs + default-language: Haskell2010 + +executable re-encode + if flag(examples) + build-depends: base >= 4.7 && < 5, midi-simple, pipes, + pipes-bytestring, pipes-attoparsec + else + buildable: False + hs-source-dirs: example + ghc-options: -Wall -O2 -rtsopts + main-is: Reencode.hs + default-language: Haskell2010 + +test-suite midi-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: base >= 4.7 && < 5, midi-simple, tasty, tasty-hspec, + tasty-quickcheck, QuickCheck, generic-random, bytestring, + hspec-attoparsec, hspec, attoparsec + +benchmark midi-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + ghc-options: -Wall -O2 + build-depends: base >= 4.7 && < 5, midi-simple, criterion, bytestring + +source-repository head + type: git + location: https://github.com/tsahyt/midi-simple diff --git a/src/Sound/MIDI.hs b/src/Sound/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI.hs @@ -0,0 +1,78 @@ +module Sound.MIDI +( + -- * Encoding + encodeMidi, + encodeMidi', + encodeMidi1, + encodeMidi1', + + -- * Decoding + decodeMidi, + decodeMidi1, + partitionRealtime, + + -- * Parser and Serializer + -- + -- | Top level parsing and serializing tools are exposed here. For + -- fine-grained access, see "Sound.MIDI.Parser" and "Sound.MIDI.Serialize". + midiParser, + midiSerializer, + + -- * Re-exports + module Sound.MIDI.Types +) +where + +import Control.Applicative +import Data.Functor.Identity +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Builder (toLazyByteString, Builder) +import qualified Data.Attoparsec.ByteString as A + +import Sound.MIDI.Types +import qualified Sound.MIDI.Parser as P +import qualified Sound.MIDI.Serialize as S + +-- | Encode some collection of 'MidiMessage's to a lazy 'BL.ByteString' +encodeMidi :: Foldable t => t MidiMessage -> BL.ByteString +encodeMidi = toLazyByteString . foldMap S.midiMessage +{-# SPECIALISE encodeMidi :: [MidiMessage] -> BL.ByteString #-} + +-- | Strict version of 'encodeMidi' +encodeMidi' :: Foldable t => t MidiMessage -> BS.ByteString +encodeMidi' = BL.toStrict . encodeMidi +{-# SPECIALISE encodeMidi' :: [MidiMessage] -> BS.ByteString #-} + +-- | Encode a single message to a lazy 'BL.ByteString' +encodeMidi1 :: MidiMessage -> BL.ByteString +encodeMidi1 = encodeMidi . Identity + +-- | Strict version of 'encodeMidi1' +encodeMidi1' :: MidiMessage -> BS.ByteString +encodeMidi1' = encodeMidi' . Identity + +-- | Decode raw MIDI data from a strict 'ByteString'. Any incomplete data at the +-- beginning will be skipped! This function assumes a normalized MIDI stream, +-- i.e. one in which events are /not/ interrupted by real-time events! +decodeMidi :: BS.ByteString -> Either String [MidiMessage] +decodeMidi = A.parseOnly (P.skipToStatus *> some P.midiMessage) + +-- | Decode one event from raw MIDI data in a strict 'ByteString'. Any +-- incomplete data at the beginning will be skipped! +decodeMidi1 :: BS.ByteString -> Either String MidiMessage +decodeMidi1 = A.parseOnly (P.skipToStatus *> P.midiMessage) + +-- | Partition an event stream into real-time events and other messages. The +-- first parameter returned will be the real-time events, the second element +-- will be the rest of the stream. Note that this effectively normalizes the +-- second element. +partitionRealtime :: BS.ByteString -> (BS.ByteString, BS.ByteString) +partitionRealtime = BS.partition isRT + where isRT x = x >= 0xF8 && x <= 0xFF + +midiParser :: A.Parser MidiMessage +midiParser = P.midiMessage + +midiSerializer :: MidiMessage -> Builder +midiSerializer = S.midiMessage diff --git a/src/Sound/MIDI/Controllers.hs b/src/Sound/MIDI/Controllers.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Controllers.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE PatternSynonyms #-} +-- | A module providing pattern synonyms for controller numbers as defined in +-- the MIDI 1.0 specification. +module Sound.MIDI.Controllers +( + pattern BankSelect, + pattern ModWheel, + pattern BreathController, + pattern FootController, + pattern PortamentoTime, + pattern DataEntryMSB, + pattern ChannelVolume, + pattern Balance, + pattern Pan, + pattern ExpressionController, + pattern EffectControl1, + pattern EffectControl2, + pattern GeneralPurposeController1, + pattern GeneralPurposeController2, + pattern GeneralPurposeController3, + pattern GeneralPurposeController4, + pattern LSB0, + pattern LSB1, + pattern LSB2, + pattern LSB3, + pattern LSB4, + pattern LSB5, + pattern LSB6, + pattern LSB7, + pattern LSB8, + pattern LSB9, + pattern LSB10, + pattern LSB11, + pattern LSB12, + pattern LSB13, + pattern LSB14, + pattern LSB15, + pattern LSB16, + pattern LSB17, + pattern LSB18, + pattern LSB19, + pattern LSB20, + pattern LSB21, + pattern LSB22, + pattern LSB23, + pattern LSB24, + pattern LSB25, + pattern LSB26, + pattern LSB27, + pattern LSB28, + pattern LSB29, + pattern LSB30, + pattern LSB31, + pattern DamperPedal, + pattern Portamento, + pattern Sostenuto, + pattern SoftPedal, + pattern LegatoFootswitch, + pattern Hold2, + pattern SoundController1, + pattern SoundVariation, + pattern SoundController2, + pattern Timbre, + pattern SoundController3, + pattern ReleaseTime, + pattern SoundController4, + pattern AttackTime, + pattern SoundController5, + pattern Brightness, + pattern SoundControllers6, + pattern SoundControllers7, + pattern SoundControllers8, + pattern SoundControllers9, + pattern SoundControllers10, + pattern GeneralPurposeController5, + pattern GeneralPurposeController6, + pattern GeneralPurposeController7, + pattern GeneralPurposeController8, + pattern PortamentoControl, + pattern Effects1Depth, + pattern ExternalEffectsDepth, + pattern Effects2Depth, + pattern TremoloDepth, + pattern Effects3Depth, + pattern ChorusDepth, + pattern Effects4Depth, + pattern CelesteDepth, + pattern Effects5Depth, + pattern PhaserDepth, + pattern DataIncrement, + pattern DataDecrement, + pattern UnRegisteredParameterNumberLSB, + pattern UnRegisteredParameterNumberMSB, + pattern RegisteredParameterNumberLSB, + pattern RegisteredParameterNumberMSB +) +where + +import Sound.MIDI.Types + +pattern BankSelect :: Controller +pattern BankSelect = Controller 0 + +pattern ModWheel :: Controller +pattern ModWheel = Controller 1 + +pattern BreathController :: Controller +pattern BreathController = Controller 2 + +pattern FootController :: Controller +pattern FootController = Controller 4 + +pattern PortamentoTime :: Controller +pattern PortamentoTime = Controller 5 + +pattern DataEntryMSB :: Controller +pattern DataEntryMSB = Controller 6 + +pattern ChannelVolume :: Controller +pattern ChannelVolume = Controller 7 + +pattern Balance :: Controller +pattern Balance = Controller 8 + +pattern Pan :: Controller +pattern Pan = Controller 10 + +pattern ExpressionController :: Controller +pattern ExpressionController = Controller 11 + +pattern EffectControl1 :: Controller +pattern EffectControl1 = Controller 12 + +pattern EffectControl2 :: Controller +pattern EffectControl2 = Controller 13 + +pattern GeneralPurposeController1 :: Controller +pattern GeneralPurposeController1 = Controller 16 + +pattern GeneralPurposeController2 :: Controller +pattern GeneralPurposeController2 = Controller 17 + +pattern GeneralPurposeController3 :: Controller +pattern GeneralPurposeController3 = Controller 18 + +pattern GeneralPurposeController4 :: Controller +pattern GeneralPurposeController4 = Controller 19 + +pattern LSB0 :: Controller +pattern LSB0 = Controller 32 + +pattern LSB1 :: Controller +pattern LSB1 = Controller 33 + +pattern LSB2 :: Controller +pattern LSB2 = Controller 34 + +pattern LSB3 :: Controller +pattern LSB3 = Controller 35 + +pattern LSB4 :: Controller +pattern LSB4 = Controller 36 + +pattern LSB5 :: Controller +pattern LSB5 = Controller 37 + +pattern LSB6 :: Controller +pattern LSB6 = Controller 38 + +pattern LSB7 :: Controller +pattern LSB7 = Controller 39 + +pattern LSB8 :: Controller +pattern LSB8 = Controller 40 + +pattern LSB9 :: Controller +pattern LSB9 = Controller 41 + +pattern LSB10 :: Controller +pattern LSB10 = Controller 42 + +pattern LSB11 :: Controller +pattern LSB11 = Controller 43 + +pattern LSB12 :: Controller +pattern LSB12 = Controller 44 + +pattern LSB13 :: Controller +pattern LSB13 = Controller 45 + +pattern LSB14 :: Controller +pattern LSB14 = Controller 46 + +pattern LSB15 :: Controller +pattern LSB15 = Controller 47 + +pattern LSB16 :: Controller +pattern LSB16 = Controller 48 + +pattern LSB17 :: Controller +pattern LSB17 = Controller 49 + +pattern LSB18 :: Controller +pattern LSB18 = Controller 50 + +pattern LSB19 :: Controller +pattern LSB19 = Controller 51 + +pattern LSB20 :: Controller +pattern LSB20 = Controller 52 + +pattern LSB21 :: Controller +pattern LSB21 = Controller 53 + +pattern LSB22 :: Controller +pattern LSB22 = Controller 54 + +pattern LSB23 :: Controller +pattern LSB23 = Controller 55 + +pattern LSB24 :: Controller +pattern LSB24 = Controller 56 + +pattern LSB25 :: Controller +pattern LSB25 = Controller 57 + +pattern LSB26 :: Controller +pattern LSB26 = Controller 58 + +pattern LSB27 :: Controller +pattern LSB27 = Controller 59 + +pattern LSB28 :: Controller +pattern LSB28 = Controller 60 + +pattern LSB29 :: Controller +pattern LSB29 = Controller 61 + +pattern LSB30 :: Controller +pattern LSB30 = Controller 62 + +pattern LSB31 :: Controller +pattern LSB31 = Controller 63 + +pattern DamperPedal :: Controller +pattern DamperPedal = Controller 64 + +pattern Portamento :: Controller +pattern Portamento = Controller 65 + +pattern Sostenuto :: Controller +pattern Sostenuto = Controller 66 + +pattern SoftPedal :: Controller +pattern SoftPedal = Controller 67 + +pattern LegatoFootswitch :: Controller +pattern LegatoFootswitch = Controller 68 + +pattern Hold2 :: Controller +pattern Hold2 = Controller 69 + +pattern SoundController1 :: Controller +pattern SoundController1 = Controller 70 + +-- | Synonym for 'SoundController1' +pattern SoundVariation :: Controller +pattern SoundVariation = Controller 70 + +pattern SoundController2 :: Controller +pattern SoundController2 = Controller 71 + +-- | Synonym for 'SoundController2' +pattern Timbre :: Controller +pattern Timbre = Controller 71 + +pattern SoundController3 :: Controller +pattern SoundController3 = Controller 72 + +-- | Synonym for 'SoundController3' +pattern ReleaseTime :: Controller +pattern ReleaseTime = Controller 72 + +pattern SoundController4 :: Controller +pattern SoundController4 = Controller 73 + +-- | Synonym for 'SoundController4' +pattern AttackTime :: Controller +pattern AttackTime = Controller 73 + +pattern SoundController5 :: Controller +pattern SoundController5 = Controller 74 + +-- | Synonym for 'SoundController5' +pattern Brightness :: Controller +pattern Brightness = Controller 74 + +pattern SoundControllers6 :: Controller +pattern SoundControllers6 = Controller 75 + +pattern SoundControllers7 :: Controller +pattern SoundControllers7 = Controller 76 + +pattern SoundControllers8 :: Controller +pattern SoundControllers8 = Controller 77 + +pattern SoundControllers9 :: Controller +pattern SoundControllers9 = Controller 78 + +pattern SoundControllers10 :: Controller +pattern SoundControllers10 = Controller 79 + +pattern GeneralPurposeController5 :: Controller +pattern GeneralPurposeController5 = Controller 80 + +pattern GeneralPurposeController6 :: Controller +pattern GeneralPurposeController6 = Controller 81 + +pattern GeneralPurposeController7 :: Controller +pattern GeneralPurposeController7 = Controller 82 + +pattern GeneralPurposeController8 :: Controller +pattern GeneralPurposeController8 = Controller 83 + +pattern PortamentoControl :: Controller +pattern PortamentoControl = Controller 84 + +pattern Effects1Depth :: Controller +pattern Effects1Depth = Controller 91 + +-- | Synonym for 'Effects1Depth' +pattern ExternalEffectsDepth :: Controller +pattern ExternalEffectsDepth = Controller 91 + +pattern Effects2Depth :: Controller +pattern Effects2Depth = Controller 92 + +-- | Synonym for 'Effects2Depth' +pattern TremoloDepth :: Controller +pattern TremoloDepth = Controller 92 + +pattern Effects3Depth :: Controller +pattern Effects3Depth = Controller 93 + +-- | Synonym for 'Effects3Depth' +pattern ChorusDepth :: Controller +pattern ChorusDepth = Controller 93 + +pattern Effects4Depth :: Controller +pattern Effects4Depth = Controller 94 + +-- | Synonym for 'Effects4Depth' +pattern CelesteDepth :: Controller +pattern CelesteDepth = Controller 94 + +pattern Effects5Depth :: Controller +pattern Effects5Depth = Controller 95 + +-- | Synonym for 'Effects5Depth' +pattern PhaserDepth :: Controller +pattern PhaserDepth = Controller 95 + +pattern DataIncrement :: Controller +pattern DataIncrement = Controller 96 + +pattern DataDecrement :: Controller +pattern DataDecrement = Controller 97 + +pattern UnRegisteredParameterNumberLSB :: Controller +pattern UnRegisteredParameterNumberLSB = Controller 98 + +pattern UnRegisteredParameterNumberMSB :: Controller +pattern UnRegisteredParameterNumberMSB = Controller 99 + +pattern RegisteredParameterNumberLSB :: Controller +pattern RegisteredParameterNumberLSB = Controller 100 + +pattern RegisteredParameterNumberMSB :: Controller +pattern RegisteredParameterNumberMSB = Controller 101 diff --git a/src/Sound/MIDI/Parser.hs b/src/Sound/MIDI/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE LambdaCase #-} +-- | Parsers for 'MidiMessage' and its components, implemented as Attoparsec +-- parsers. See "Data.Attoparsec.ByteString" for how to run them. In most common +-- use cases, the 'decodeMidi' function in "Sound.MIDI" should suffice. +module Sound.MIDI.Parser where + +import Control.Applicative +import Sound.MIDI.Types +import Data.Bits +import Data.Word +import Data.Attoparsec.ByteString +import qualified Data.ByteString as B + +import Prelude hiding (take) + +midiMessage :: Parser MidiMessage +midiMessage = go =<< peekWord8' + where go x = case x .&. 0xF0 of + 0xB0 -> ChannelMode <$> channelMode + <|> ChannelVoice <$> channelVoice + 0xF0 -> system x + _ -> ChannelVoice <$> channelVoice + system x + | x == 0xF0 = SystemExclusive <$> systemExclusive + | x <= 0xF7 = SystemCommon <$> systemCommon + | otherwise = SystemRealTime <$> systemRealTime + +skipToStatus :: Parser () +skipToStatus = skipWhile (not . flip testBit 7) + +channelVoice :: Parser ChannelVoice +channelVoice = go =<< peekWord8' + where go x = case x .&. 0xF0 of + 0x80 -> noteOff + 0x90 -> noteOn + 0xA0 -> aftertouch + 0xB0 -> controlChange + 0xC0 -> patchChange + 0xD0 -> channelPressure + 0xE0 -> pitchBend + _ -> empty + +channelMessage :: Word8 -> (Word8 -> Parser a) -> Parser a +channelMessage header p = do + status <- anyWord8 + let upper = unsafeShiftR status 4 + lower = status .&. 0x0F + if upper == header then p lower else empty +{-# INLINE channelMessage #-} + +noteOff :: Parser ChannelVoice +noteOff = channelMessage 0x08 $ \c -> + NoteOff (Channel c) <$> pitch <*> velocity + +noteOn :: Parser ChannelVoice +noteOn = channelMessage 0x09 $ \c -> + NoteOn (Channel c) <$> pitch <*> velocity + +aftertouch :: Parser ChannelVoice +aftertouch = channelMessage 0x0A $ \c -> + Aftertouch (Channel c) <$> pitch <*> touch + +controlChange :: Parser ChannelVoice +controlChange = channelMessage 0x0B $ \c -> + ControlChange (Channel c) <$> controller <*> anyWord8 + +patchChange :: Parser ChannelVoice +patchChange = channelMessage 0x0C $ \c -> + PatchChange (Channel c) <$> patch + +channelPressure :: Parser ChannelVoice +channelPressure = channelMessage 0x0D $ \c -> + ChannelPressure (Channel c) <$> touch + +pitchBend :: Parser ChannelVoice +pitchBend = channelMessage 0x0E $ \c -> + PitchBend (Channel c) <$> anyWord14 + +anyWord14 :: Parser Word16 +anyWord14 = go <$> take 2 + where go x = let l = x `B.index` 0 + m = x `B.index` 1 + in unsafeShiftL (fromIntegral m) 7 + fromIntegral l + +channelMode :: Parser ChannelMode +channelMode = channelMessage 0x0B $ \c -> anyWord8 >>= \case + 0x78 -> AllSoundOff (Channel c) <$ word8 0x00 + 0x79 -> ResetAllControllers (Channel c) <$ word8 0x00 + 0x7A -> LocalControl (Channel c) <$> bool' + 0x7B -> AllNotesOff (Channel c) <$ word8 0x00 + 0x7C -> OmniOff (Channel c) <$ word8 0x00 + 0x7D -> OmniOn (Channel c) <$ word8 0x00 + 0x7E -> MonoOn (Channel c) <$> anyWord8 + 0x7F -> PolyOn (Channel c) <$ word8 0x00 + _ -> empty + + where bool' = anyWord8 >>= \case + 0x00 -> pure False + 0x7f -> pure True + _ -> empty + +systemCommon :: Parser SystemCommon +systemCommon = peekWord8' >>= \case + 0xF1 -> mtcQuarter + 0xF2 -> songPosition + 0xF3 -> songSelect + 0xF6 -> tuneRequest + 0xF7 -> eox + _ -> empty + +mtcQuarter :: Parser SystemCommon +mtcQuarter = MTCQuarter <$> (word8 0xF1 *> anyWord8) + +songPosition :: Parser SystemCommon +songPosition = SongPosition <$> (word8 0xF2 *> (PositionPointer <$> anyWord14)) + +songSelect :: Parser SystemCommon +songSelect = SongSelect <$> (word8 0xF3 *> anyWord8) + +tuneRequest :: Parser SystemCommon +tuneRequest = TuneRequest <$ word8 0xF6 + +eox :: Parser SystemCommon +eox = EOX <$ word8 0xF7 + +systemRealTime :: Parser SystemRealTime +systemRealTime = anyWord8 >>= \case + 0xF8 -> pure TimingClock + 0xFA -> pure Start + 0xFB -> pure Continue + 0xFC -> pure Stop + 0xFE -> pure ActiveSensing + 0xFF -> pure SystemReset + _ -> empty + +systemExclusive :: Parser SystemExclusive +systemExclusive = Exclusive + <$> (word8 0xF0 *> vendorId) + <*> takeTill (`testBit` 7) + +vendorId :: Parser VendorId +vendorId = longId <|> shortId + where longId = VendorIdLong <$> (word8 0x00 *> anyWord8) <*> anyWord8 + shortId = VendorIdShort <$> anyWord8 + +-- | Parse a 'Pitch', no check for bit 7 is performed! +pitch :: Parser Pitch +pitch = Pitch <$> anyWord8 + +-- | Parse a 'Pitch', no check for bit 7 is performed! +patch :: Parser Patch +patch = Patch <$> anyWord8 + +-- | Parse a 'Velocity', no check for bit 7 is performed! +velocity :: Parser Velocity +velocity = Velocity <$> anyWord8 + +-- | Parse a 'Touch', no check for bit 7 is performed! +touch :: Parser Touch +touch = Touch <$> anyWord8 + +-- | Parse a 'Controller', no check for bit 7 is performed! +controller :: Parser Controller +controller = Controller <$> anyWord8 diff --git a/src/Sound/MIDI/Serialize.hs b/src/Sound/MIDI/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Serialize.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +-- | ByteString builders for MIDI messages and their components. For information +-- on how to use the resulting 'Builder's, see "Data.ByteString.Builder". The +-- type signatures in this module should serve as sufficient documentation. For +-- most use cases the 'encodeMidi' function in "Sound.MIDI" should suffice. +module Sound.MIDI.Serialize where + +import Sound.MIDI.Types +import Data.ByteString.Builder +import Data.Monoid +import Data.Word +import Data.Bits + +midiMessage :: MidiMessage -> Builder +midiMessage = \case + ChannelVoice x -> channelVoice x + ChannelMode x -> channelMode x + SystemCommon x -> systemCommon x + SystemRealTime x -> systemRealTime x + SystemExclusive x -> systemExclusive x + +channelVoice :: ChannelVoice -> Builder +channelVoice = \case + NoteOff c p v -> + channelStatus 0x80 c <> pitch p <> velocity v + NoteOn c p v -> + channelStatus 0x90 c <> pitch p <> velocity v + Aftertouch c p t -> + channelStatus 0xA0 c <> pitch p <> touch t + ControlChange c n d -> + channelStatus 0xB0 c <> controller n <> word8 d + PatchChange c p -> + channelStatus 0xC0 c <> patch p + ChannelPressure c t -> + channelStatus 0xD0 c <> touch t + PitchBend c v -> + channelStatus 0xE0 c <> word14 v + +channelStatus :: Word8 -> Channel -> Builder +channelStatus p c = word8 $ p .|. getChannel c +{-# INLINE channelStatus #-} + +-- | Build a 14 bit word as it is used in the MIDI specifications, i.e. it is +-- built as two 8 bit words with the 7th bit not set respectively. +word14 :: Word16 -> Builder +word14 v = + let l = fromIntegral $ v .&. 0x007f + m = fromIntegral $ unsafeShiftR (v .&. 0x3f80) 7 + in word8 l <> word8 m +{-# INLINE word14 #-} + +channelMode :: ChannelMode -> Builder +channelMode = \case + AllSoundOff c -> + channelStatus 0xB0 c <> word8 0x78 <> word8 0x00 + ResetAllControllers c -> + channelStatus 0xB0 c <> word8 0x79 <> word8 0x00 + LocalControl c b -> + channelStatus 0xB0 c <> word8 0x7A <> bool' b + AllNotesOff c -> + channelStatus 0xB0 c <> word8 0x7B <> word8 0x00 + OmniOff c -> + channelStatus 0xB0 c <> word8 0x7C <> word8 0x00 + OmniOn c -> + channelStatus 0xB0 c <> word8 0x7D <> word8 0x00 + MonoOn c n -> + channelStatus 0xB0 c <> word8 0x7E <> word8 n + PolyOn c -> + channelStatus 0xB0 c <> word8 0x7F <> word8 0x00 + + where bool' True = word8 0x7F + bool' False = word8 0x00 + +systemCommon :: SystemCommon -> Builder +systemCommon = \case + MTCQuarter v -> word8 0xF1 <> word8 v + SongPosition pp -> word8 0xF2 <> word14 (getPositionPointer pp) + SongSelect x -> word8 0xF3 <> word8 x + TuneRequest -> word8 0xF6 + EOX -> word8 0xF7 + +systemRealTime :: SystemRealTime -> Builder +systemRealTime = \case + TimingClock -> word8 0xF8 + Start -> word8 0xFA + Continue -> word8 0xFB + Stop -> word8 0xFC + ActiveSensing -> word8 0xFE + SystemReset -> word8 0xFF + +systemExclusive :: SystemExclusive -> Builder +systemExclusive (Exclusive v x) = + word8 0xF0 <> vendorId v <> byteString x <> systemCommon EOX + +vendorId :: VendorId -> Builder +vendorId (VendorIdShort x) = word8 x +vendorId (VendorIdLong a b) = word8 0x00 <> word8 a <> word8 b + +pitch :: Pitch -> Builder +pitch = word8 . getPitch +{-# INLINE pitch #-} + +patch :: Patch -> Builder +patch = word8 . getPatch +{-# INLINE patch #-} + +velocity :: Velocity -> Builder +velocity = word8 . getVelocity +{-# INLINE velocity #-} + +touch :: Touch -> Builder +touch = word8 . getTouch +{-# INLINE touch #-} + +controller :: Controller -> Builder +controller = word8 . getController +{-# INLINE controller #-} diff --git a/src/Sound/MIDI/Types.hs b/src/Sound/MIDI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Types.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module Sound.MIDI.Types +( + -- * MIDI messages + MidiMessage (..), + + -- * Basic MIDI types + ChannelVoice (..), + ChannelMode (..), + SystemCommon (..), + SystemRealTime (..), + SystemExclusive (..), + + VendorId (..), + + -- * Numeric MIDI data + -- + -- | Only use the direct constructors when you can assure that the values + -- fit into 7 bits! In general you should prefer the smart constructors. For + -- values outside of the 7 bit range, the numbers should generally wrap + -- around, but no guarantees are made! + Channel (..), + mkChannel, + Pitch (..), + mkPitch, + middleC, + Patch (..), + mkPatch, + Velocity (..), + mkVelocity, + Touch (..), + mkTouch, + Controller (..), + mkController, + PositionPointer (..), + mkPositionPointer, + toClocks, + + -- * Helper functions + to4Bit, + to7Bit, + to14Bit +) +where + +import Data.Word +import Data.ByteString (ByteString) +import Data.Bits +import GHC.Generics + +-- | A data type representing midi messages. Messages can be categorized into 5 +-- subcategories +-- +-- 1. __Channel Voice Messages__. Start, stop, or alter sounds being played. +-- 2. __Channel Mode Messages__. Control messages affecting the entire +-- channel. +-- 3. __System Real-Time Messages__. Used by sequencers to regulate and +-- synchronize timing. +-- 4. __System Common Messages__. Used for song selection, position +-- pointers, etc. +-- 5. __System Exclusive Messages__. Used for device-specific extensions to +-- the MIDI protocol. +-- +data MidiMessage + = ChannelVoice ChannelVoice + | ChannelMode ChannelMode + | SystemCommon SystemCommon + | SystemRealTime SystemRealTime + | SystemExclusive SystemExclusive + deriving (Eq, Show, Ord, Read, Generic) + +-- | Type holding channel voice messages. Channel Voice messages transmit +-- real-time performance data over a single channel. Examples include "note-on" +-- messages which contain a MIDI note number that specifies the note's pitch, a +-- velocity value that indicates how forcefully the note was played, and the +-- channel number; "note-off" messages that end a note; program change messages +-- that change a device's patch; and control changes that allow adjustment of an +-- instrument's parameters. +data ChannelVoice + = NoteOff !Channel !Pitch !Velocity + | NoteOn !Channel !Pitch !Velocity + | Aftertouch !Channel !Pitch !Touch + | ControlChange !Channel !Controller !Word8 + | PatchChange !Channel !Patch + | ChannelPressure !Channel !Touch + | PitchBend !Channel !Word16 + deriving (Eq, Show, Ord, Read, Generic) + +-- | A type for channel mode messages. Mode messages determine how an instrument +-- will receive all subsequent voice messages. This includes whether the +-- receiver will play notes monophonically or polyphonically and whether it will +-- respond only to data sent on one specific voice channel or all of them. +data ChannelMode + = AllSoundOff !Channel + | ResetAllControllers !Channel + | LocalControl !Channel !Bool + | AllNotesOff !Channel + | OmniOff !Channel + | OmniOn !Channel + | MonoOn !Channel !Word8 + | PolyOn !Channel + deriving (Eq, Show, Ord, Read, Generic) + +-- | A type for system common messages. System common messages are intended for +-- all receivers in the system. +data SystemCommon + = MTCQuarter !Word8 + | SongPosition !PositionPointer + | SongSelect !Word8 + | TuneRequest + | EOX + deriving (Eq, Show, Ord, Read, Generic) + +-- | System real time messages. The MIDI System Real Time messages are used to +-- synchronize all of the MIDI clock-based equipment within a system, such as +-- sequencers and drum machines. Most of the System Real Time messages are +-- normally ignored by keyboard instruments and synthesizers. To help ensure +-- accurate timing, System Real Time messages are given priority over other +-- messages, and these single-byte messages may occur anywhere in the data +-- stream (a Real Time message may appear between the status byte and data byte +-- of some other MIDI message). +data SystemRealTime + = TimingClock + | Start + | Continue + | Stop + | ActiveSensing + | SystemReset + deriving (Eq, Show, Ord, Read, Generic) + +-- | System exclusive messages. System Exclusive messages may be used to send +-- data such as patch parameters or sample data between MIDI devices. +-- Manufacturers of MIDI equipment may define their own formats for System +-- Exclusive data. Manufacturers are granted unique identification (ID) numbers +-- by the MMA or the JMSC, and the manufacturer ID number is included as part of +-- the System Exclusive message. See 'VendorId'. +-- +-- The representation used here is deliberately generic. Special sets of system +-- exclusive messages can be implemented on top of this type. +data SystemExclusive + = Exclusive !VendorId ByteString + deriving (Eq, Show, Ord, Read, Generic) + +-- | Data type encapsulating vendor ID numbers as used in 'SystemExclusive'. +-- They have one of two possible formats: +-- +-- 1. A one byte ID (represented by 'VendorIdShort') +-- 2. A three byte ID, which must begin with @0x00@. ('VendorIdLong') +data VendorId + = VendorIdShort !Word8 + | VendorIdLong !Word8 !Word8 + deriving (Eq, Show, Ord, Read, Generic) + +to7Bit :: Integral a => a -> Word8 +to7Bit = (.&. 0x7F) . fromIntegral + +to4Bit :: Integral a => a -> Word8 +to4Bit = (.&. 0x0F) . fromIntegral + +newtype Channel = Channel { getChannel :: Word8 } + deriving (Eq, Show, Ord, Read) + +mkChannel :: Integral a => a -> Channel +mkChannel = Channel . to4Bit + +newtype Pitch = Pitch { getPitch :: Word8 } + deriving (Eq, Show, Ord, Read) + +mkPitch :: Integral a => a -> Pitch +mkPitch = Pitch . to7Bit + +-- | The middle C on a piano as defined by the MIDI specification. This can +-- serve as a reference value for working with pitches. +middleC :: Pitch +middleC = Pitch 60 + +newtype Velocity = Velocity { getVelocity :: Word8 } + deriving (Eq, Show, Ord, Read) + +mkVelocity :: Integral a => a -> Velocity +mkVelocity = Velocity . to7Bit + +newtype Touch = Touch { getTouch :: Word8 } + deriving (Eq, Show, Ord, Read) + +mkTouch :: Integral a => a -> Touch +mkTouch = Touch . to7Bit + +newtype Controller = Controller { getController :: Word8 } + deriving (Eq, Show, Ord, Read) + +mkController :: Integral a => a -> Controller +mkController = Controller . to7Bit + +newtype Patch = Patch { getPatch :: Word8 } + deriving (Eq, Show, Ord, Read) + +mkPatch :: Integral a => a -> Patch +mkPatch = Patch . to7Bit + +newtype PositionPointer = PositionPointer { getPositionPointer :: Word16 } + deriving (Eq, Show, Ord, Read) + +to14Bit :: Integral a => a -> Word16 +to14Bit = (.&. 0x3FFF) . fromIntegral + +mkPositionPointer :: Integral a => a -> PositionPointer +mkPositionPointer = PositionPointer . to14Bit + +-- | Convert a 'PositionPointer', used to indicate song position, to the MIDI +-- clock. Song Position Pointer is always multiplied by 6 times the MIDI clocks +-- (F8H). Thus the smallest Song Position change is 6 MIDI clocks, or 1/16 note. +toClocks :: PositionPointer -> Int +toClocks = (* 6) . fromIntegral . getPositionPointer +{-# INLINEABLE toClocks #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,233 @@ +{-# 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)