midi-0.2.0.1/0000755000000000000000000000000011753275103010764 5ustar0000000000000000midi-0.2.0.1/Makefile0000644000000000000000000000004611753275103012424 0ustar0000000000000000ghci: ghci -i:src -Wall test/Main.hs midi-0.2.0.1/midi.cabal0000644000000000000000000000671211753275103012700 0ustar0000000000000000Name: midi Version: 0.2.0.1 License: GPL License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann Homepage: http://www.haskell.org/haskellwiki/MIDI Category: Sound, Music Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3 Tested-With: GHC==7.0.4, GHC==7.2.1 Cabal-Version: >=1.6 Build-Type: Simple Synopsis: Handling of MIDI messages and files Description: MIDI is the Musical Instrument Digital Interface. The package contains definition of realtime and file MIDI messages, reading and writing MIDI files, and some definitions from the General MIDI standard. It contains no sending and receiving of MIDI messages. For this purpose see the @alsa-seq@, @jack@, @PortMidi@, @hmidi@ packages. For music composition with MIDI output, see @haskore@. Alternative packages are @HCodecs@, @zmidi-core@. Extra-Source-Files: Makefile src/Sound/MIDI/Example/Tomatosalad.hs Source-Repository head type: darcs location: http://code.haskell.org/~thielema/midi/ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/midi/ tag: 0.2.0.1 Flag splitBase description: Choose the new smaller, split-up base package. Flag buildTests description: Build test executables default: False Library Build-Depends: event-list >=0.0.9 && < 0.2, non-negative>=0.0.1 && <0.2, explicit-exception >=0.1 && <0.2, bytestring >=0.9.0.1 && <0.11, binary >=0.4.2 && <0.6, transformers >=0.2 && <0.4, monoid-transformer >=0.0.1 && <0.1, QuickCheck >=1 && <3 If flag(splitBase) Build-Depends: random >=1 && <2, base >= 3 && <5 Else Build-Depends: base >= 1.0 && < 3 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Sound.MIDI.File Sound.MIDI.File.Event Sound.MIDI.File.Event.Meta Sound.MIDI.File.Event.SystemExclusive Sound.MIDI.File.Load Sound.MIDI.File.Save Sound.MIDI.Parser.Report Sound.MIDI.Message Sound.MIDI.Message.Channel Sound.MIDI.Message.Channel.Voice Sound.MIDI.Message.Channel.Mode Sound.MIDI.Message.System Sound.MIDI.Message.System.Exclusive Sound.MIDI.Message.System.Common Sound.MIDI.Message.System.RealTime Sound.MIDI.Message.Class.Check Sound.MIDI.Message.Class.Query Sound.MIDI.Controller Sound.MIDI.Manufacturer Sound.MIDI.KeySignature Sound.MIDI.General -- exports ByteList data type Sound.MIDI.IO Other-Modules: -- Parser class and general parser functions Sound.MIDI.Parser.Class Sound.MIDI.Parser.Restricted Sound.MIDI.Parser.Exception Sound.MIDI.Parser.Warning Sound.MIDI.Parser.Primitive Sound.MIDI.Parser.Status -- concrete Parsers Sound.MIDI.Parser.File Sound.MIDI.Parser.Stream Sound.MIDI.Parser.ByteString -- output basics Sound.MIDI.Writer.Basic Sound.MIDI.Writer.Status -- utilities Sound.MIDI.Bit Sound.MIDI.Monoid Sound.MIDI.String Sound.MIDI.Utility -- type definition Sound.MIDI.ControllerPrivate -- didactic example Sound.MIDI.Example.ControllerRamp Executable test If !flag(buildTests) Buildable: False -- this will put Cabal into an infinite loop sooner or later -- Build-Depends: midi Hs-source-dirs: src, test GHC-Options: -Wall Main-Is: Main.hs midi-0.2.0.1/Setup.lhs0000644000000000000000000000011511753275103012571 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain midi-0.2.0.1/LICENSE0000644000000000000000000010451311753275103011775 0ustar0000000000000000 GNU 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. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU 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 Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . midi-0.2.0.1/src/0000755000000000000000000000000011753275103011553 5ustar0000000000000000midi-0.2.0.1/src/Sound/0000755000000000000000000000000011753275103012643 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/0000755000000000000000000000000011753275103013365 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/String.hs0000644000000000000000000000143411753275103015171 0ustar0000000000000000{- | Taken from Haskore. -} module Sound.MIDI.String where import Control.Monad.Trans.State (State, runState) unlinesS :: [ShowS] -> ShowS unlinesS = concatS . map (. showString "\n") concatS :: [ShowS] -> ShowS concatS = foldr (.) id rightS, leftS, centreS :: Int -> ShowS -> ShowS rightS n s = showString (right n (s "")) leftS n s = showString (left n (s "")) centreS n s = showString (centre n (s "")) right,left, centre :: Int -> String -> String right n s = spaces (n - length s) ++ s left n s = s ++ spaces (n - length s) centre n s = spaces l ++ s ++ spaces (n'-l) where n' = n - length s l = n' `div` 2 spaces :: Int -> String spaces n = replicate (max 0 n) ' ' stateToReadS :: State String a -> ReadS a stateToReadS state string = [runState state string] midi-0.2.0.1/src/Sound/MIDI/IO.hs0000644000000000000000000000205011753275103014225 0ustar0000000000000000{- | Taken from Haskore. -} module Sound.MIDI.IO (openBinaryFile, readBinaryFile, writeBinaryFile, ByteList, listCharFromByte, listByteFromChar) where import System.IO import Control.Exception(bracket) import Control.Monad(liftM) import Data.Char (ord, chr) import Data.Word (Word8) type ByteList = [Word8] {- | Hugs makes trouble here because it performs UTF-8 conversions. E.g. @[255]@ is output as @[195,191]@ It would be easy to replace these routines by FastPackedString(fps).ByteList.Lazy, however this introduces a new package dependency. -} writeBinaryFile :: FilePath -> ByteList -> IO () writeBinaryFile path str = bracket (openBinaryFile path WriteMode) hClose (flip hPutStr (listCharFromByte str)) listCharFromByte :: ByteList -> String listCharFromByte = map (chr . fromIntegral) readBinaryFile :: FilePath -> IO ByteList readBinaryFile path = liftM listByteFromChar . hGetContents =<< openBinaryFile path ReadMode listByteFromChar :: String -> ByteList listByteFromChar = map (fromIntegral . ord) midi-0.2.0.1/src/Sound/MIDI/Bit.hs0000644000000000000000000000516111753275103014442 0ustar0000000000000000{- | Bit manipulation. Taken from Haskore. Bit operations work with numbers on the level of ones and zeros. These functions should be called something like \"pseudo-bit-operations\". They do not reach into the ones and zeros, but they do duplicate the effects using regular math. Note that these bitops, though convenient, are no more efficient than the high-level arithmetic that does the same thing. (This is different than in other languages such as C.) -} module Sound.MIDI.Bit where import Sound.MIDI.Utility (toMaybe, swap) import Data.Word(Word8) import qualified Data.List as List import qualified Data.Bits as Bits {- | Shift bitwise to the left and right. -} shiftL, shiftR :: Bits.Bits a => Int -> a -> a shiftL = flip Bits.shiftL shiftR = flip Bits.shiftR {- | The call @toBase n x@ takes a given number x and "chops it up," returning its digits in base b. Its output is in the form of a big-endian list of ints. divMod is used because it gives the correct rounding for negative numbers. Ex. toBytes 1000 -> toBase 256 1000 -> (256*3) + 232 -> [ 3 , 232 ] -} toBase :: Integral a => a -> a -> [a] toBase b = reverse . List.unfoldr (\n -> toMaybe (n>0) (swap (divMod n b))) toBits, toOctal, toHex, toBytes :: Integral a => a -> [a] toBytes = toBase 256 toHex = toBase 16 toOctal = toBase 8 toBits = toBase 2 {- | Get only n of the least significant bytes of x. If it takes less than n digits to express x, then fill the extra digits with zeros. -} someBytes :: Integral a => Int -> a -> [Word8] someBytes n = reverse . take n . map fromIntegral . List.unfoldr (Just . swap . flip divMod (2^(8::Int))) {- | The fromBase function converts a list of digits in another base into a single base-10 number. fromBase b [x,y,z] = x*b^2 + y*b^1 + z*b^0 -} fromBase :: Integral a => a -> [a] -> a fromBase base xs = foldl (\a x -> base*a+x) 0 xs fromBits, fromOctal, fromHex, fromBytes :: Integral a => [a] -> a fromBytes = fromBase 256 fromHex = fromBase 16 fromOctal = fromBase 8 fromBits = fromBase 2 {- | Like 'replicate' but for big numbers. It chops the list into blocks of tractable sizes (e.g. @maxBound::Int@). -} replicateBig :: Integer -> Integer -> a -> [a] replicateBig base x c = let loopSizes = map fromInteger (toBase base x) b = fromInteger base in foldl (\cs n -> concat (replicate b cs) ++ replicate n c) [] loopSizes {- | @trunc b n@ takes the b least significant bits of n. -} trunc :: Integral a => Int -> a -> a trunc b n = n `mod` (2^b) {- | @splitAt b n@ splits a number into a tuple: (before bit b, after bit b). -} splitAt :: Integral a => Int -> a -> (a, a) splitAt b n = n `divMod` (2^b) midi-0.2.0.1/src/Sound/MIDI/KeySignature.hs0000644000000000000000000001211011753275103016326 0ustar0000000000000000module Sound.MIDI.KeySignature ( T(..), Accidentals(..), Mode(..), keyName, cfMajor, gfMajor, dfMajor, afMajor, efMajor, bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor, eMajor, bMajor, fsMajor, csMajor, afMinor, efMinor, bfMinor, fMinor, cMinor, gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor, csMinor, gsMinor, dsMinor, asMinor, get, toBytes, ) where import Sound.MIDI.Parser.Primitive (getByte, getEnum, makeEnum, ) import qualified Sound.MIDI.Parser.Class as Parser import Control.Monad (liftM2, ) import Data.Ix (Ix, inRange, ) import Sound.MIDI.Utility (enumRandomR, boundedEnumRandom, chooseEnum, checkRange, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), ) import Data.Int (Int8, ) import Prelude hiding (putStr, ) data T = Cons Mode Accidentals deriving (Eq, Ord) instance Show T where showsPrec p (Cons mode accs) = if inRange (minBound, maxBound) accs then showString "KeySig." . showString (keyName mode accs) . shows mode else showParen (p>10) $ showString "KeySig.Cons " . shows mode . showString " " . showsPrec 11 accs instance Arbitrary T where arbitrary = liftM2 Cons arbitrary arbitrary {- | The Key Signature specifies a mode, either major or minor. -} data Mode = Major | Minor deriving (Show, Eq, Ord, Ix, Enum, Bounded) instance Random Mode where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Mode where arbitrary = chooseEnum keyName :: Mode -> Accidentals -> String keyName Major (Accidentals (-7)) = "cf" keyName Major (Accidentals (-6)) = "gf" keyName Major (Accidentals (-5)) = "df" keyName Major (Accidentals (-4)) = "af" keyName Major (Accidentals (-3)) = "ef" keyName Major (Accidentals (-2)) = "bf" keyName Major (Accidentals (-1)) = "f" keyName Major (Accidentals 0) = "c" keyName Major (Accidentals 1) = "g" keyName Major (Accidentals 2) = "d" keyName Major (Accidentals 3) = "a" keyName Major (Accidentals 4) = "e" keyName Major (Accidentals 5) = "b" keyName Major (Accidentals 6) = "fs" keyName Major (Accidentals 7) = "cs" keyName Minor (Accidentals (-7)) = "af" keyName Minor (Accidentals (-6)) = "ef" keyName Minor (Accidentals (-5)) = "bf" keyName Minor (Accidentals (-4)) = "f" keyName Minor (Accidentals (-3)) = "c" keyName Minor (Accidentals (-2)) = "g" keyName Minor (Accidentals (-1)) = "d" keyName Minor (Accidentals 0) = "a" keyName Minor (Accidentals 1) = "e" keyName Minor (Accidentals 2) = "b" keyName Minor (Accidentals 3) = "fs" keyName Minor (Accidentals 4) = "cs" keyName Minor (Accidentals 5) = "gs" keyName Minor (Accidentals 6) = "ds" keyName Minor (Accidentals 7) = "as" keyName _ (Accidentals n) = if n<0 then show (-n) ++ " flats" else show n ++ " sharps" {- | Accidentals as used in key signature. -} newtype Accidentals = Accidentals Int deriving (Show, Eq, Ord, Ix) instance Bounded Accidentals where minBound = Accidentals (-7) maxBound = Accidentals 7 instance Enum Accidentals where fromEnum (Accidentals n) = fromIntegral n toEnum = checkRange "Accidentals" (Accidentals . fromIntegral) instance Random Accidentals where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Accidentals where arbitrary = chooseEnum major, minor :: Accidentals -> T major = Cons Major minor = Cons Minor cfMajor, gfMajor, dfMajor, afMajor, efMajor, bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor, eMajor, bMajor, fsMajor, csMajor :: T afMinor, efMinor, bfMinor, fMinor, cMinor, gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor, csMinor, gsMinor, dsMinor, asMinor :: T cfMajor = major (Accidentals (-7)) gfMajor = major (Accidentals (-6)) dfMajor = major (Accidentals (-5)) afMajor = major (Accidentals (-4)) efMajor = major (Accidentals (-3)) bfMajor = major (Accidentals (-2)) fMajor = major (Accidentals (-1)) cMajor = major (Accidentals 0) gMajor = major (Accidentals 1) dMajor = major (Accidentals 2) aMajor = major (Accidentals 3) eMajor = major (Accidentals 4) bMajor = major (Accidentals 5) fsMajor = major (Accidentals 6) csMajor = major (Accidentals 7) afMinor = minor (Accidentals (-7)) efMinor = minor (Accidentals (-6)) bfMinor = minor (Accidentals (-5)) fMinor = minor (Accidentals (-4)) cMinor = minor (Accidentals (-3)) gMinor = minor (Accidentals (-2)) dMinor = minor (Accidentals (-1)) aMinor = minor (Accidentals 0) eMinor = minor (Accidentals 1) bMinor = minor (Accidentals 2) fsMinor = minor (Accidentals 3) csMinor = minor (Accidentals 4) gsMinor = minor (Accidentals 5) dsMinor = minor (Accidentals 6) asMinor = minor (Accidentals 7) get :: (Parser.C parser) => Parser.Fallible parser T get = liftM2 (flip Cons) getAccidentals getEnum getAccidentals :: (Parser.C parser) => Parser.Fallible parser Accidentals getAccidentals = makeEnum . fromIntegral . (id :: Int8 -> Int8) . fromIntegral =<< getByte toBytes :: T -> [Int] toBytes (Cons mi sf) = [fromEnum sf, fromEnum mi] midi-0.2.0.1/src/Sound/MIDI/Controller.hs0000644000000000000000000002135011753275103016045 0ustar0000000000000000{- | MIDI controller data type and common controller definitions. See . -} module Sound.MIDI.Controller ( T, Value, fromInt, toInt, bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, volume, balance, panorama, expression, effectControl1, effectControl2, generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, vectorX, vectorY, soundController1, soundController2, soundController3, soundController4, soundController5, soundController6, soundController7, soundController8, soundController9, soundController10, portamentoControl, effect1Depth, effect2Depth, effect3Depth, effect4Depth, effect5Depth, bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, portamentoTimeMSB, dataEntryMSB, volumeMSB, balanceMSB, panoramaMSB, expressionMSB, effectControl1MSB, effectControl2MSB, generalPurpose1MSB, generalPurpose2MSB, generalPurpose3MSB, generalPurpose4MSB, bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, volumeLSB, balanceLSB, panoramaLSB, expressionLSB, effectControl1LSB, effectControl2LSB, generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB, soundVariation, timbre, harmonicIntensity, releaseTime, attackTime, brightness, decayTime, vibratoRate, vibratoDepth, vibratoDelay, reverbSendLevel, chorusSendLevel, legato, sustain, portamento, sustenuto, softPedal, hold2, generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, externalEffectDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth, dataIncrement, dataDecrement, nonRegisteredParameterLSB, nonRegisteredParameterMSB, registeredParameterLSB, registeredParameterMSB, ) where import qualified Sound.MIDI.ControllerPrivate as CtrlP import Sound.MIDI.Utility (checkRange, ) -- * MIDI controller data type {- In the future this will be the main type, and @Controller@ becomes a synonym and is eventually removed. -} type T = CtrlP.Controller fromInt :: Int -> T fromInt = checkRange "Controller" CtrlP.Controller toInt :: T -> Int toInt = CtrlP.fromController type Value = Int -- * predefined MIDI controllers -- ** simple names for controllers, if only most-significant bytes are used bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, volume, balance, panorama, expression, effectControl1, effectControl2, generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4 :: T bankSelect = bankSelectMSB modulation = modulationMSB breathControl = breathControlMSB footControl = footControlMSB portamentoTime = portamentoTimeMSB dataEntry = dataEntryMSB volume = volumeMSB balance = balanceMSB panorama = panoramaMSB expression = expressionMSB effectControl1 = effectControl1MSB effectControl2 = effectControl2MSB generalPurpose1 = generalPurpose1MSB generalPurpose2 = generalPurpose2MSB generalPurpose3 = generalPurpose3MSB generalPurpose4 = generalPurpose4MSB -- ** aliases for general purpose controllers vectorX, vectorY, soundVariation, timbre, harmonicIntensity, releaseTime, attackTime, brightness, decayTime, vibratoRate, vibratoDepth, vibratoDelay, reverbSendLevel, chorusSendLevel, externalEffectDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth :: T vectorX = generalPurpose1 vectorY = generalPurpose2 soundVariation = soundController1 timbre = soundController2 harmonicIntensity = soundController2 releaseTime = soundController3 attackTime = soundController4 brightness = soundController5 decayTime = soundController6 vibratoRate = soundController7 vibratoDepth = soundController8 vibratoDelay = soundController9 reverbSendLevel = effect1Depth chorusSendLevel = effect3Depth externalEffectDepth = effect1Depth tremoloDepth = effect2Depth chorusDepth = effect3Depth celesteDepth = effect4Depth phaserDepth = effect5Depth -- ** controllers for most-significant bytes of control values bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, portamentoTimeMSB, dataEntryMSB, volumeMSB, balanceMSB, panoramaMSB, expressionMSB, effectControl1MSB, effectControl2MSB, generalPurpose1MSB, generalPurpose2MSB, generalPurpose3MSB, generalPurpose4MSB :: T -- ** controllers for least-significant bytes of control values bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, volumeLSB, balanceLSB, panoramaLSB, expressionLSB, effectControl1LSB, effectControl2LSB, generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB :: T -- ** controllers of sound and global effects sustain, portamento, sustenuto, softPedal, legato, hold2, soundController1, soundController2, soundController3, soundController4, soundController5, soundController6, soundController7, soundController8, soundController9, soundController10, generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, portamentoControl, effect1Depth, effect2Depth, effect3Depth, effect4Depth, effect5Depth :: T -- ** increment/decrement and parameter numbers dataIncrement, dataDecrement, nonRegisteredParameterLSB, nonRegisteredParameterMSB, registeredParameterLSB, registeredParameterMSB :: T bankSelectMSB = toEnum 0x00 {- 00 00 -} modulationMSB = toEnum 0x01 {- 01 01 -} breathControlMSB = toEnum 0x02 {- 02 02 -} footControlMSB = toEnum 0x04 {- 04 04 -} portamentoTimeMSB = toEnum 0x05 {- 05 05 -} dataEntryMSB = toEnum 0x06 {- 06 06 -} volumeMSB = toEnum 0x07 {- 07 07 -} balanceMSB = toEnum 0x08 {- 08 08 -} panoramaMSB = toEnum 0x0A {- 10 0A -} expressionMSB = toEnum 0x0B {- 11 0B -} effectControl1MSB = toEnum 0x0C {- 10 0C -} effectControl2MSB = toEnum 0x0D {- 11 0D -} generalPurpose1MSB = toEnum 0x10 {- 16 10 -} generalPurpose2MSB = toEnum 0x11 {- 17 11 -} generalPurpose3MSB = toEnum 0x12 {- 18 12 -} generalPurpose4MSB = toEnum 0x13 {- 19 13 -} bankSelectLSB = toEnum 0x20 {- 32 20 -} modulationLSB = toEnum 0x21 {- 33 21 -} breathControlLSB = toEnum 0x22 {- 34 22 -} footControlLSB = toEnum 0x24 {- 36 24 -} portamentoTimeLSB = toEnum 0x25 {- 37 25 -} dataEntryLSB = toEnum 0x26 {- 38 26 -} volumeLSB = toEnum 0x27 {- 39 27 -} balanceLSB = toEnum 0x28 {- 40 28 -} panoramaLSB = toEnum 0x2A {- 42 2A -} expressionLSB = toEnum 0x2B {- 43 2B -} effectControl1LSB = toEnum 0x2C {- 44 2C -} effectControl2LSB = toEnum 0x2D {- 45 2D -} generalPurpose1LSB = toEnum 0x30 {- 48 30 -} generalPurpose2LSB = toEnum 0x31 {- 49 31 -} generalPurpose3LSB = toEnum 0x32 {- 50 32 -} generalPurpose4LSB = toEnum 0x33 {- 51 33 -} sustain = toEnum 0x40 {- 64 40 -} portamento = toEnum 0x41 {- 65 41 -} sustenuto = toEnum 0x42 {- 66 42 -} softPedal = toEnum 0x43 {- 67 43 -} legato = toEnum 0x44 {- 68 44 -} hold2 = toEnum 0x45 {- 69 45 -} soundController1 = toEnum 0x46 {- 70 46 -} soundController2 = toEnum 0x47 {- 71 47 -} soundController3 = toEnum 0x48 {- 72 48 -} soundController4 = toEnum 0x49 {- 73 49 -} soundController5 = toEnum 0x4A {- 74 4A -} soundController6 = toEnum 0x4B {- 75 4B -} soundController7 = toEnum 0x4C {- 76 4C -} soundController8 = toEnum 0x4D {- 77 4D -} soundController9 = toEnum 0x4E {- 78 4E -} soundController10 = toEnum 0x4F {- 79 4F -} generalPurpose5 = toEnum 0x50 {- 80 50 -} generalPurpose6 = toEnum 0x51 {- 81 51 -} generalPurpose7 = toEnum 0x52 {- 82 52 -} generalPurpose8 = toEnum 0x53 {- 83 53 -} portamentoControl = toEnum 0x54 {- 84 54 -} effect1Depth = toEnum 0x5B {- 91 5B -} effect2Depth = toEnum 0x5C {- 92 5C -} effect3Depth = toEnum 0x5D {- 93 5D -} effect4Depth = toEnum 0x5E {- 94 5E -} effect5Depth = toEnum 0x5F {- 95 5F -} dataIncrement = toEnum 0x60 {- 96 60 -} dataDecrement = toEnum 0x61 {- 97 61 -} nonRegisteredParameterLSB = toEnum 0x62 {- 98 62 -} nonRegisteredParameterMSB = toEnum 0x63 {- 99 63 -} registeredParameterLSB = toEnum 0x64 {- 100 64 -} registeredParameterMSB = toEnum 0x65 {- 101 65 -} midi-0.2.0.1/src/Sound/MIDI/Utility.hs0000644000000000000000000000646611753275103015400 0ustar0000000000000000module Sound.MIDI.Utility where import qualified Test.QuickCheck as QC import System.Random (Random(randomR), RandomGen) import Data.Word(Word8) {-# INLINE mapFst #-} mapFst :: (a -> c) -> (a,b) -> (c,b) mapFst f ~(x,y) = (f x, y) {-# INLINE mapSnd #-} mapSnd :: (b -> d) -> (a,b) -> (a,d) mapSnd g ~(x,y) = (x, g y) {-# INLINE fst3 #-} fst3 :: (a,b,c) -> a fst3 (x,_,_) = x {-# INLINE snd3 #-} snd3 :: (a,b,c) -> b snd3 (_,x,_) = x {-# INLINE thd3 #-} thd3 :: (a,b,c) -> c thd3 (_,_,x) = x {-# INLINE toMaybe #-} toMaybe :: Bool -> a -> Maybe a toMaybe False _ = Nothing toMaybe True x = Just x {-# INLINE swap #-} swap :: (a,b) -> (b,a) swap (a,b) = (b,a) {-# INLINE checkRange #-} checkRange :: (Bounded a, Ord a, Show a) => String -> (Int -> a) -> Int -> a checkRange typ f x = let y = f x in if minBound <= y && y <= maxBound then y else error (typ ++ ": value " ++ show x ++ " outside range " ++ show ((minBound, maxBound) `asTypeOf` (y,y))) {-# INLINE viewR #-} viewR :: [a] -> Maybe ([a], a) viewR = foldr (\x mxs -> Just (maybe ([],x) (mapFst (x:)) mxs)) Nothing {-# INLINE dropMatch #-} dropMatch :: [b] -> [a] -> [a] dropMatch xs ys = snd $ head $ dropWhile (not . null . fst) $ zip (iterate (drop 1) xs) (iterate (drop 1) ys) {-# INLINE untilM #-} untilM :: Monad m => (a -> Bool) -> m a -> m a untilM p act = let go = act >>= \x -> if p x then return x else go in go {-# INLINE loopM #-} loopM :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m a loopM p preExit postExit = let go = preExit >>= \x -> if p x then return x else postExit x >> go in go -- random generators enumRandomR :: (Enum a, RandomGen g) => (a,a) -> g -> (a,g) enumRandomR (l,r) = mapFst toEnum . randomR (fromEnum l, fromEnum r) boundedEnumRandom :: (Enum a, Bounded a, RandomGen g) => g -> (a,g) boundedEnumRandom = enumRandomR (minBound, maxBound) chooseEnum :: (Enum a, Bounded a, Random a) => QC.Gen a chooseEnum = QC.choose (minBound, maxBound) quantityRandomR :: (Random b, RandomGen g) => (a -> b) -> (b -> a) -> (a,a) -> g -> (a,g) quantityRandomR fromQuantity toQuantity (l,r) = mapFst toQuantity . randomR (fromQuantity l, fromQuantity r) boundedQuantityRandom :: (Bounded a, Random b, RandomGen g) => (a -> b) -> (b -> a) -> g -> (a,g) boundedQuantityRandom fromQuantity toQuantity = quantityRandomR fromQuantity toQuantity (minBound, maxBound) chooseQuantity :: (Bounded a, Random b) => (a -> b) -> (b -> a) -> QC.Gen a chooseQuantity fromQuantity toQuantity = fmap toQuantity $ QC.choose (fromQuantity minBound, fromQuantity maxBound) newtype ArbChar = ArbChar {deconsArbChar :: Char} instance QC.Arbitrary ArbChar where arbitrary = fmap ArbChar $ QC.frequency [(26, QC.choose ('a','z')), (26, QC.choose ('A','Z')), (10, QC.choose ('0','9'))] arbitraryString :: QC.Gen String arbitraryString = fmap (map deconsArbChar) QC.arbitrary newtype ArbByte = ArbByte {deconsArbByte :: Word8} instance QC.Arbitrary ArbByte where arbitrary = fmap (ArbByte . fromIntegral) $ QC.choose (0,0xFF::Int) arbitraryByteList :: QC.Gen [Word8] -- ByteList arbitraryByteList = fmap (map deconsArbByte) QC.arbitrary midi-0.2.0.1/src/Sound/MIDI/ControllerPrivate.hs0000644000000000000000000000241511753275103017401 0ustar0000000000000000module Sound.MIDI.ControllerPrivate where import Data.Ix (Ix) import Sound.MIDI.Utility (checkRange, enumRandomR, boundedEnumRandom, chooseEnum, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), ) {- | We do not define 'Controller' as enumeration with many constructors, because some controllers have multiple names and some are undefined. It is also more efficient this way. Thus you cannot use @case@ for processing controller types, but you can use 'Data.List.lookup' instead. > maybe (putStrLn "unsupported controller") putStrLn $ > lookup ctrl $ > (portamento, "portamento") : > (modulation, "modulation") : > [] -} newtype Controller = Controller {fromController :: Int} deriving (Show, Eq, Ord, Ix) toController :: Int -> Controller toController = checkRange "Controller" Controller instance Random Controller where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Controller where arbitrary = chooseEnum instance Enum Controller where toEnum = toController fromEnum = fromController instance Bounded Controller where minBound = Controller 0 maxBound = Controller 119 -- higher controller numbers have special meanings midi-0.2.0.1/src/Sound/MIDI/File.hs0000644000000000000000000002164011753275103014603 0ustar0000000000000000{- | MIDI-File Datatype Taken from Haskore. -} module Sound.MIDI.File( T(..), Division(..), Track, Type(..), empty, ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, explicitNoteOff, implicitNoteOff, getTracks, mergeTracks, secondsFromTicks, ticksPerQuarterNote, showLines, changeVelocity, resampleTime, showEvent, showTime, sortEvents, progChangeBeforeSetTempo, ) where import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as Event import Sound.MIDI.File.Event.Meta ( ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, ) import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Class as NonNeg import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM, liftM2, ) -- import Sound.MIDI.IO(ByteList) import Sound.MIDI.String (rightS, ) import Data.Ratio((%)) import Data.Ix(Ix) import Data.List(groupBy, sort) import Data.Maybe(fromMaybe) {- | The datatypes for MIDI Files and MIDI Events -} data T = Cons Type Division [Track] deriving (Show, Eq) data Type = Mixed | Parallel | Serial deriving (Show, Eq, Ord, Ix, Enum, Bounded) data Division = Ticks Tempo | SMPTE Int Int deriving (Show, Eq) type Track = EventList.T ElapsedTime Event.T {- | An empty MIDI file. Tempo is set to one tick per quarter note. -} empty :: T empty = Cons Mixed (Ticks 1) [EventList.empty] instance Arbitrary T where arbitrary = do (typ, content) <- QC.oneof $ fmap (\track -> (Mixed, [track])) arbitrary : fmap (\tracks -> (Parallel, tracks)) arbitrary : fmap (\tracks -> (Serial, tracks)) arbitrary : [] division <- arbitrary return (Cons typ division content) instance Arbitrary Division where arbitrary = QC.oneof $ liftM (Ticks . (1+)) arbitrary : liftM2 (\x y -> SMPTE (1+abs x) (1+abs y)) arbitrary arbitrary : [] {- * Processing -} {- | Apply a function to each track. -} mapTrack :: (Track -> Track) -> T -> T mapTrack f (Cons mfType division tracks) = Cons mfType division (map f tracks) {- | Convert all @NoteOn p 0@ to @NoteOff p 64@. The latter one is easier to process. -} explicitNoteOff :: T -> T explicitNoteOff = mapTrack (EventList.mapBody (Event.mapVoice VoiceMsg.explicitNoteOff)) {- | Convert all @NoteOff p 64@ to @NoteOn p 0@. The latter one can be encoded more efficiently using the running status. -} implicitNoteOff :: T -> T implicitNoteOff = mapTrack (EventList.mapBody (Event.mapVoice VoiceMsg.implicitNoteOff)) getTracks :: T -> [Track] getTracks (Cons _ _ trks) = trks {- | Merge all tracks into a single track according to the MIDI file type. -} mergeTracks :: (NonNeg.C time) => Type -> [EventList.T time event] -> EventList.T time event mergeTracks typ tracks = case typ of Mixed -> foldr (EventList.mergeBy (\_ _ -> True)) EventList.empty tracks Parallel -> foldr (EventList.mergeBy (\_ _ -> True)) EventList.empty tracks Serial -> EventList.concat tracks {- | Process and remove all @SetTempo@ events. The result is an event list where the times are measured in seconds. -} secondsFromTicks :: Division -> EventList.T ElapsedTime Event.T -> EventList.T NonNegW.Rational Event.T secondsFromTicks division = EventList.catMaybes . flip MS.evalState MetaEvent.defltTempo . EventList.mapM (\ticks -> do microsPerQN <- MS.get -- cf. Standard MIDI Files 1.0, page 14 return $ NonNegW.fromNumberMsg "MIDI.File.processTempo" $ fromElapsedTime ticks * fromIntegral (NonNegW.toNumber microsPerQN) % (1000000 * fromIntegral (NonNegW.toNumber (ticksPerQuarterNote division)))) (\ev -> case ev of Event.MetaEvent (MetaEvent.SetTempo microsPerQN) -> MS.put microsPerQN >> return Nothing _ -> return $ Just ev) ticksPerQuarterNote :: Division -> Tempo ticksPerQuarterNote division = case division of Ticks ticksPerQN -> ticksPerQN SMPTE framesPerSecond ticksPerFrames -> {- I am uncertain, whether this is correct. The "Standard MIDI File 1.0" is unprecise with respect to the question, whether SetTempo is relevant also in SMPTE mode. TiMidity-2.13.2 interprets this kind of division as we do and qualifies it as "totally untested". -} NonNegW.fromNumberMsg "MIDI.File.ticksPerQuarterNote" $ framesPerSecond * ticksPerFrames {- * Debugging -} {-# DEPRECATED showLines, changeVelocity, resampleTime, showEvent, showTime, sortEvents, progChangeBeforeSetTempo "only use this for debugging" #-} {- | Show the 'T' with one event per line, suited for comparing MIDIFiles with @diff@. Can this be replaced by 'Sound.MIDI.Load.showFile'? -} showLines :: T -> String showLines (Cons mfType division tracks) = let showTrack track = unlines (" (" : map (\event -> " " ++ show event ++ " :") (EventList.toPairList track) ++ " []) :" : []) in "MIDIFile.Cons " ++ show mfType ++ " (" ++ show division ++ ") (\n" ++ concatMap showTrack tracks ++ " [])" showTime :: ElapsedTime -> ShowS showTime t = rightS 10 (shows t) . showString " : " showEvent :: Event.T -> ShowS showEvent (Event.MIDIEvent e) = showString "Event.MIDIEvent " . shows e showEvent (Event.MetaEvent e) = showString "Event.MetaEvent " . shows e showEvent (Event.SystemExclusive s) = showString "SystemExclusive " . shows s {- | A hack that changes the velocities by a rational factor. -} changeVelocity :: Double -> T -> T changeVelocity r = let multVel vel = VoiceMsg.toVelocity $ round (r * fromIntegral (VoiceMsg.fromVelocity vel)) procVoice (VoiceMsg.NoteOn pitch vel) = VoiceMsg.NoteOn pitch (multVel vel) procVoice (VoiceMsg.NoteOff pitch vel) = VoiceMsg.NoteOff pitch (multVel vel) procVoice me = me in mapTrack (EventList.mapBody (Event.mapVoice procVoice)) {- | Change the time base. -} resampleTime :: Double -> T -> T resampleTime r = let divTime time = round (fromIntegral time / r) newTempo tmp = round (fromIntegral tmp * r) procEvent ev = case ev of Event.MetaEvent (MetaEvent.SetTempo tmp) -> Event.MetaEvent (MetaEvent.SetTempo (newTempo tmp)) _ -> ev in mapTrack (EventList.mapBody procEvent . EventList.mapTime divTime) {- | Sort MIDI note events lexicographically. This is to make MIDI files unique and robust against changes in the computation. In principle Performance.merge should handle this but due to rounding errors in Float the order of note events still depends on some internal issues. The sample rate of MIDI events should be coarse enough to assert unique results. -} sortEvents :: T -> T sortEvents = let coincideNote ev0 ev1 = fromMaybe False $ do (_,x0) <- Event.maybeVoice ev0 (_,x1) <- Event.maybeVoice ev1 return (VoiceMsg.isNote x0 && VoiceMsg.isNote x1) {- coincideNote (Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice x0))) (Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice x1))) = VoiceMsg.isNote x0 && VoiceMsg.isNote x1 coincideNote _ _ = False -} sortTrack = EventList.flatten . EventList.mapBody sort . EventList.mapCoincident (groupBy coincideNote) in mapTrack sortTrack {- | Old versions of "Haskore.Interface.MIDI.Write" wrote 'MIDIEvent.ProgramChange' and 'MetaEvent.SetTempo' once at the beginning of a file in that order. The current version supports multiple 'MIDIEvent.ProgramChange's in a track and thus a 'MIDIEvent.ProgramChange' is set immediately before a note. Because of this a 'MIDIEvent.ProgramChange' is now always after a 'MetaEvent.SetTempo'. For checking equivalence with old MIDI files we can switch this back. -} progChangeBeforeSetTempo :: T -> T progChangeBeforeSetTempo = let sortTrack evs = do ((t0,st@(Event.MetaEvent (MetaEvent.SetTempo _))), rest0) <- EventList.viewL evs ((t1,pc@(Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice (VoiceMsg.ProgramChange _))))), rest1) <- EventList.viewL rest0 return $ EventList.cons t0 pc $ EventList.cons 0 st $ EventList.delay t1 rest1 in mapTrack (\track -> fromMaybe track (sortTrack track)) midi-0.2.0.1/src/Sound/MIDI/Monoid.hs0000644000000000000000000000100311753275103015140 0ustar0000000000000000module Sound.MIDI.Monoid where import Data.Monoid (Monoid, mappend, mconcat, ) import Prelude hiding (concatMap, ) infixr 5 +#+ (+#+) :: Monoid m => m -> m -> m (+#+) = mappend genAppend :: (Monoid m) => (m -> a) -> (a -> m) -> a -> a -> a genAppend cons decons x y = cons $ mappend (decons x) (decons y) genConcat :: (Monoid m) => (m -> a) -> (a -> m) -> [a] -> a genConcat cons decons = cons . concatMap decons concatMap :: (Monoid m) => (a -> m) -> [a] -> m concatMap f = mconcat . map f midi-0.2.0.1/src/Sound/MIDI/General.hs0000644000000000000000000002403011753275103015275 0ustar0000000000000000{- | General-MIDI definitions. Taken from Haskore. -} module Sound.MIDI.General where import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import Sound.MIDI.Message.Channel (Channel, toChannel, ) import Data.Ix(Ix) import qualified Data.List as List import Sound.MIDI.Utility (mapSnd, enumRandomR, boundedEnumRandom, chooseEnum, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import System.Random (Random(random,randomR), ) {- * Instrument definitions -} instrumentNameToProgram :: String -> Maybe VoiceMsg.Program instrumentNameToProgram = fmap VoiceMsg.toProgram . flip List.elemIndex instrumentNames instrumentNames :: [String] instrumentNames = map fst instrumentPrograms instrumentPrograms :: [(String, VoiceMsg.Program)] instrumentPrograms = map (mapSnd VoiceMsg.toProgram) [ ("Acoustic Grand Piano",0), ("Bright Acoustic Piano",1), ("Electric Grand Piano",2), ("Honky Tonk Piano",3), ("Rhodes Piano",4), ("Chorused Piano",5), ("Harpsichord",6), ("Clavinet",7), ("Celesta",8), ("Glockenspiel",9), ("Music Box",10), ("Vibraphone",11), ("Marimba",12), ("Xylophone",13), ("Tubular Bells",14), ("Dulcimer",15), ("Hammond Organ",16), ("Percussive Organ",17), ("Rock Organ",18), ("Church Organ",19), ("Reed Organ",20), ("Accordion",21), ("Harmonica",22), ("Tango Accordion",23), ("Acoustic Guitar (nylon)",24), ("Acoustic Guitar (steel)",25), ("Electric Guitar (jazz)",26), ("Electric Guitar (clean)",27), ("Electric Guitar (muted)",28), ("Overdriven Guitar",29), ("Distortion Guitar",30), ("Guitar Harmonics",31), ("Acoustic Bass",32), ("Electric Bass (fingered)",33), ("Electric Bass (picked)",34), ("Fretless Bass",35), ("Slap Bass 1",36), ("Slap Bass 2",37), ("Synth Bass 1",38), ("Synth Bass 2",39), ("Violin",40), ("Viola",41), ("Cello",42), ("Contrabass",43), ("Tremolo Strings",44), ("Pizzicato Strings",45), ("Orchestral Harp",46), ("Timpani",47), ("String Ensemble 1",48), ("String Ensemble 2",49), ("Synth Strings 1",50), ("Synth Strings 2",51), ("Choir Aahs",52), ("Voice Oohs",53), ("Synth Voice",54), ("Orchestra Hit",55), ("Trumpet",56), ("Trombone",57), ("Tuba",58), ("Muted Trumpet",59), ("French Horn",60), ("Brass Section",61), ("Synth Brass 1",62), ("Synth Brass 2",63), ("Soprano Sax",64), ("Alto Sax",65), ("Tenor Sax",66), ("Baritone Sax",67), ("Oboe",68), ("Bassoon",69), ("English Horn",70), ("Clarinet",71), ("Piccolo",72), ("Flute",73), ("Recorder",74), ("Pan Flute",75), ("Blown Bottle",76), ("Shakuhachi",77), ("Whistle",78), ("Ocarina",79), ("Lead 1 (square)",80), ("Lead 2 (sawtooth)",81), ("Lead 3 (calliope)",82), ("Lead 4 (chiff)",83), ("Lead 5 (charang)",84), ("Lead 6 (voice)",85), ("Lead 7 (fifths)",86), ("Lead 8 (bass+lead)",87), ("Pad 1 (new age)",88), ("Pad 2 (warm)",89), ("Pad 3 (polysynth)",90), ("Pad 4 (choir)",91), ("Pad 5 (bowed)",92), ("Pad 6 (metallic)",93), ("Pad 7 (halo)",94), ("Pad 8 (sweep)",95), ("FX1 (train)",96), ("FX2 (soundtrack)",97), ("FX3 (crystal)",98), ("FX4 (atmosphere)",99), ("FX5 (brightness)",100), ("FX6 (goblins)",101), ("FX7 (echoes)",102), ("FX8 (sci-fi)",103), ("Sitar",104), ("Banjo",105), ("Shamisen",106), ("Koto",107), ("Kalimba",108), ("Bagpipe",109), ("Fiddle",110), ("Shanai",111), ("Tinkle Bell",112), ("Agogo",113), ("Steel Drums",114), ("Woodblock",115), ("Taiko Drum",116), ("Melodic Drum",117), ("Synth Drum",118), ("Reverse Cymbal",119), ("Guitar Fret Noise",120), ("Breath Noise",121), ("Seashore",122), ("Bird Tweet",123), ("Telephone Ring",124), ("Helicopter",125), ("Applause",126), ("Gunshot",127) ] instrumentFromProgram :: VoiceMsg.Program -> Instrument instrumentFromProgram = toEnum . VoiceMsg.fromProgram instrumentToProgram :: Instrument -> VoiceMsg.Program instrumentToProgram = VoiceMsg.toProgram . fromEnum instrumentChannels :: [Channel] instrumentChannels = map toChannel $ [0..8] ++ [10..15] instruments :: [Instrument] instruments = enumFromTo minBound maxBound data Instrument = AcousticGrandPiano | BrightAcousticPiano | ElectricGrandPiano | HonkyTonk | ElectricPiano1 | ElectricPiano2 | Harpsichord | Clavinet | Celesta | Glockenspiel | MusicBox | Vibraphone | Marimba | Xylophone | TubularBells | Dulcimer | DrawbarOrgan | PercussiveOrgan | RockOrgan | ChurchOrgan | ReedOrgan | Accordion | Harmonica | TangoAccordian | AcousticGuitarNylon | AcousticGuitarSteel | ElectricGuitarJazz | ElectricGuitarClean | ElectricGuitarMuted | OverdrivenGuitar | DistortionGuitar | GuitarHarmonics | AcousticBass | ElectricBassFinger | ElectricBassPick | FretlessBass | SlapBass1 | SlapBass2 | SynthBass1 | SynthBass2 | Violin | Viola | Cello | Contrabass | TremoloStrings | PizzicatoStrings | OrchestralHarp | Timpani | StringEnsemble1 | StringEnsemble2 | SynthStrings1 | SynthStrings2 | ChoirAahs | VoiceOohs | SynthVoice | OrchestraHit | Trumpet | Trombone | Tuba | MutedTrumpet | FrenchHorn | BrassSection | SynthBrass1 | SynthBrass2 | SopranoSax | AltoSax | TenorSax | BaritoneSax | Oboe | EnglishHorn | Bassoon | Clarinet | Piccolo | Flute | Recorder | PanFlute | BlownBottle | Skakuhachi | Whistle | Ocarina | Lead1Square | Lead2Sawtooth | Lead3Calliope | Lead4Chiff | Lead5Charang | Lead6Voice | Lead7Fifths | Lead8BassLead | Pad1NewAge | Pad2Warm | Pad3Polysynth | Pad4Choir | Pad5Bowed | Pad6Metallic | Pad7Halo | Pad8Sweep | FX1Rain | FX2Soundtrack | FX3Crystal | FX4Atmosphere | FX5Brightness | FX6Goblins | FX7Echoes | FX8SciFi | Sitar | Banjo | Shamisen | Koto | Kalimba | Bagpipe | Fiddle | Shanai | TinkleBell | Agogo | SteelDrums | Woodblock | TaikoDrum | MelodicTom | SynthDrum | ReverseCymbal | GuitarFretNoise | BreathNoise | Seashore | BirdTweet | TelephoneRing | Helicopter | Applause | Gunshot deriving (Show, Eq, Ord, Ix, Enum, Bounded) instance Random Instrument where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Instrument where arbitrary = chooseEnum {- * Drum definitions -} drumChannel :: Channel drumChannel = toChannel 9 drumProgram :: VoiceMsg.Program drumProgram = VoiceMsg.toProgram 0 drumMinKey :: VoiceMsg.Pitch drumMinKey = VoiceMsg.toPitch 35 drumKeyTable :: [(Drum, VoiceMsg.Pitch)] drumKeyTable = zip drums [drumMinKey ..] drumFromKey :: VoiceMsg.Pitch -> Drum drumFromKey = toEnum . VoiceMsg.subtractPitch drumMinKey drumToKey :: Drum -> VoiceMsg.Pitch drumToKey = flip VoiceMsg.increasePitch drumMinKey . fromEnum drums :: [Drum] drums = enumFromTo minBound maxBound data Drum = AcousticBassDrum -- Midi Key 35 | BassDrum1 -- Midi Key 36 | SideStick -- ... | AcousticSnare | HandClap | ElectricSnare | LowFloorTom | ClosedHiHat | HighFloorTom | PedalHiHat | LowTom | OpenHiHat | LowMidTom | HiMidTom | CrashCymbal1 | HighTom | RideCymbal1 | ChineseCymbal | RideBell | Tambourine | SplashCymbal | Cowbell | CrashCymbal2 | Vibraslap | RideCymbal2 | HiBongo | LowBongo | MuteHiConga | OpenHiConga | LowConga | HighTimbale | LowTimbale | HighAgogo | LowAgogo | Cabasa | Maracas | ShortWhistle | LongWhistle | ShortGuiro | LongGuiro | Claves | HiWoodBlock | LowWoodBlock | MuteCuica | OpenCuica | MuteTriangle | OpenTriangle -- Midi Key 81 deriving (Show, Eq, Ord, Ix, Enum, Bounded) -- http://oxygen.cside6.com/gallery/ins_gm.html instance Random Drum where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Drum where arbitrary = chooseEnum midi-0.2.0.1/src/Sound/MIDI/Manufacturer.hs0000644000000000000000000003357111753275103016366 0ustar0000000000000000{- | MIDI device manufacturers and their id's. -} module Sound.MIDI.Manufacturer (T, get, put, sequential, idp, octavePlateau, moog, passport, lexicon, kurzweil, fender, gulbransen, akg, voyce, waveframe, ada, garfield, ensoniq, oberheim, apple, greyMatter, digidesign, palmTree, jlCooper, lowrey, adamsSmith, emu, harmony, art, baldwin, eventide, inventronics, keyConcepts, clarity, timeWarner, digitalMusic, iota, newEngland, artisyn, ivl, southernMusic, lakeButler, alesis, dod, studerEditech, perfectFret, kat, opcode, rane, anadi, kmx, brenell, peavey, systems360, spectrum, marquis, zeta, axxes, orban, kti, breakaway, cae, rocktron, pianoDisc, cannon, rogers, blueSkyLogic, encore, uptown, voce, cti, ssResearch, broderbund, allenOrgan, musicQuest, aphex, gallienKrueger, ibm, hotzInstruments, etaLighting, nsi, adLib, richmond, microsoft, softwareToolworks, rjmgNiche, intone, grooveTubes, euphonix, interMIDI, loneWolf, musonix, taHorng, eTek, electrovoice, midisoft, qSoundLabs, westrex, nVidia, ess, mediaTrix, brooktree, otari, keyElectronics, crystalake, crystal, rockwell, siliconGraphics, midiman, preSonus, topaz, castLighting, microsoftConsumer, fastForward, headspace, vanKoevering, altech, vlsi, chromaticResearch, sapphire, idrc, justonic, torComp, newtek, soundSculpture, walker, pavo, inVision, tSquareDesign, nemesys, dbx, syndyne, bitheadz, cakewalk, staccato, nationalSemiconductor, boomTheory, virtualDSP, antares, angelSoftware, stLouis, lyrrus, passac, siel, synthaxe, hohner, twister, solton, jellinghaus, southworth, ppg, jen, ssl, audioVeritrieb, elka, dynacord, viscount, clavia, audioArchitect, generalMusic, soundcraft, wersi, avab, digigram, waldorf, quasimidi, dream, strandLighting, amek, drBohm, trident, realWorldDesign, yesTechnology, audiomatica, bontempiFarfisa, fbtElectronica, miditemp, larkingAudio, zero88lighting, miconAudio, forefront, kenton, adb, jimMarshall, dda, bssAudio, tcElectronic, medeli, charlieLab, blueChip, beeOH, lgSemiconductor, tesi, emagic, behringer, access, synoptic, hanmesoft, terratec, proel, ibk, kawai, roland, korg, yamaha, casio, kamiya, akai, japanVictor, mesosha, hoshinoGakki, fujitsuElect, sony, nisshinOnpa, teac, matsushitaElec, fostex, zoom, midori, matsushitaComm, suzuki, nonCommercial, nonRealTime, realTime, ) where import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) import Control.Monad (liftM2, ) import Data.Word (Word8) data T = Short Word8 | Extended Word8 Word8 deriving (Show, Eq, Ord) -- * North American Group sequential, idp, octavePlateau, moog, passport, lexicon, kurzweil, fender, gulbransen, akg, voyce, waveframe, ada, garfield, ensoniq, oberheim, apple, greyMatter, digidesign, palmTree, jlCooper, lowrey, adamsSmith, emu, harmony, art, baldwin, eventide, inventronics, keyConcepts, clarity, timeWarner, digitalMusic, iota, newEngland, artisyn, ivl, southernMusic, lakeButler, alesis, dod, studerEditech, perfectFret, kat, opcode, rane, anadi, kmx, brenell, peavey, systems360, spectrum, marquis, zeta, axxes, orban, kti, breakaway, cae, rocktron, pianoDisc, cannon, rogers, blueSkyLogic, encore, uptown, voce, cti, ssResearch, broderbund, allenOrgan, musicQuest, aphex, gallienKrueger, ibm, hotzInstruments, etaLighting, nsi, adLib, richmond, microsoft, softwareToolworks, rjmgNiche, intone, grooveTubes, euphonix, interMIDI, loneWolf, musonix, taHorng, eTek, electrovoice, midisoft, qSoundLabs, westrex, nVidia, ess, mediaTrix, brooktree, otari, keyElectronics, crystalake, crystal, rockwell, siliconGraphics, midiman, preSonus, topaz, castLighting, microsoftConsumer, fastForward, headspace, vanKoevering, altech, vlsi, chromaticResearch, sapphire, idrc, justonic, torComp, newtek, soundSculpture, walker, pavo, inVision, tSquareDesign, nemesys, dbx, syndyne, bitheadz, cakewalk, staccato, nationalSemiconductor, boomTheory, virtualDSP, antares, angelSoftware, stLouis, lyrrus :: T sequential = Short 0x01 idp = Short 0x02 octavePlateau = Short 0x03 moog = Short 0x04 passport = Short 0x05 lexicon = Short 0x06 kurzweil = Short 0x07 fender = Short 0x08 gulbransen = Short 0x09 akg = Short 0x0A voyce = Short 0x0B waveframe = Short 0x0C ada = Short 0x0D garfield = Short 0x0E ensoniq = Short 0x0F oberheim = Short 0x10 apple = Short 0x11 greyMatter = Short 0x12 digidesign = Short 0x13 palmTree = Short 0x14 jlCooper = Short 0x15 lowrey = Short 0x16 adamsSmith = Short 0x17 emu = Short 0x18 harmony = Short 0x19 art = Short 0x1A baldwin = Short 0x1B eventide = Short 0x1C inventronics = Short 0x1D keyConcepts = Short 0x1E clarity = Short 0x1F timeWarner = Extended 0x00 0x01 digitalMusic = Extended 0x00 0x07 iota = Extended 0x00 0x08 newEngland = Extended 0x00 0x09 artisyn = Extended 0x00 0x0A ivl = Extended 0x00 0x0B southernMusic = Extended 0x00 0x0C lakeButler = Extended 0x00 0x0D alesis = Extended 0x00 0x0E dod = Extended 0x00 0x10 studerEditech = Extended 0x00 0x11 perfectFret = Extended 0x00 0x14 kat = Extended 0x00 0x15 opcode = Extended 0x00 0x16 rane = Extended 0x00 0x17 anadi = Extended 0x00 0x18 -- spatialSound ? kmx = Extended 0x00 0x19 brenell = Extended 0x00 0x1A peavey = Extended 0x00 0x1B systems360 = Extended 0x00 0x1C spectrum = Extended 0x00 0x1D marquis = Extended 0x00 0x1E zeta = Extended 0x00 0x1F axxes = Extended 0x00 0x20 orban = Extended 0x00 0x21 kti = Extended 0x00 0x24 breakaway = Extended 0x00 0x25 cae = Extended 0x00 0x26 rocktron = Extended 0x00 0x29 pianoDisc = Extended 0x00 0x2A cannon = Extended 0x00 0x2B rogers = Extended 0x00 0x2D blueSkyLogic = Extended 0x00 0x2E encore = Extended 0x00 0x2F uptown = Extended 0x00 0x30 voce = Extended 0x00 0x31 cti = Extended 0x00 0x32 ssResearch = Extended 0x00 0x33 broderbund = Extended 0x00 0x34 allenOrgan = Extended 0x00 0x35 musicQuest = Extended 0x00 0x37 aphex = Extended 0x00 0x38 gallienKrueger = Extended 0x00 0x39 ibm = Extended 0x00 0x3A hotzInstruments = Extended 0x00 0x3C etaLighting = Extended 0x00 0x3D nsi = Extended 0x00 0x3E adLib = Extended 0x00 0x3F richmond = Extended 0x00 0x40 microsoft = Extended 0x00 0x41 softwareToolworks = Extended 0x00 0x42 rjmgNiche = Extended 0x00 0x43 intone = Extended 0x00 0x44 grooveTubes = Extended 0x00 0x47 euphonix = Extended 0x00 0x4E interMIDI = Extended 0x00 0x4F loneWolf = Extended 0x00 0x55 musonix = Extended 0x00 0x64 taHorng = Extended 0x00 0x74 eTek = Extended 0x00 0x75 -- formerly Forte electrovoice = Extended 0x00 0x76 midisoft = Extended 0x00 0x77 qSoundLabs = Extended 0x00 0x78 westrex = Extended 0x00 0x79 nVidia = Extended 0x00 0x7A ess = Extended 0x00 0x7B mediaTrix = Extended 0x00 0x7C brooktree = Extended 0x00 0x7D otari = Extended 0x00 0x7E keyElectronics = Extended 0x00 0x7F crystalake = Extended 0x01 0x01 crystal = Extended 0x01 0x02 rockwell = Extended 0x01 0x03 siliconGraphics = Extended 0x01 0x04 midiman = Extended 0x01 0x05 preSonus = Extended 0x01 0x06 topaz = Extended 0x01 0x08 castLighting = Extended 0x01 0x09 microsoftConsumer = Extended 0x01 0x0A fastForward = Extended 0x01 0x0C headspace = Extended 0x01 0x0D -- Igor's Labs vanKoevering = Extended 0x01 0x0E altech = Extended 0x01 0x0F -- ssResearch = Extended 0x01 0x10 vlsi = Extended 0x01 0x11 chromaticResearch = Extended 0x01 0x12 sapphire = Extended 0x01 0x13 idrc = Extended 0x01 0x14 justonic = Extended 0x01 0x15 torComp = Extended 0x01 0x16 newtek = Extended 0x01 0x17 soundSculpture = Extended 0x01 0x18 walker = Extended 0x01 0x19 pavo = Extended 0x01 0x1A inVision = Extended 0x01 0x1B tSquareDesign = Extended 0x01 0x1C nemesys = Extended 0x01 0x1D dbx = Extended 0x01 0x1E syndyne = Extended 0x01 0x1F bitheadz = Extended 0x01 0x20 cakewalk = Extended 0x01 0x21 staccato = Extended 0x01 0x22 nationalSemiconductor = Extended 0x01 0x23 boomTheory = Extended 0x01 0x24 -- Adinolfi Alternative Percussion virtualDSP = Extended 0x01 0x25 antares = Extended 0x01 0x26 angelSoftware = Extended 0x01 0x27 stLouis = Extended 0x01 0x28 lyrrus = Extended 0x01 0x29 -- * European Group passac, siel, synthaxe, hohner, twister, solton, jellinghaus, southworth, ppg, jen, ssl, audioVeritrieb, elka, dynacord, viscount, clavia, audioArchitect, generalMusic, soundcraft, wersi, avab, digigram, waldorf, quasimidi, dream, strandLighting, amek, drBohm, trident, realWorldDesign, yesTechnology, audiomatica, bontempiFarfisa, fbtElectronica, miditemp, larkingAudio, zero88lighting, miconAudio, forefront, kenton, adb, jimMarshall, dda, bssAudio, tcElectronic, medeli, charlieLab, blueChip, beeOH, lgSemiconductor, tesi, emagic, behringer, access, synoptic, hanmesoft, terratec, proel, ibk :: T passac = Short 0x20 siel = Short 0x21 synthaxe = Short 0x22 hohner = Short 0x24 twister = Short 0x25 solton = Short 0x26 jellinghaus = Short 0x27 southworth = Short 0x28 ppg = Short 0x29 jen = Short 0x2A ssl = Short 0x2B audioVeritrieb = Short 0x2C elka = Short 0x2F dynacord = Short 0x30 viscount = Short 0x31 clavia = Short 0x33 audioArchitect = Short 0x34 generalMusic = Short 0x35 soundcraft = Short 0x39 wersi = Short 0x3B avab = Short 0x3C digigram = Short 0x3D waldorf = Short 0x3E quasimidi = Short 0x3F dream = Extended 0x20 0x00 strandLighting = Extended 0x20 0x01 amek = Extended 0x20 0x02 drBohm = Extended 0x20 0x04 trident = Extended 0x20 0x06 realWorldDesign = Extended 0x20 0x07 yesTechnology = Extended 0x20 0x09 audiomatica = Extended 0x20 0x0A bontempiFarfisa = Extended 0x20 0x0B fbtElectronica = Extended 0x20 0x0C miditemp = Extended 0x20 0x0D larkingAudio = Extended 0x20 0x0E zero88lighting = Extended 0x20 0x0F miconAudio = Extended 0x20 0x10 forefront = Extended 0x20 0x11 kenton = Extended 0x20 0x13 adb = Extended 0x20 0x15 jimMarshall = Extended 0x20 0x16 dda = Extended 0x20 0x17 bssAudio = Extended 0x20 0x18 tcElectronic = Extended 0x20 0x1F medeli = Extended 0x20 0x2B charlieLab = Extended 0x20 0x2C blueChip = Extended 0x20 0x2D beeOH = Extended 0x20 0x2E lgSemiconductor = Extended 0x20 0x2F tesi = Extended 0x20 0x30 emagic = Extended 0x20 0x31 behringer = Extended 0x20 0x32 access = Extended 0x20 0x33 synoptic = Extended 0x20 0x34 hanmesoft = Extended 0x20 0x35 terratec = Extended 0x20 0x36 proel = Extended 0x20 0x37 ibk = Extended 0x20 0x38 -- * Japanese Group kawai, roland, korg, yamaha, casio, kamiya, akai, japanVictor, mesosha, hoshinoGakki, fujitsuElect, sony, nisshinOnpa, teac, matsushitaElec, fostex, zoom, midori, matsushitaComm, suzuki :: T kawai = Short 0x40 roland = Short 0x41 korg = Short 0x42 yamaha = Short 0x43 casio = Short 0x44 kamiya = Short 0x46 akai = Short 0x47 japanVictor = Short 0x48 mesosha = Short 0x49 hoshinoGakki = Short 0x4A fujitsuElect = Short 0x4B sony = Short 0x4C nisshinOnpa = Short 0x4D teac = Short 0x4E matsushitaElec = Short 0x50 fostex = Short 0x51 zoom = Short 0x52 midori = Short 0x53 matsushitaComm = Short 0x54 suzuki = Short 0x55 -- * Universal ID Numbers nonCommercial, nonRealTime, realTime :: T nonCommercial = Short 0x7D nonRealTime = Short 0x7E realTime = Short 0x7F -- * serialization get :: Parser.C parser => Parser.Fallible parser T get = do subId <- getByte if subId == 0 then liftM2 Extended getByte getByte else return $ Short subId put :: Writer.C writer => T -> writer put subId = case subId of Short n -> Writer.putByte n Extended hi lo -> Writer.putByte 0 +#+ Writer.putByte hi +#+ Writer.putByte lo midi-0.2.0.1/src/Sound/MIDI/Message.hs0000644000000000000000000000504111753275103015305 0ustar0000000000000000{- | MIDI messages for real-time communication with MIDI devices. This does not cover MIDI file events. For these refer to "Sound.MIDI.File.Event". -} module Sound.MIDI.Message ( T(..), get, getWithStatus, getIncompleteWithStatus, put, putWithStatus, maybeFromByteString, toByteString, ) where import qualified Sound.MIDI.Message.Channel as Channel import qualified Sound.MIDI.Message.System as System import qualified Sound.MIDI.Parser.Status as StatusParser import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Primitive (get1) import qualified Sound.MIDI.Parser.ByteString as ParserByteString import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) import qualified Sound.MIDI.Parser.Report as Report import qualified Control.Monad.Exception.Asynchronous as Async import Control.Monad (liftM, ) import qualified Data.ByteString.Lazy as B data T = Channel Channel.T | System System.T -- Show instance requires Show instance of System.T -- deriving (Show) get :: Parser.C parser => Parser.Fallible parser T get = get1 >>= \code -> if code >= 0xF0 then liftM System $ System.get code else liftM Channel $ (uncurry Channel.get (Channel.decodeStatus code) =<< get1) -- else liftM Channel $ StatusParser.run (Channel.getWithStatus code) getWithStatus :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T getWithStatus = StatusParser.lift get1 >>= \code -> if code >= 0xF0 then StatusParser.set Nothing >> (liftM System $ StatusParser.lift $ System.get code) else liftM Channel $ Channel.getWithStatus code getIncompleteWithStatus :: Parser.C parser => Parser.Partial (Parser.Fallible (StatusParser.T parser)) T getIncompleteWithStatus = StatusParser.lift get1 >>= \code -> if code >= 0xF0 then liftM (fmap System) $ StatusParser.lift $ System.getIncomplete code else liftM (Async.pure . Channel) $ Channel.getWithStatus code maybeFromByteString :: B.ByteString -> Report.T T maybeFromByteString = ParserByteString.run get put :: Writer.C writer => T -> writer put msg = case msg of Channel s -> Channel.put s System s -> System.put s putWithStatus :: Writer.C writer => T -> StatusWriter.T writer putWithStatus msg = case msg of Channel s -> Channel.putWithStatus s System s -> StatusWriter.clear +#+ StatusWriter.lift (System.put s) toByteString :: T -> B.ByteString toByteString = Writer.runByteString . put midi-0.2.0.1/src/Sound/MIDI/Parser/0000755000000000000000000000000011753275103014621 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Parser/Status.hs0000644000000000000000000000360411753275103016443 0ustar0000000000000000{- | Parser which handles the running state that is used in MIDI messages in realtime and files. The running state consists of a message code and the message channel. -} module Sound.MIDI.Parser.Status (T, Status, set, get, run, lift, Channel, fromChannel, toChannel, ) where import qualified Sound.MIDI.Parser.Class as Parser import qualified Control.Monad.Exception.Synchronous as Sync import Control.Monad.Trans.State (StateT, evalStateT, ) import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Class as Trans import Sound.MIDI.Utility (checkRange, ) import Data.Ix (Ix) {- | The 'T' monad parses a track of a MIDI File. In MIDI, a shortcut is used for long strings of similar MIDI events: If a stream of consecutive events all have the same type and channel, the type and channel can be omitted for all but the first event. To implement this /feature/, the parser must keep track of the type and channel of the most recent MIDI Event. This is done by managing a 'Status' in the parser. -} type T parser = StateT Status parser type Status = Maybe (Int,Channel) set :: Monad parser => Status -> Parser.Fallible (T parser) () set = Trans.lift . State.put get :: Monad parser => Parser.Fallible (T parser) Status get = Trans.lift State.get run :: Monad parser => T parser a -> parser a run = flip evalStateT Nothing lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a lift = Sync.mapExceptionalT Trans.lift -- * Channel definition {- | This definition should be in Message.Channel, but this results in a cyclic import. -} newtype Channel = Channel {fromChannel :: Int} deriving (Show, Eq, Ord, Ix) toChannel :: Int -> Channel toChannel = checkRange "Channel" Channel instance Enum Channel where toEnum = toChannel fromEnum = fromChannel instance Bounded Channel where minBound = Channel 0 maxBound = Channel 15 midi-0.2.0.1/src/Sound/MIDI/Parser/Restricted.hs0000644000000000000000000000527411753275103017275 0ustar0000000000000000{- | Parser which limits the input data to a given number of bytes. We need this for parsing MIDI tracks and some MetaEvents, where the length of a part is fixed by a length specification. -} module Sound.MIDI.Parser.Restricted (T(..), run, runFallible, ) where import qualified Sound.MIDI.Parser.Class as Parser import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Trans.Class as Trans import Control.Monad.Trans.State (StateT(runStateT), gets, get, put, ) import Control.Monad (when, ) import qualified Numeric.NonNegative.Wrapper as NonNeg import Prelude hiding (replicate, until, ) run :: Parser.C parser => NonNeg.Integer -> T parser a -> parser a run maxLen p = do (x,remaining) <- runStateT (decons p) maxLen Parser.warnIf (remaining>0) ("unparsed bytes left in part (" ++ show remaining ++ " bytes)") return x runFallible :: Parser.C parser => NonNeg.Integer -> Parser.Fallible (T parser) a -> Parser.Fallible parser a runFallible len = Sync.mapExceptionalT (run len) lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a lift = Sync.mapExceptionalT Trans.lift newtype T parser a = Cons {decons :: StateT NonNeg.Integer parser a} instance Monad parser => Monad (T parser) where return = Cons . return x >>= y = Cons $ decons . y =<< decons x instance Trans.MonadTrans T where lift = Cons . Trans.lift getRemaining :: Monad parser => Parser.Fallible (T parser) NonNeg.Integer getRemaining = Trans.lift $ Cons get putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fallible (T parser) () putRemaining = Trans.lift . Cons . put instance Parser.EndCheck parser => Parser.EndCheck (T parser) where isEnd = {- if remaining>0 then we do not check whether there are actually more bytes in the stream because that will be catched anyway on the next getByte or skip -} Cons (gets (0==)) -- if remaining==0 then return True else lift Parser.isEnd instance Parser.C parser => Parser.C (T parser) where getByte = getRemaining >>= \remaining -> do when (remaining==0) (lift $ Parser.giveUp "unexpected end of part") {- in principle not necessary, because Parser.getByte must check for remaining bytes end <- lift Parser.isEnd when end (lift $ Parser.giveUp "part longer than container") -} putRemaining (remaining-1) lift Parser.getByte skip n = getRemaining >>= \remaining -> if n>remaining then lift $ Parser.giveUp "skip beyond end of part" else putRemaining (remaining-n) >> lift (Parser.skip n) warn = Cons . Trans.lift . Parser.warn midi-0.2.0.1/src/Sound/MIDI/Parser/ByteString.hs0000644000000000000000000000537611753275103017262 0ustar0000000000000000{- This module Sound.MIDI.Parser.Stream share significant portions of code. -} module Sound.MIDI.Parser.ByteString (T(..), run, runIncomplete, {- runPartial, -} PossiblyIncomplete, UserMessage, ) where import qualified Data.ByteString.Lazy as B import qualified Data.Binary.Get as Binary import Data.Binary.Get (Get, runGet, ) import Control.Monad.Trans.Class (lift, ) import qualified Sound.MIDI.Parser.Report as Report import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) import qualified Sound.MIDI.Parser.Exception as Exception import qualified Sound.MIDI.Parser.Warning as Warning -- import qualified Control.Monad.Exception.Synchronous as Sync -- import Data.Word (Word8) import Data.Int (Int64) import qualified Numeric.NonNegative.Wrapper as NonNeg import Prelude hiding (replicate, until, ) newtype T a = Cons {decons :: Warning.T Get a} {- runPartial :: T a -> B.ByteString -> (Report.T a, B.ByteString) runPartial parser input = flip runGetState input (decons parser) -} run :: Parser.Fallible T a -> B.ByteString -> Report.T a run parser input = flip runGet input $ Warning.run $ decons $ Exception.run $ (do a <- parser lift $ Parser.isEnd >>= \end -> Parser.warnIf (not end) "unparsed data left over" return a) {- | Treat errors which caused an incomplete data structure as warnings. This is reasonable, because we do not reveal the remaining unparsed data and thus further parsing is not possible. -} runIncomplete :: Parser.Partial (Parser.Fallible T) a -> B.ByteString -> Report.T a runIncomplete parser input = flip run input $ lift . Parser.warnIncomplete =<< parser fromGet :: Get a -> T a fromGet p = Cons $ lift p instance Monad T where return = Cons . return x >>= y = Cons $ decons . y =<< decons x instance Parser.EndCheck T where isEnd = fromGet Binary.isEmpty instance Parser.C T where -- getByte = fromGet Binary.getWord8 -- a get getMaybeWord8 would be nice in order to avoid double-checking getByte = do end <- lift $ fromGet Binary.isEmpty if end then Parser.giveUp "unexpected end of ByteString" else lift $ fromGet Binary.getWord8 skip n = let toSize x = let y = if x > fromIntegral (maxBound `asTypeOf` y) then error "skip: number too big" else fromIntegral x in y in lift $ fromGet $ skip $ toSize $ NonNeg.toNumber n warn = Cons . Warning.warn {- | In contrast to Binary.skip this one does not fail badly and it works with Int64. I hope that it is not too inefficient. -} skip :: Int64 -> Get () skip n = Binary.getLazyByteString n >> return () -- Binary.skip n midi-0.2.0.1/src/Sound/MIDI/Parser/Stream.hs0000644000000000000000000001076311753275103016417 0ustar0000000000000000module Sound.MIDI.Parser.Stream (T(..), run, runIncomplete, runPartial, ByteList(..), PossiblyIncomplete, UserMessage, ) where import Control.Monad.Trans.State (State, runState, evalState, get, put, ) import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, when, ) import qualified Sound.MIDI.Parser.Report as Report import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) import qualified Sound.MIDI.Parser.Exception as Exception import qualified Sound.MIDI.Parser.Warning as Warning -- import qualified Control.Monad.Exception.Synchronous as Sync import qualified Sound.MIDI.IO as MIO import Data.Word (Word8) import qualified Data.List as List import qualified Numeric.NonNegative.Wrapper as NonNeg import Prelude hiding (replicate, until, drop, ) {- Instead of using Report and write the monad instance manually, we could also use WriterT monad for warnings and ErrorT monad for failure handling. -} newtype T str a = Cons {decons :: Warning.T (State str) a} runPartial :: Parser.Fallible (T str) a -> str -> (Report.T a, str) runPartial parser input = flip runState input $ Warning.run $ decons $ Exception.run parser run :: ByteStream str => Parser.Fallible (T str) a -> str -> Report.T a run parser input = flip evalState input $ Warning.run $ decons $ Exception.run $ (do a <- parser lift $ Parser.isEnd >>= \end -> Parser.warnIf (not end) "unparsed data left over" return a) {- | Treat errors which caused an incomplete data structure as warnings. This is reasonable, because we do not reveal the remaining unparsed data and thus further parsing is not possible. -} runIncomplete :: ByteStream str => Parser.Partial (Parser.Fallible (T str)) a -> str -> Report.T a runIncomplete parser input = flip run input $ lift . Parser.warnIncomplete =<< parser fromState :: State str a -> T str a fromState p = Cons $ lift p instance Monad (T str) where return = Cons . return x >>= y = Cons $ decons . y =<< decons x class ByteStream str where switchL :: a -> (Word8 -> str -> a) -> str -> a drop :: NonNeg.Integer -> str -> str newtype ByteList = ByteList MIO.ByteList instance ByteStream ByteList where switchL n j (ByteList xss) = case xss of (x:xs) -> j x (ByteList xs) _ -> n drop n (ByteList xs) = ByteList $ List.genericDrop n xs instance ByteStream str => Parser.EndCheck (T str) where isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get instance ByteStream str => Parser.C (T str) where getByte = switchL (Parser.giveUp "unexpected end of data") (\s ss -> lift (fromState (put ss)) >> return s) =<< lift (fromState get) {- skip n = sequence_ (genericReplicate n Parser.getByte) -} skip n = when (n>0) $ do s <- lift $ fromState get switchL (Parser.giveUp "skip past end of part") (\ _ rest -> lift $ fromState $ put rest) (drop (n-1) s) warn = Cons . Warning.warn {- laziness problems: fst $ runPartial (Parser.try (undefined :: T ByteList String)) $ ByteList [] fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.try (return "bla" :: T ByteList String))) $ ByteList [] fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.handleMsg id undefined)) $ ByteList [] evalState (sequence $ repeat $ return 'a') "" fst $ runPartial (sequence $ repeat $ return 'a') "" fmap snd $ Report.result $ fst $ runPartial (Parser.appendIncomplete (return (undefined,'a')) (return (undefined,"bc"))) (ByteList $ repeat 129) fmap snd $ Report.result $ fst $ runPartial ((return (undefined,'a'))) (ByteList $ repeat 129) fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (Nothing,'a'))) (ByteList $ repeat 129) fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (undefined,'a'))) (ByteList $ repeat 129) fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) either error snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) Report.result $ run (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) Report.result $ runIncomplete (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) Report.result $ runIncomplete (Parser.replicate 1000000 (liftM ((,) Nothing) Parser.getByte)) (ByteList $ repeat 129) Report.result $ runIncomplete (Parser.until (128==) Parser.getByte) (ByteList $ repeat 129) -} midi-0.2.0.1/src/Sound/MIDI/Parser/Warning.hs0000644000000000000000000000117511753275103016566 0ustar0000000000000000{- | Handling of warnings. -} module Sound.MIDI.Parser.Warning where import qualified Sound.MIDI.Parser.Report as Report import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Trans.Writer as Writer type T m = Writer.WriterT [Report.UserMessage] m run :: Monad m => T m (Sync.Exceptional Report.UserMessage a) -> m (Report.T a) run act = do (exc,warns) <- Writer.runWriterT act return $ Report.Cons warns (Sync.toEither exc) {- run :: Monad m => T m a -> m (a, [Report.UserMessage]) run = Writer.runWriterT -} warn :: Monad m => String -> T m () warn text = Writer.tell [text] midi-0.2.0.1/src/Sound/MIDI/Parser/File.hs0000644000000000000000000000455111753275103016041 0ustar0000000000000000module Sound.MIDI.Parser.File (T(..), runFile, runHandle, runIncompleteFile, PossiblyIncomplete, UserMessage, ) where import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) import Control.Monad.Trans.Reader (ReaderT(runReaderT), ask, ) import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, ) import qualified System.IO.Error as IOE import qualified Control.Exception as Exc import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync import qualified System.IO as IO import Data.Char (ord) import qualified Numeric.NonNegative.Wrapper as NonNeg newtype T a = Cons {decons :: ReaderT IO.Handle IO a} runFile :: Parser.Fallible T a -> FilePath -> IO a runFile p name = Exc.bracket (IO.openBinaryFile name IO.ReadMode) IO.hClose (runHandle p) runHandle :: Parser.Fallible T a -> IO.Handle -> IO a runHandle p h = do exc <- runReaderT (decons (Sync.tryT p)) h Sync.resolve (IOE.ioError . IOE.userError) (fmap return exc) {- | Since in case of an incomplete file read, we cannot know where the current file position is, we omit the @runIncompleteHandle@ variant. -} runIncompleteFile :: Parser.Partial (Parser.Fallible T) a -> FilePath -> IO a runIncompleteFile p name = Exc.bracket (IO.openBinaryFile name IO.ReadMode) IO.hClose (\h -> do (Async.Exceptional me a) <- runHandle p h maybe (return ()) (\msg -> putStrLn $ "could not parse MIDI file completely: " ++ msg) me return a) instance Monad T where return = Cons . return x >>= y = Cons $ decons . y =<< decons x fromIO :: (IO.Handle -> IO a) -> T a fromIO act = Cons $ lift . act =<< ask ioeTry :: IO a -> IO (Either IOError a) ioeTry = Exc.try fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a fallibleFromIO act = Sync.ExceptionalT . Cons . lift . fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act =<< lift (Cons ask) instance Parser.EndCheck T where isEnd = fromIO IO.hIsEOF instance Parser.C T where getByte = fallibleFromIO $ liftM (fromIntegral . ord) . IO.hGetChar skip n = fallibleFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n) warn = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg)) midi-0.2.0.1/src/Sound/MIDI/Parser/Primitive.hs0000644000000000000000000000675211753275103017137 0ustar0000000000000000{- | Parse primitive types contained in MIDI files. -} module Sound.MIDI.Parser.Primitive (getByte, getN, getString, getBigN, getNByteInt, get1, get2, get3, get4, getNByteCardinal, getVar, getVarBytes, getEnum, makeEnum, ) where import qualified Sound.MIDI.Parser.Class as Parser import Control.Monad (replicateM, liftM, ) import Sound.MIDI.IO (ByteList, listCharFromByte, ) import qualified Sound.MIDI.Bit as Bit import Data.Bits (testBit, clearBit) import Data.Word (Word8) import qualified Numeric.NonNegative.Wrapper as NonNeg {- | 'getByte' gets a single byte from the input. -} getByte :: Parser.C parser => Parser.Fallible parser Word8 getByte = Parser.getByte {- | @getN n@ returns n characters (bytes) from the input. -} getN :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser ByteList getN n = replicateM (NonNeg.toNumber n) getByte getString :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser String getString n = liftM listCharFromByte (getBigN n) getBigN :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser ByteList getBigN n = sequence $ Bit.replicateBig (1 + fromIntegral (maxBound :: NonNeg.Int)) (NonNeg.toNumber n) getByte {- | 'get1', 'get2', 'get3', and 'get4' take 1-, 2-, 3-, or 4-byte numbers from the input (respectively), convert the base-256 data into a single number, and return. -} get1 :: Parser.C parser => Parser.Fallible parser Int get1 = liftM fromIntegral getByte getNByteInt :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser Int getNByteInt n = liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1) get2, get3, get4 :: Parser.C parser => Parser.Fallible parser Int get2 = getNByteInt 2 get3 = getNByteInt 3 get4 = getNByteInt 4 getByteAsCardinal :: Parser.C parser => Parser.Fallible parser NonNeg.Integer getByteAsCardinal = liftM fromIntegral getByte getNByteCardinal :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser NonNeg.Integer getNByteCardinal n = liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) getByteAsCardinal) {- | /Variable-length quantities/ are used often in MIDI notation. They are represented in the following way: Each byte (containing 8 bits) uses the 7 least significant bits to store information. The most significant bit is used to signal whether or not more information is coming. If it's @1@, another byte is coming. If it's @0@, that byte is the last one. 'getVar' gets a variable-length quantity from the input. -} getVar :: Parser.C parser => Parser.Fallible parser NonNeg.Integer getVar = liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes {- | The returned list contains only bytes with the most significant bit cleared. These are digits of a 128-ary number. -} getVarBytes :: Parser.C parser => Parser.Fallible parser [Word8] getVarBytes = do digit <- getByte if flip testBit 7 digit -- if it's the last byte then liftM (flip clearBit 7 digit :) getVarBytes else return [digit] getEnum :: (Parser.C parser, Enum enum, Bounded enum) => Parser.Fallible parser enum getEnum = makeEnum =<< get1 makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> Parser.Fallible parser enum makeEnum n = let go :: (Parser.C parser, Enum a) => a -> a -> Parser.Fallible parser a go lower upper = if fromEnum lower <= n && n <= fromEnum upper then return (toEnum n) else Parser.giveUp ("value " ++ show n ++ " is out of range for enumeration") in go minBound maxBound midi-0.2.0.1/src/Sound/MIDI/Parser/Report.hs0000644000000000000000000000114311753275103016427 0ustar0000000000000000{- | Definition of a datatype that reports on the success of a parser. -} module Sound.MIDI.Parser.Report where {- | This datatype is the result of a parser. First it stores a sequence of warnings. Warnings are for corruptions of the input which can be fixed. After encountering a series of warnings, there is finally an end, either a successful one, with the result as @(Right result)@ or an eventual non-fixable problem indicated by @(Left errorMessage)@. -} data T a = Cons { warnings :: [UserMessage], result :: Either UserMessage a } deriving (Show, Eq) type UserMessage = String midi-0.2.0.1/src/Sound/MIDI/Parser/Exception.hs0000644000000000000000000000104011753275103017106 0ustar0000000000000000{- | Handling of exceptions. -} module Sound.MIDI.Parser.Exception where import qualified Sound.MIDI.Parser.Report as Report -- import qualified Sound.MIDI.Parser.Warning as Warning import qualified Control.Monad.Exception.Synchronous as Sync type T m = Sync.ExceptionalT Report.UserMessage m run :: Monad m => T m a -> m (Sync.Exceptional Report.UserMessage a) run = Sync.runExceptionalT giveUp :: Monad m => String -> T m a giveUp = Sync.throwT try :: Monad m => T m a -> m (Sync.Exceptional Report.UserMessage a) try = Sync.tryT midi-0.2.0.1/src/Sound/MIDI/Parser/Class.hs0000644000000000000000000001127611753275103016231 0ustar0000000000000000module Sound.MIDI.Parser.Class (EndCheck, isEnd, C, getByte, skip, warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try, until, zeroOrMore, zeroOrMoreInc, replicate, emptyList, PossiblyIncomplete, UserMessage, Fallible, Partial, {- for debugging absorbException, appendIncomplete, -} ) where import Sound.MIDI.Parser.Report (UserMessage) import qualified Sound.MIDI.Parser.Exception as Exc import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync import Control.Monad.Trans.Class (lift, ) import Control.Monad.Trans.State (StateT, ) import Control.Monad (liftM, liftM2, when, ) import Data.Word (Word8) import qualified Numeric.NonNegative.Wrapper as NonNeg import Prelude hiding (replicate, until, ) class Monad parser => EndCheck parser where isEnd :: parser Bool -- would be probably better placed in Parser.Status instance EndCheck parser => EndCheck (StateT st parser) where isEnd = lift $ isEnd class EndCheck parser => C parser where getByte :: Fallible parser Word8 skip :: NonNeg.Integer -> Fallible parser () warn :: UserMessage -> parser () {- | @PossiblyIncomplete@ represents a value like a list that can be the result of an incomplete parse. The case of an incomplete parse is indicated by @Just message@. It is not possible to merge this functionality in the parser monad, because then it is not possible to define monadic binding. -} type PossiblyIncomplete a = Async.Exceptional UserMessage a type Fallible parser = Sync.ExceptionalT UserMessage parser type Partial parser a = parser (PossiblyIncomplete a) warnIf :: C parser => Bool -> UserMessage -> parser () warnIf b msg = when b (warn msg) {- | Emit a warning if a value is said to be incomplete. Be careful using this function, because an incomplete value often means that subsequent parse actions will process data from the wrong position. Only use this function if you either know that the parse is complete also if the parsed value is incomplete or if there are no subsequent parse actions to run. This function cannot fail. -} warnIncomplete :: C parser => PossiblyIncomplete a -> parser a warnIncomplete ~(Async.Exceptional me a) = do maybe (return ()) warn me return a {- | This function will never fail. If the element parser fails somewhere, a prefix of the complete list is returned along with the error message. -} zeroOrMore :: EndCheck parser => Fallible parser a -> Partial parser [a] zeroOrMore p = let go = isEnd >>= \b -> if b then return emptyList else absorbException (liftM2 (\ x -> fmap (x:)) p (lift go)) in go zeroOrMoreInc :: EndCheck parser => Partial (Fallible parser) a -> Partial parser [a] zeroOrMoreInc p = let go = isEnd >>= \b -> if b then return emptyList else absorbException (appendIncomplete p go) in go {- | Parse until an element is found, which matches a condition. The terminating element is consumed by the parser but not appended to the result list. If the end of the input is reached without finding the terminating element, then an Incomplete exception (Just errorMessage) is signaled. -} until :: EndCheck parser => (a -> Bool) -> Fallible parser a -> Partial parser [a] until c p = let go = isEnd >>= \b -> if b then return $ Async.broken "Parser.until: unexpected end of input" [] else absorbException $ p >>= \x -> if c x then return emptyList else liftM (fmap (x:)) (lift go) in go {- | This function will never fail. It may however return a list that is shorter than requested. -} replicate :: C parser => NonNeg.Int -> Partial (Fallible parser) a -> Partial parser [a] replicate m p = let go n = if n==0 then return emptyList else absorbException (appendIncomplete p (go (n-1))) in go m emptyList :: PossiblyIncomplete [a] emptyList = Async.pure [] {- | The first parser may fail, but the second one must not. -} appendIncomplete :: Monad parser => Partial (Fallible parser) a -> Partial parser [a] -> Partial (Fallible parser) [a] appendIncomplete p ps = do ~(Async.Exceptional me x) <- p lift $ liftM (fmap (x:)) $ maybe ps (\_ -> return (Async.Exceptional me [])) me absorbException :: Monad parser => Partial (Fallible parser) [a] -> Partial parser [a] absorbException = Sync.resolveT (\errMsg -> return $ Async.broken errMsg []) midi-0.2.0.1/src/Sound/MIDI/Example/0000755000000000000000000000000011753275103014760 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Example/ControllerRamp.hs0000644000000000000000000000210311753275103020253 0ustar0000000000000000module Sound.MIDI.Example.ControllerRamp {- Main -} where import qualified Sound.MIDI.File as MidiFile import qualified Sound.MIDI.File.Save as Save -- import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as Event import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -- import qualified Sound.MIDI.Parser.Report as Report import qualified Data.EventList.Relative.TimeBody as EventList -- import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.ByteString.Lazy as B -- import qualified Numeric.NonNegative.Wrapper as NonNeg example :: MidiFile.T example = let chan = ChannelMsg.toChannel 0 in MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) [EventList.fromPairList $ map (\x -> (50, Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.Control VoiceMsg.mainVolume x))))) [0..127]] main :: IO () main = B.writeFile "controller-ramp.mid" (Save.toByteString example) midi-0.2.0.1/src/Sound/MIDI/Example/Tomatosalad.hs0000644000000000000000000001502211753275103017564 0ustar0000000000000000{- The famous song, that is named "Tomatensalat" in German. -} module Main where import qualified Sound.MIDI.File as MidiFile import qualified Sound.MIDI.File.Save as Save import Sound.MIDI.File (ElapsedTime, ) import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as Event import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -- import qualified Sound.MIDI.Parser.Report as Report import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.BodyTime as EventListBT import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Relative.TimeBody as EventList -- import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.ByteString.Lazy as B -- import qualified Numeric.NonNegative.Wrapper as NonNeg import Data.Tuple.HT (mapFst, ) import qualified Control.Monad.Trans.State as State import Control.Monad (liftM3, ) g0,a0,b0,c1,cs1,d1,e1,f1,g1,a1,as1 :: VoiceMsg.Pitch [g0,a0,b0,c1,cs1,d1,e1,f1,g1,a1,as1] = map VoiceMsg.toPitch [55,57,59,60,61,62,64,65,67,69,70] melody :: [(VoiceMsg.Pitch, ElapsedTime)] melody = let n p t = (VoiceMsg.increasePitch (-12) p, t) in n g0 3 : n c1 1 : n c1 1 : n c1 1 : n e1 1 : n d1 1 : n c1 1 : n d1 1 : n g0 1 : n g0 1 : n g0 3 : n c1 1 : n c1 1 : n c1 1 : n e1 1 : n d1 1 : n c1 1 : n g1 3 : n e1 3 : n f1 1 : n f1 1 : n f1 1 : n a1 1 : n g1 1 : n f1 1 : n e1 1 : n e1 1 : n e1 1 : n g1 1 : n f1 1 : n e1 1 : n d1 1 : n d1 1 : n d1 1 : n f1 1 : n e1 1 : n d1 1 : n c1 3 : [] melodyEvents :: [(VoiceMsg.Pitch, ElapsedTime)] -> Int -> EventListBT.T ElapsedTime Event.T melodyEvents mel pn = let chan = ChannelMsg.toChannel 0 vel = VoiceMsg.toVelocity (VoiceMsg.normalVelocity+25) event = Event.MIDIEvent . ChannelMsg.Cons chan . ChannelMsg.Voice in EventListBT.fromPairList $ concatMap (\(pgm, (n,t)) -> [(event $ VoiceMsg.ProgramChange pgm, 0), (event $ VoiceMsg.NoteOn n vel, t), (event $ VoiceMsg.NoteOff n vel, 0)]) $ zip (cycle $ map VoiceMsg.toProgram [pn..(pn+4)]) $ concat $ replicate 5 $ mel solo :: Int -> MidiFile.T solo pn = MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 4) [EventList.cons 0 (Event.MetaEvent $ MetaEvent.SetTempo 1500000) $ EventListTM.switchTimeR const $ EventListMT.consTime 0 $ melodyEvents melody pn] melody2 :: [(VoiceMsg.Pitch, ElapsedTime)] melody2 = let n p t = (p, t) in n g0 3 : n c1 1 : n c1 1 : n c1 1 : n e1 1 : n d1 1 : n c1 1 : n d1 1 : n g0 1 : n g0 1 : n g0 3 : n d1 1 : n d1 1 : n d1 1 : n f1 1 : n e1 1 : n d1 1 : n g1 3 : n e1 3 : n f1 1 : n f1 1 : n f1 1 : n a1 1 : n g1 1 : n f1 1 : n e1 1 : n e1 1 : n e1 1 : n g1 1 : n f1 1 : n e1 1 : n d1 1 : n d1 1 : n d1 1 : n f1 1 : n e1 1 : n d1 1 : n c1 3 : [] nextProgram :: State.State [VoiceMsg.Program] VoiceMsg.Program nextProgram = State.state $ \(pgm:pgms) -> (pgm,pgms) accompEvents :: Int -> EventListBT.T ElapsedTime Event.T accompEvents pn = let chan = ChannelMsg.toChannel 0 vel = VoiceMsg.toVelocity (VoiceMsg.normalVelocity-25) event = Event.MIDIEvent . ChannelMsg.Cons chan . ChannelMsg.Voice chord :: VoiceMsg.Pitch -> (VoiceMsg.Pitch, VoiceMsg.Pitch) -> State.State [VoiceMsg.Program] [(Event.T, ElapsedTime)] chord a_ (b_,c_) = liftM3 (\ pgm0 pgm1 pgm2 -> let a = VoiceMsg.increasePitch (-12) a_ b = VoiceMsg.increasePitch (-12) b_ c = VoiceMsg.increasePitch (-12) c_ in map (mapFst event) $ (VoiceMsg.ProgramChange pgm0, 0) : (VoiceMsg.NoteOn a vel, 1) : (VoiceMsg.NoteOff a vel, 0) : (VoiceMsg.ProgramChange pgm1, 0) : (VoiceMsg.NoteOn b vel, 0) : (VoiceMsg.NoteOn c vel, 1) : (VoiceMsg.NoteOff b vel, 0) : (VoiceMsg.NoteOff c vel, 0) : (VoiceMsg.ProgramChange pgm2, 0) : (VoiceMsg.NoteOn b vel, 0) : (VoiceMsg.NoteOn c vel, 1) : (VoiceMsg.NoteOff b vel, 0) : (VoiceMsg.NoteOff c vel, 0) : []) nextProgram nextProgram nextProgram introChords = chord c1 (e1, g1) : chord g0 (e1, g1) : chord c1 (e1, g1) : chord g0 (e1, g1) : [] chords = chord c1 (e1, g1) : chord g0 (e1, g1) : chord b0 (d1, g1) : chord g0 (d1, g1) : chord b0 (f1, g1) : chord g0 (f1, g1) : chord c1 (e1, g1) : chord g0 (g1, as1) : chord c1 (f1, a1) : chord a0 (f1, a1) : chord c1 (e1, g1) : chord cs1 (e1, a1) : chord b0 (d1, g1) : chord g0 (d1, g1) : chord c1 (e1, g1) : chord g0 (e1, g1) : [] in EventListBT.fromPairList $ concat $ State.evalState (sequence $ concat $ introChords : replicate 5 chords) $ cycle $ map VoiceMsg.toProgram [pn..(pn+4)] song :: Int -> Int -> MidiFile.T song pna pnm = MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 4) [EventList.cons 0 (Event.MetaEvent $ MetaEvent.SetTempo 1500000) $ let tb t = EventListTM.switchTimeR const . EventListMT.consTime t in EventList.mergeBy (\ _ _ -> True) (tb 0 $ accompEvents pna) (tb 9 $ melodyEvents melody2 pnm)] main :: IO () main = B.writeFile "tomatosalad.mid" (Save.toByteString (solo 16)) >> B.writeFile "hal.mid" (Save.toByteString (solo 21)) >> B.writeFile "graphtheory.mid" (Save.toByteString (solo 26)) >> B.writeFile "haltomato.mid" (Save.toByteString (song 16 21)) midi-0.2.0.1/src/Sound/MIDI/Message/0000755000000000000000000000000011753275103014751 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Message/Channel.hs0000644000000000000000000000765511753275103016672 0ustar0000000000000000{- | Channel messages -} module Sound.MIDI.Message.Channel ( T(..), Body(..), get, getWithStatus, put, putWithStatus, Channel, fromChannel, toChannel, Voice.Pitch, Voice.fromPitch, Voice.toPitch, Voice.Velocity, Voice.fromVelocity, Voice.toVelocity, Voice.Program, Voice.fromProgram, Voice.toProgram, Voice.Controller, Voice.fromController, Voice.toController, decodeStatus, ) where import qualified Sound.MIDI.Message.Channel.Voice as Voice import qualified Sound.MIDI.Message.Channel.Mode as Mode import qualified Sound.MIDI.Parser.Status as StatusParser import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Status (Channel, fromChannel, toChannel, ) import Control.Monad (liftM, liftM2, when, ) import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit import Sound.MIDI.Monoid ((+#+)) import Sound.MIDI.Utility ({-checkRange,-} mapSnd, ) -- import Data.Ix (Ix) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC data T = Cons { messageChannel :: Channel, messageBody :: Body } -- ToDo: make nicer Show instance deriving (Show, Eq, Ord) data Body = Voice Voice.T | Mode Mode.T deriving (Show, Eq, Ord) instance Arbitrary T where arbitrary = liftM2 Cons (liftM toChannel $ QC.frequency $ -- we have to prefer one favorite channel in order to test correct implementation of the running status (20, return 3) : ( 1, QC.choose (0,15)) : []) (QC.frequency $ (20, liftM Voice arbitrary) : ( 1, liftM Mode arbitrary) : []) -- * serialization {- | Parse an event. Note that in the case of a regular MIDI Event, the tag is the status, and we read the first byte of data before we call 'get'. In the case of a MIDIEvent with running status, we find out the status from the parser (it's been nice enough to keep track of it for us), and the tag that we've already gotten is the first byte of data. -} getWithStatus :: Parser.C parser => Int -> Parser.Fallible (StatusParser.T parser) T getWithStatus tag = do (status@(code, channel), firstData) <- if tag < 0x80 then maybe (Parser.giveUp "messages wants to repeat status byte, but there was no status yet") (\cc -> return (cc,tag)) =<< StatusParser.get else liftM ((,) $ decodeStatus tag) $ StatusParser.lift get1 StatusParser.set (Just status) StatusParser.lift $ get code channel firstData -- | for internal use decodeStatus :: Int -> (Int, Channel) decodeStatus = mapSnd toChannel . Bit.splitAt 4 {- | Parse a MIDI Channel message. Note that since getting the first byte is a little complex (there are issues with running status), the code, channel and first data byte must be determined by the caller. -} get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fallible parser T get code channel firstData = liftM (Cons channel) $ if code == 11 && firstData >= 0x78 then when (firstData >= 0x80) (Parser.giveUp ("mode value out of range: " ++ show firstData)) >> liftM Mode (Mode.get firstData) else liftM Voice (Voice.get code firstData) put :: Writer.C writer => T -> writer put = StatusWriter.toWriterWithoutStatus . putWithStatus putWithStatus :: Writer.C writer => T -> StatusWriter.T writer putWithStatus (Cons c e) = case e of Voice v -> Voice.putWithStatus (putChannel c) v Mode m -> putChannel c 11 +#+ StatusWriter.lift (Mode.put m) -- | output a channel + message code putChannel :: Writer.C writer => Channel -> Int -> StatusWriter.T writer putChannel chan code = StatusWriter.change (Just (code, chan)) $ Writer.putIntAsByte (16*code + fromChannel chan) midi-0.2.0.1/src/Sound/MIDI/Message/System.hs0000644000000000000000000000326411753275103016576 0ustar0000000000000000{- | System messages -} module Sound.MIDI.Message.System ( T(..), get, getIncomplete, put, ) where import qualified Sound.MIDI.Message.System.Exclusive as Exclusive import qualified Sound.MIDI.Message.System.Common as Common import qualified Sound.MIDI.Message.System.RealTime as RealTime -- import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer import qualified Control.Monad.Exception.Asynchronous as Async import Control.Monad (liftM, ) data T = Exclusive Exclusive.T | Common Common.T | RealTime RealTime.T get :: Parser.C parser => Int -> Parser.Fallible parser T get code = if code == 0xF0 then liftM Exclusive Exclusive.get else if code >= 0xF1 && code <= 0xF6 then liftM Common $ Common.get code else if code >= 0xF8 && code <= 0xFF then liftM RealTime $ RealTime.get code else Parser.giveUp ("invalid System message code " ++ show code) getIncomplete :: Parser.C parser => Int -> Parser.Partial (Parser.Fallible parser) T getIncomplete code = if code == 0xF0 then liftM (fmap Exclusive) Exclusive.getIncomplete else if code >= 0xF1 && code <= 0xF6 then liftM (Async.pure . Common) $ Common.get code else if code >= 0xF8 && code <= 0xFF then liftM (Async.pure . RealTime) $ RealTime.get code else Parser.giveUp ("invalid System message code " ++ show code) put :: Writer.C writer => T -> writer put msg = case msg of Exclusive s -> Exclusive.put s Common s -> Common.put s RealTime s -> RealTime.put s midi-0.2.0.1/src/Sound/MIDI/Message/Class/0000755000000000000000000000000011753275103016016 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Message/Class/Query.hs0000644000000000000000000000537511753275103017471 0ustar0000000000000000module Sound.MIDI.Message.Class.Query where import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, ) import qualified Sound.MIDI.Message as MidiMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode {- | All methods have default implementations that return 'Nothing'. This helps implementing event data types that support only a subset of types of events. Maybe a better approach is to provide type classes for every type of event and make 'C' a subclass of all of them. -} class C event where note :: event -> Maybe (Channel, (Velocity, Pitch, Bool)) program :: event -> Maybe (Channel, Program) anyController :: event -> Maybe (Channel, (Controller, Int)) pitchBend :: event -> Maybe (Channel, Int) channelPressure :: event -> Maybe (Channel, Int) mode :: event -> Maybe (Channel, Mode.T) note _ev = Nothing program _ev = Nothing anyController _ev = Nothing pitchBend _ev = Nothing channelPressure _ev = Nothing mode _ev = Nothing instance C ChannelMsg.T where note msg = do ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg fmap ((,) (ChannelMsg.messageChannel msg)) $ case voice of VoiceMsg.NoteOn pitch velocity -> Just (velocity, pitch, True) VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False) _ -> Nothing program msg = do ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <- Just $ ChannelMsg.messageBody msg return (ChannelMsg.messageChannel msg, pgm) anyController msg = do ChannelMsg.Voice (VoiceMsg.Control ctrl val) <- Just $ ChannelMsg.messageBody msg return (ChannelMsg.messageChannel msg, (ctrl, val)) pitchBend msg = do ChannelMsg.Voice (VoiceMsg.PitchBend bend) <- Just $ ChannelMsg.messageBody msg return (ChannelMsg.messageChannel msg, bend) channelPressure msg = do ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <- Just $ ChannelMsg.messageBody msg return (ChannelMsg.messageChannel msg, pressure) mode msg = do ChannelMsg.Mode m <- Just $ ChannelMsg.messageBody msg return (ChannelMsg.messageChannel msg, m) liftMidi :: (ChannelMsg.T -> Maybe (Channel, a)) -> (MidiMsg.T -> Maybe (Channel, a)) liftMidi checkMsg msg = case msg of MidiMsg.Channel chanMsg -> checkMsg chanMsg _ -> Nothing instance C MidiMsg.T where note = liftMidi note program = liftMidi program anyController = liftMidi anyController pitchBend = liftMidi pitchBend channelPressure = liftMidi channelPressure mode = liftMidi mode midi-0.2.0.1/src/Sound/MIDI/Message/Class/Check.hs0000644000000000000000000000616311753275103017375 0ustar0000000000000000module Sound.MIDI.Message.Class.Check where import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, ) import qualified Sound.MIDI.Message as MidiMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode import Control.Monad (guard, ) {- | All methods have default implementations that return 'Nothing'. This helps implementing event data types that support only a subset of types of events. Maybe a better approach is to provide type classes for every type of event and make 'C' a subclass of all of them. -} class C event where note :: Channel -> event -> Maybe (Velocity, Pitch, Bool) program :: Channel -> event -> Maybe Program anyController :: Channel -> event -> Maybe (Controller, Int) pitchBend :: Channel -> event -> Maybe Int channelPressure :: Channel -> event -> Maybe Int mode :: Channel -> event -> Maybe Mode.T note _chan _ev = Nothing program _chan _ev = Nothing anyController _chan _ev = Nothing pitchBend _chan _ev = Nothing channelPressure _chan _ev = Nothing mode _chan _ev = Nothing controller :: (C event) => Channel -> Controller -> event -> Maybe Int controller chan ctrl e = do (c,n) <- anyController chan e guard (ctrl==c) return n instance C ChannelMsg.T where note chan msg = do guard (ChannelMsg.messageChannel msg == chan) ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg case voice of VoiceMsg.NoteOn pitch velocity -> Just (velocity, pitch, True) VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False) _ -> Nothing program chan msg = do guard (ChannelMsg.messageChannel msg == chan) ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <- Just $ ChannelMsg.messageBody msg return pgm anyController chan msg = do guard (ChannelMsg.messageChannel msg == chan) ChannelMsg.Voice (VoiceMsg.Control ctrl val) <- Just $ ChannelMsg.messageBody msg return (ctrl, val) pitchBend chan msg = do guard (ChannelMsg.messageChannel msg == chan) ChannelMsg.Voice (VoiceMsg.PitchBend bend) <- Just $ ChannelMsg.messageBody msg return bend channelPressure chan msg = do guard (ChannelMsg.messageChannel msg == chan) ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <- Just $ ChannelMsg.messageBody msg return pressure mode chan msg = do guard (ChannelMsg.messageChannel msg == chan) ChannelMsg.Mode m <- Just $ ChannelMsg.messageBody msg return m liftMidi :: (Channel -> ChannelMsg.T -> Maybe a) -> (Channel -> MidiMsg.T -> Maybe a) liftMidi checkMsg chan msg = case msg of MidiMsg.Channel chanMsg -> checkMsg chan chanMsg _ -> Nothing instance C MidiMsg.T where note = liftMidi note program = liftMidi program anyController = liftMidi anyController pitchBend = liftMidi pitchBend channelPressure = liftMidi channelPressure mode = liftMidi mode midi-0.2.0.1/src/Sound/MIDI/Message/System/0000755000000000000000000000000011753275103016235 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Message/System/Exclusive.hs0000644000000000000000000000444111753275103020543 0ustar0000000000000000{- | System Exclusive messages -} module Sound.MIDI.Message.System.Exclusive ( T(..), get, getIncomplete, put, ) where import qualified Sound.MIDI.Manufacturer as Manufacturer import Sound.MIDI.IO (ByteList) import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) import Control.Monad.Trans.Class (MonadTrans, lift, ) import qualified Control.Monad.Exception.Asynchronous as Async import Data.Maybe (fromMaybe, ) data T = Commercial Manufacturer.T ByteList | NonCommercial ByteList | NonRealTime NonRealTime | RealTime RealTime -- * Non-real time {-# DEPRECATED NonRealTime "structure must be defined, yet" #-} newtype NonRealTime = NonRealTimeCons ByteList -- * Real time {-# DEPRECATED RealTime "structure must be defined, yet" #-} newtype RealTime = RealTimeCons ByteList -- * serialization get :: Parser.C parser => Parser.Fallible parser T get = do (Async.Exceptional err sysex) <- getIncomplete maybe (return sysex) Parser.giveUp err getIncomplete :: Parser.C parser => Parser.Partial (Parser.Fallible parser) T getIncomplete = do manu <- Manufacturer.get incBody <- lift getBody return $ flip fmap incBody $ \body -> fromMaybe (Commercial manu body) $ lookup manu $ (Manufacturer.nonCommercial, NonCommercial body) : (Manufacturer.nonRealTime, NonRealTime $ NonRealTimeCons body) : (Manufacturer.realTime, RealTime $ RealTimeCons body) : [] getBody :: Parser.C parser => Parser.Partial parser ByteList getBody = Parser.until (0xf7 ==) getByte {- | It is not checked whether SysEx messages contain only 7-bit values. -} put :: Writer.C writer => T -> writer put sysex = case sysex of Commercial manu body -> Manufacturer.put manu +#+ Writer.putByteList body NonCommercial body -> Manufacturer.put Manufacturer.nonCommercial +#+ Writer.putByteList body NonRealTime (NonRealTimeCons body) -> Manufacturer.put Manufacturer.nonRealTime +#+ Writer.putByteList body RealTime (RealTimeCons body) -> Manufacturer.put Manufacturer.realTime +#+ Writer.putByteList body midi-0.2.0.1/src/Sound/MIDI/Message/System/Common.hs0000644000000000000000000000371711753275103020031 0ustar0000000000000000{- | System Common messages -} module Sound.MIDI.Message.System.Common ( T(..), TimeNibbleType(..), get, put, ) where import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, liftM2, ) import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) import qualified Sound.MIDI.Bit as Bit import Data.Ix(Ix) data T = TimeCodeQuarterFrame TimeNibbleType Int | SongPositionPointer Int | SongSelect Int | TuneRequest -- | EndOfSystemExclusive data TimeNibbleType = FrameLS | FrameMS | SecondsLS | SecondsMS | MinutesLS | MinutesMS | HoursLS | HoursMS -- ^ also includes SMPTE type deriving (Eq, Ord, Show, Enum, Ix) -- * serialization get :: Parser.C parser => Int -> Parser.Fallible parser T get code = case code of 0xF1 -> do dat <- get1 let (nib, value) = Bit.splitAt 4 dat let (msb, nibble) = Bit.splitAt 3 nib lift $ Parser.warnIf (msb/=0) "TimeCodeQuarterFrame: most significant bit must 0" return $ TimeCodeQuarterFrame (toEnum nibble) value 0xF2 -> liftM2 (\lsb msb -> SongPositionPointer (lsb + Bit.shiftL 7 msb)) get1 get1 0xF3 -> liftM SongSelect get1 0xF6 -> return TuneRequest _ -> Parser.giveUp ("invalid System Common code:" ++ show code) put :: Writer.C writer => T -> writer put msg = case msg of TimeCodeQuarterFrame nibble value -> Writer.putByte 0xF1 +#+ Writer.putIntAsByte (Bit.shiftL 4 (fromEnum nibble) + value) SongPositionPointer pos -> Writer.putByte 0xF2 +#+ let (msb,lsb) = Bit.splitAt 7 pos in Writer.putIntAsByte lsb +#+ Writer.putIntAsByte msb SongSelect song -> Writer.putByte 0xF3 +#+ Writer.putIntAsByte song TuneRequest -> Writer.putByte 0xF6 midi-0.2.0.1/src/Sound/MIDI/Message/System/RealTime.hs0000644000000000000000000000236311753275103020277 0ustar0000000000000000{- | System Real Time messages -} module Sound.MIDI.Message.System.RealTime ( T(..), get, put, ) where -- import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer import Data.Ix(Ix) data T = TimingClock -- F8 | Start -- FA | Continue -- FB | Stop -- FC | ActiveSensing -- FE | Reset -- FF deriving (Eq, Ord, Show, Enum, Ix) -- * serialization get :: Parser.C parser => Int -> Parser.Fallible parser T get code = case code of 0xF8 -> return TimingClock 0xFA -> return Start 0xFB -> return Continue 0xFC -> return Stop 0xFE -> return ActiveSensing 0xFF -> return Reset _ -> Parser.giveUp ("unknown System Real Time message code " ++ show code) put :: Writer.C writer => T -> writer put msg = case msg of TimingClock -> Writer.putByte 0xF8 Start -> Writer.putByte 0xFA Continue -> Writer.putByte 0xFB Stop -> Writer.putByte 0xFC ActiveSensing -> Writer.putByte 0xFE Reset -> Writer.putByte 0xFF midi-0.2.0.1/src/Sound/MIDI/Message/Channel/0000755000000000000000000000000011753275103016321 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Message/Channel/Mode.hs0000644000000000000000000000604711753275103017550 0ustar0000000000000000{- | Channel mode messages -} module Sound.MIDI.Message.Channel.Mode (T(..), get, put, fromControllerValue, toControllerValue, ) where import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Parser.Report (UserMessage, ) import qualified Control.Monad.Exception.Asynchronous as Async import Sound.MIDI.Utility (toMaybe, ) import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC data T = AllSoundOff | ResetAllControllers | LocalControl Bool | AllNotesOff | OmniMode Bool | MonoMode Int | PolyMode deriving (Show, Eq, Ord) instance Arbitrary T where arbitrary = QC.oneof $ return AllSoundOff : return ResetAllControllers : liftM LocalControl arbitrary : return AllNotesOff : liftM OmniMode arbitrary : liftM MonoMode (QC.choose (0,16)) : return PolyMode : [] -- * serialization get :: Parser.C parser => Int -> Parser.Fallible parser T get mode = do x <- get1 lift $ Parser.warnIncomplete $ uncurry Async.Exceptional $ fromControllerValue (mode,x) {- | This function is also used in alsa-midi, we could give it the result type @Parser.PossiblyIncomplete T@ otherwise. -} fromControllerValue :: (Show a, Integral a) => (a, a) -> (Maybe UserMessage, T) fromControllerValue (mode,x) = case mode of 0x78 -> (checkValidValue "AllSoundOff" [0] x, AllSoundOff) 0x79 -> (checkValidValue "ResetAllControllers" [0] x, ResetAllControllers) 0x7A -> (checkValidValue "LocalControl" [0,127] x, LocalControl (x/=0)) 0x7B -> (checkValidValue "AllNotesOff" [0] x, AllNotesOff) 0x7C -> (checkValidValue "OmniMode Off" [0] x, OmniMode False) 0x7D -> (checkValidValue "OmniMode On" [0] x, OmniMode True) 0x7E -> (Nothing, MonoMode (fromIntegral x)) 0x7F -> (checkValidValue "PolyMode On" [0] x, PolyMode) _ -> error ("Channel.Mode.get: mode value out of range: " ++ show mode) checkValidValue :: (Show a, Integral a) => String -> [a] -> a -> Maybe UserMessage checkValidValue name validValues value = toMaybe (not (elem value validValues)) ("Invalid value for " ++ name ++ ": " ++ show value) put :: Writer.C writer => T -> writer put mode = let (code, value) = toControllerValue mode in Writer.putByteList [code, value] toControllerValue :: Integral a => T -> (a, a) toControllerValue mode = case mode of AllSoundOff -> (,) 0x78 0 ResetAllControllers -> (,) 0x79 0 LocalControl b -> (,) 0x7A (if b then 127 else 0) AllNotesOff -> (,) 0x7B 0 OmniMode b -> (,) (if b then 0x7D else 0x7C) 0 MonoMode x -> (,) 0x7E (fromIntegral x) PolyMode -> (,) 0x7F 0 midi-0.2.0.1/src/Sound/MIDI/Message/Channel/Voice.hs0000644000000000000000000003376211753275103017735 0ustar0000000000000000{- | Channel voice messages -} module Sound.MIDI.Message.Channel.Voice ( T(..), get, putWithStatus, ControllerValue, PitchBendRange, Pressure, isNote, isNoteOn, isNoteOff, zeroKey, explicitNoteOff, implicitNoteOff, realFromControllerValue, bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, mainVolume, balance, panorama, expression, generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, vectorX, vectorY, bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, portamentoTimeMSB, dataEntryMSB, mainVolumeMSB, balanceMSB, panoramaMSB, expressionMSB, generalPurpose1MSB, generalPurpose2MSB, generalPurpose3MSB, generalPurpose4MSB, bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB, generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB, sustain, porta, sustenuto, softPedal, hold2, generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth, dataIncrement, dataDecrement, nonRegisteredParameterLSB, nonRegisteredParameterMSB, registeredParameterLSB, registeredParameterMSB, Pitch, fromPitch, toPitch, Velocity, fromVelocity, toVelocity, Program, fromProgram, toProgram, CtrlP.Controller, CtrlP.fromController, CtrlP.toController, increasePitch, subtractPitch, frequencyFromPitch, maximumVelocity, normalVelocity, realFromVelocity, ) where import qualified Sound.MIDI.ControllerPrivate as CtrlP import qualified Sound.MIDI.Controller as Ctrl import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import Control.Monad (liftM, liftM2, ) import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit import Sound.MIDI.Monoid ((+#+)) import Data.Ix (Ix) import Sound.MIDI.Utility (checkRange, quantityRandomR, boundedQuantityRandom, chooseQuantity, enumRandomR, boundedEnumRandom, chooseEnum, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), ) -- * message type data T = NoteOff Pitch Velocity | NoteOn Pitch Velocity | PolyAftertouch Pitch Pressure | ProgramChange Program {- Shall we add support for registered parameters? -} | Control Ctrl.T ControllerValue | PitchBend PitchBendRange | MonoAftertouch Pressure deriving (Show, Eq, Ord) instance Arbitrary T where arbitrary = QC.frequency $ (10, liftM2 NoteOff arbitrary arbitrary) : (10, liftM2 NoteOn arbitrary arbitrary) : ( 1, liftM2 PolyAftertouch arbitrary (QC.choose (0,127))) : ( 1, liftM ProgramChange arbitrary) : ( 1, liftM2 Control arbitrary (QC.choose (0,127))) : ( 1, liftM PitchBend (QC.choose (0,12))) : ( 1, liftM MonoAftertouch (QC.choose (0,127))) : [] instance Random Pitch where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Pitch where arbitrary = chooseEnum instance Random Velocity where random = boundedQuantityRandom fromVelocity toVelocity randomR = quantityRandomR fromVelocity toVelocity instance Arbitrary Velocity where arbitrary = chooseQuantity fromVelocity toVelocity instance Random Program where random = boundedEnumRandom randomR = enumRandomR instance Arbitrary Program where arbitrary = chooseEnum isNote :: T -> Bool isNote (NoteOn _ _) = True isNote (NoteOff _ _) = True isNote _ = False {- | NoteOn with zero velocity is considered NoteOff according to MIDI specification. -} isNoteOn :: T -> Bool isNoteOn (NoteOn _ v) = v > toVelocity 0 isNoteOn _ = False {- | NoteOn with zero velocity is considered NoteOff according to MIDI specification. -} isNoteOff :: T -> Bool isNoteOff (NoteOn _ v) = v == toVelocity 0 isNoteOff (NoteOff _ _) = True isNoteOff _ = False {- | Convert all @NoteOn p 0@ to @NoteOff p 64@. The latter one is easier to process. -} explicitNoteOff :: T -> T explicitNoteOff msg = case msg of NoteOn p v -> if v == toVelocity 0 then NoteOff p $ toVelocity 64 else msg _ -> msg {- | Convert all @NoteOff p 64@ to @NoteOn p 0@. The latter one can be encoded more efficiently using the running status. -} implicitNoteOff :: T -> T implicitNoteOff msg = case msg of NoteOff p v -> if v == toVelocity 64 then NoteOn p $ toVelocity 0 else msg _ -> msg -- * Primitive types in Voice messages type PitchBendRange = Int type Pressure = Int type ControllerValue = Ctrl.Value newtype Pitch = Pitch {fromPitch :: Int} deriving (Show, Eq, Ord, Ix) newtype Velocity = Velocity {fromVelocity :: Int} deriving (Show, Eq, Ord) newtype Program = Program {fromProgram :: Int} deriving (Show, Eq, Ord, Ix) toPitch :: Int -> Pitch toPitch = checkRange "Pitch" Pitch toVelocity :: Int -> Velocity toVelocity = checkRange "Velocity" Velocity toProgram :: Int -> Program toProgram = checkRange "Program" Program instance Enum Pitch where toEnum = toPitch fromEnum = fromPitch {- I do not like an Enum Velocity instance, because Velocity is an artificially sampled continuous quantity. -} instance Enum Program where toEnum = toProgram fromEnum = fromProgram -- typical methods of a type class for affine spaces increasePitch :: Int -> Pitch -> Pitch increasePitch d = toPitch . (d+) . fromPitch subtractPitch :: Pitch -> Pitch -> Int subtractPitch (Pitch p0) (Pitch p1) = p1-p0 {- | Convert pitch to frequency according to the default tuning given in MIDI 1.0 Detailed Specification. -} frequencyFromPitch :: (Floating a) => Pitch -> a frequencyFromPitch (Pitch p) = 440 * 2 ** (fromIntegral (p + 3 - 6*12) / 12) instance Bounded Pitch where minBound = Pitch 0 maxBound = Pitch 127 {- | ToDo: We have defined minBound = Velocity 0, but strictly spoken the minimum Velocity is 1, since Velocity zero means NoteOff. One can at least think of NoteOff with (Velocity 0), but I have never seen that. -} instance Bounded Velocity where minBound = Velocity 0 maxBound = Velocity 127 instance Bounded Program where minBound = Program 0 maxBound = Program 127 {- | A MIDI problem is that one cannot uniquely map a MIDI key to a frequency. The frequency depends on the instrument. I don't know if the deviations are defined for General MIDI. If this applies one could add transposition information to the use patch map. For now I have chosen a value that leads to the right frequency for some piano sound in my setup. -} zeroKey :: Pitch zeroKey = toPitch 48 {- | The velocity of an ordinary key stroke and the maximum possible velocity. -} normalVelocity, maximumVelocity :: Velocity normalVelocity = Velocity 64 maximumVelocity = maxBound {- | MIDI specification says, if velocity is simply mapped to amplitude, then this should be done by an exponential function. Thus we map 'normalVelocity' (64) to 0, 'maximumVelocity' (127) to 1, and 'minimumVelocity' (1) to -1. That is, normally you should write something like @amplitude = 2 ** realFromVelocity vel@ or @3 ** realFromVelocity vel@. -} realFromVelocity :: (Fractional b) => Velocity -> b realFromVelocity (Velocity x) = fromIntegral (x - fromVelocity normalVelocity) / fromIntegral (fromVelocity maximumVelocity - fromVelocity normalVelocity) maximumControllerValue :: Num a => a maximumControllerValue = 127 {- | Map integral MIDI controller value to floating point value. Maximum integral MIDI controller value 127 is mapped to 1. Minimum integral MIDI controller value 0 is mapped to 0. -} realFromControllerValue :: (Integral a, Fractional b) => a -> b realFromControllerValue x = fromIntegral x / maximumControllerValue {- These definitions will be deprecated and then replaced by the ones from MIDI.Controller. -} -- * predefined MIDI controllers -- ** simple names for controllers, if only most-significant bytes are used bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, mainVolume, balance, panorama, expression, generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, vectorX, vectorY :: Ctrl.T bankSelect = bankSelectMSB modulation = modulationMSB breathControl = breathControlMSB footControl = footControlMSB portamentoTime = portamentoTimeMSB dataEntry = dataEntryMSB mainVolume = mainVolumeMSB balance = balanceMSB panorama = panoramaMSB expression = expressionMSB generalPurpose1 = generalPurpose1MSB generalPurpose2 = generalPurpose2MSB generalPurpose3 = generalPurpose3MSB generalPurpose4 = generalPurpose4MSB vectorX = generalPurpose1 vectorY = generalPurpose2 -- ** controllers for most-significant bytes of control values bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, portamentoTimeMSB, dataEntryMSB, mainVolumeMSB, balanceMSB, panoramaMSB, expressionMSB, generalPurpose1MSB, generalPurpose2MSB, generalPurpose3MSB, generalPurpose4MSB :: Ctrl.T -- ** controllers for least-significant bytes of control values bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB, generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB :: Ctrl.T -- ** additional single byte controllers sustain, porta, sustenuto, softPedal, hold2, generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth :: Ctrl.T -- ** increment/decrement and parameter numbers dataIncrement, dataDecrement, nonRegisteredParameterLSB, nonRegisteredParameterMSB, registeredParameterLSB, registeredParameterMSB :: Ctrl.T bankSelectMSB = toEnum 0x00 {- 00 00 -} modulationMSB = toEnum 0x01 {- 01 01 -} breathControlMSB = toEnum 0x02 {- 02 02 -} footControlMSB = toEnum 0x04 {- 04 04 -} portamentoTimeMSB = toEnum 0x05 {- 05 05 -} dataEntryMSB = toEnum 0x06 {- 06 06 -} mainVolumeMSB = toEnum 0x07 {- 07 07 -} balanceMSB = toEnum 0x08 {- 08 08 -} panoramaMSB = toEnum 0x0A {- 10 0A -} expressionMSB = toEnum 0x0B {- 11 0B -} generalPurpose1MSB = toEnum 0x10 {- 16 10 -} generalPurpose2MSB = toEnum 0x11 {- 17 11 -} generalPurpose3MSB = toEnum 0x12 {- 18 12 -} generalPurpose4MSB = toEnum 0x13 {- 19 13 -} bankSelectLSB = toEnum 0x20 {- 32 20 -} modulationLSB = toEnum 0x21 {- 33 21 -} breathControlLSB = toEnum 0x22 {- 34 22 -} footControlLSB = toEnum 0x24 {- 36 24 -} portamentoTimeLSB = toEnum 0x25 {- 37 25 -} dataEntryLSB = toEnum 0x26 {- 38 26 -} mainVolumeLSB = toEnum 0x27 {- 39 27 -} balanceLSB = toEnum 0x28 {- 40 28 -} panoramaLSB = toEnum 0x2A {- 42 2A -} expressionLSB = toEnum 0x2B {- 43 2B -} generalPurpose1LSB = toEnum 0x30 {- 48 30 -} generalPurpose2LSB = toEnum 0x31 {- 49 31 -} generalPurpose3LSB = toEnum 0x32 {- 50 32 -} generalPurpose4LSB = toEnum 0x33 {- 51 33 -} sustain = toEnum 0x40 {- 64 40 -} porta = toEnum 0x41 {- 65 41 -} sustenuto = toEnum 0x42 {- 66 42 -} softPedal = toEnum 0x43 {- 67 43 -} hold2 = toEnum 0x45 {- 69 45 -} generalPurpose5 = toEnum 0x50 {- 80 50 -} generalPurpose6 = toEnum 0x51 {- 81 51 -} generalPurpose7 = toEnum 0x52 {- 82 52 -} generalPurpose8 = toEnum 0x53 {- 83 53 -} extDepth = toEnum 0x5B {- 91 5B -} tremoloDepth = toEnum 0x5C {- 92 5C -} chorusDepth = toEnum 0x5D {- 93 5D -} celesteDepth = toEnum 0x5E {- 94 5E -} phaserDepth = toEnum 0x5F {- 95 5F -} dataIncrement = toEnum 0x60 {- 96 60 -} dataDecrement = toEnum 0x61 {- 97 61 -} nonRegisteredParameterLSB = toEnum 0x62 {- 98 62 -} nonRegisteredParameterMSB = toEnum 0x63 {- 99 63 -} registeredParameterLSB = toEnum 0x64 {- 100 64 -} registeredParameterMSB = toEnum 0x65 {- 101 65 -} -- * serialization get :: Parser.C parser => Int -> Int -> Parser.Fallible parser T get code firstData = let pitch = toPitch firstData getVel = liftM toVelocity get1 in case code of 08 -> liftM (NoteOff pitch) getVel 09 -> liftM (NoteOn pitch) getVel 10 -> liftM (PolyAftertouch pitch) get1 {- Whether firstData is a controller and not a mode is checked in Message.Channel.get. -} 11 -> liftM (Control (toEnum firstData)) get1 12 -> return (ProgramChange (toProgram firstData)) 13 -> return (MonoAftertouch firstData) 14 -> liftM (\msb -> PitchBend (firstData+128*msb)) get1 _ -> Parser.giveUp ("invalid Voice message code:" ++ show code) putWithStatus :: Writer.C writer => (Int -> StatusWriter.T writer) -> T -> StatusWriter.T writer putWithStatus putChan e = let putC code bytes = putChan code +#+ StatusWriter.fromWriter (Writer.putByteList (map fromIntegral bytes)) in case e of NoteOff p v -> putC 8 [fromPitch p, fromVelocity v] NoteOn p v -> putC 9 [fromPitch p, fromVelocity v] PolyAftertouch p pr -> putC 10 [fromPitch p, pr] Control cn cv -> putC 11 [fromEnum cn, cv] ProgramChange pn -> putC 12 [fromProgram pn] MonoAftertouch pr -> putC 13 [pr] PitchBend pb -> let (hi,lo) = Bit.splitAt 7 pb in putC 14 [lo,hi] -- little-endian!! midi-0.2.0.1/src/Sound/MIDI/File/0000755000000000000000000000000011753275103014244 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/File/Load.hs0000644000000000000000000002345011753275103015463 0ustar0000000000000000{- | Loading MIDI Files This module loads and parses a MIDI File. It can convert it into a 'MIDIFile.T' data type object or simply print out the contents of the file. -} {- The MIDI file format is quite similar to the Interchange File Format (IFF) of Electronic Arts. But it seems to be not sensible to re-use functionality from the @iff@ package. -} module Sound.MIDI.File.Load (fromFile, fromByteList, maybeFromByteList, maybeFromByteString, showFile, ) where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as Event import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, readBinaryFile, ) -- import qualified Sound.MIDI.Bit as Bit import Sound.MIDI.String (unlinesS) import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as RestrictedParser import qualified Sound.MIDI.Parser.ByteString as ByteStringParser import qualified Sound.MIDI.Parser.Stream as StreamParser import qualified Sound.MIDI.Parser.File as FileParser import qualified Sound.MIDI.Parser.Status as StatusParser import qualified Sound.MIDI.Parser.Report as Report import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, liftM2, ) import qualified Data.ByteString.Lazy as B import qualified Control.Monad.Exception.Asynchronous as Async -- import qualified Control.Monad.Exception.Synchronous as Sync -- import System.IO (hPutStrLn, stderr, ) import Data.List (genericReplicate, genericLength, ) import Data.Maybe (catMaybes, ) {- | The main load function. Warnings are written to standard error output and an error is signaled by a user exception. This function will not be appropriate in GUI applications. For these, use 'maybeFromByteString' instead. -} fromFile :: FilePath -> IO MIDIFile.T fromFile = FileParser.runIncompleteFile parse {- fromFile :: FilePath -> IO MIDIFile.T fromFile filename = do report <- fmap maybeFromByteList $ readBinaryFile filename mapM_ (hPutStrLn stderr . ("MIDI.File.Load warning: " ++)) (StreamParser.warnings report) either (ioError . userError . ("MIDI.File.Load error: " ++)) return (StreamParser.result report) -} {- | This function ignores warnings, turns exceptions into errors, and return partial results without warnings. Use this only in testing but never in production code! -} fromByteList :: ByteList -> MIDIFile.T fromByteList contents = either error id (Report.result (maybeFromByteList contents)) maybeFromByteList :: ByteList -> Report.T MIDIFile.T maybeFromByteList = StreamParser.runIncomplete parse . StreamParser.ByteList maybeFromByteString :: B.ByteString -> Report.T MIDIFile.T maybeFromByteString = ByteStringParser.runIncomplete parse {- | A MIDI file is made of /chunks/, each of which is either a /header chunk/ or a /track chunk/. To be correct, it must consist of one header chunk followed by any number of track chunks, but for robustness's sake we ignore any non-header chunks that come before a header chunk. The header tells us the number of tracks to come, which is passed to 'getTracks'. -} parse :: Parser.C parser => Parser.Partial (Parser.Fallible parser) MIDIFile.T parse = getChunk >>= \ (typ, hdLen) -> case typ of "MThd" -> do (format, nTracks, division) <- RestrictedParser.runFallible hdLen getHeader excTracks <- lift $ Parser.zeroOrMoreInc (getTrackChunk >>= Async.mapM (lift . liftMaybe removeEndOfTrack)) flip Async.mapM excTracks $ \tracks -> do let n = genericLength tracks lift $ Parser.warnIf (n /= nTracks) ("header says " ++ show nTracks ++ " tracks, but " ++ show n ++ " tracks were found") return (MIDIFile.Cons format division $ catMaybes tracks) _ -> lift (Parser.warn ("found Alien chunk <" ++ typ ++ ">")) >> Parser.skip hdLen >> parse liftMaybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) liftMaybe f = maybe (return Nothing) (liftM Just . f) {- | There are two ways to mark the end of the track: The end of the event list and the meta event 'EndOfTrack'. Thus the end marker is redundant and we remove a 'EndOfTrack' at the end of the track and complain about all 'EndOfTrack's within the event list. -} removeEndOfTrack :: Parser.C parser => Track -> parser Track removeEndOfTrack xs = maybe (Parser.warn "Empty track, missing EndOfTrack" >> return xs) (\(initEvents, lastEvent) -> let (eots, track) = EventList.partition isEndOfTrack initEvents in do Parser.warnIf (not $ EventList.null eots) "EndOfTrack inside a track" Parser.warnIf (not $ isEndOfTrack $ snd lastEvent) "Track does not end with EndOfTrack" return track) (EventList.viewR xs) isEndOfTrack :: Event.T -> Bool isEndOfTrack ev = case ev of Event.MetaEvent MetaEvent.EndOfTrack -> True _ -> False {- removeEndOfTrack :: Track -> Track removeEndOfTrack = maybe (error "Track does not end with EndOfTrack") (\(ev,evs) -> case snd ev of MetaEvent EndOfTrack -> if EventList.null evs then evs else error "EndOfTrack inside a track" _ -> uncurry EventList.cons ev (removeEndOfTrack evs)) . EventList.viewL -} {- | Parse a chunk, whether a header chunk, a track chunk, or otherwise. A chunk consists of a four-byte type code (a header is @MThd@; a track is @MTrk@), four bytes for the size of the coming data, and the data itself. -} getChunk :: Parser.C parser => Parser.Fallible parser (String, NonNeg.Integer) getChunk = liftM2 (,) (getString 4) -- chunk type: header or track (getNByteCardinal 4) -- chunk body getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fallible parser) (Maybe Track) getTrackChunk = do (typ, len) <- getChunk if typ=="MTrk" then liftM (fmap Just) $ lift $ RestrictedParser.run len $ StatusParser.run getTrack else lift (Parser.warn ("found Alien chunk <" ++ typ ++ "> in track section")) >> Parser.skip len >> return (Async.pure Nothing) {- | Parse a Header Chunk. A header consists of a format (0, 1, or 2), the number of track chunks to come, and the smallest time division to be used in reading the rest of the file. -} getHeader :: Parser.C parser => Parser.Fallible parser (MIDIFile.Type, NonNeg.Int, Division) getHeader = do format <- makeEnum =<< get2 nTracks <- liftM (NonNeg.fromNumberMsg "MIDI.Load.getHeader") get2 division <- getDivision return (format, nTracks, division) {- | The division is implemented thus: the most significant bit is 0 if it's in ticks per quarter note; 1 if it's an SMPTE value. -} getDivision :: Parser.C parser => Parser.Fallible parser Division getDivision = do x <- get1 y <- get1 return $ if x < 128 then Ticks (NonNeg.fromNumberMsg "MIDI.Load.getDivision" (x*256+y)) else SMPTE (256-x) y {- | A track is a series of events. Parse a track, stopping when the size is zero. -} getTrack :: Parser.C parser => Parser.Partial (StatusParser.T parser) MIDIFile.Track getTrack = liftM (fmap EventList.fromPairList) (Parser.zeroOrMore Event.getTrackEvent) -- * show contents of a MIDI file for debugging {-# DEPRECATED showFile "only use this for debugging" #-} {- | Functions to show the decoded contents of a MIDI file in an easy-to-read format. This is for debugging purposes and should not be used in production code. -} showFile :: FilePath -> IO () showFile fileName = putStr . showChunks =<< readBinaryFile fileName showChunks :: ByteList -> String showChunks mf = showMR (lift getChunks) (\(Async.Exceptional me cs) -> unlinesS (map pp cs) . maybe id (\e -> showString ("incomplete chunk list: " ++ e ++ "\n")) me) mf "" where pp :: (String, ByteList) -> ShowS pp ("MThd",contents) = showString "Header: " . showMR getHeader shows contents pp ("MTrk",contents) = showString "Track:\n" . showMR (lift $ StatusParser.run getTrack) (\(Async.Exceptional me track) str -> EventList.foldr MIDIFile.showTime (\e -> MIDIFile.showEvent e . showString "\n") (maybe "" (\e -> "incomplete track: " ++ e ++ "\n") me ++ str) track) contents pp (ty,contents) = showString "Alien Chunk: " . showString ty . showString " " . shows contents . showString "\n" showMR :: Parser.Fallible (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS showMR m pp contents = let report = StreamParser.run m (StreamParser.ByteList contents) in unlinesS (map showString $ Report.warnings report) . either showString pp (Report.result report) {- | The two functions, the 'getChunk' and 'getChunks' parsers, do not combine directly into a single master parser. Rather, they should be used to chop parts of a midi file up into chunks of bytes which can be outputted separately. Chop a MIDI file into chunks returning: * list of /chunk-type/-contents pairs; and * leftover slop (should be empty in correctly formatted file) -} getChunks :: Parser.C parser => Parser.Partial parser [(String, ByteList)] getChunks = Parser.zeroOrMore $ do (typ, len) <- getChunk body <- sequence (genericReplicate len getByte) return (typ, body) midi-0.2.0.1/src/Sound/MIDI/File/Save.hs0000644000000000000000000000716511753275103015507 0ustar0000000000000000{- | Save MIDI data to files. The functions in this module allow 'Sound.MIDI.File.T's to be written into Standard MIDI files (@*.mid@) that can be read and played by music programs such as Cakewalk. -} module Sound.MIDI.File.Save (toSeekableFile, toFile, toByteList, toByteString, toCompressedByteString, ) where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile import qualified Sound.MIDI.File.Event as Event import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Monoid as M import Sound.MIDI.Monoid ((+#+)) import qualified Data.Monoid.Reader as Reader import qualified Data.Monoid.Transformer as Trans import Sound.MIDI.IO (ByteList, writeBinaryFile, ) import qualified Data.ByteString.Lazy as B {- | Directly write to a file. Since chunks lengths are not known before writing, we need to seek in a file. Thus you cannot write to pipes with this function. -} toSeekableFile :: FilePath {- ^ file name -} -> MIDIFile.T -> IO () toSeekableFile fn = Writer.runSeekableFile fn . StatusWriter.toWriterWithoutStatus . put {- | The function 'toFile' is the main function for writing 'MIDIFile.T' values to an actual file. -} toFile :: FilePath {- ^ file name -} -> MIDIFile.T -> IO () toFile fn mf = writeBinaryFile fn (toByteList mf) {- MIDI files are first converted to a monadic string computation using the function 'put', and then \"executed\" using 'execWriter'. -} {- | Convert a MIDI file to a 'ByteList'. -} toByteList :: MIDIFile.T -> ByteList toByteList = Writer.runByteList . StatusWriter.toWriterWithoutStatus . put {- | Convert a MIDI file to a lazy 'B.ByteString'. -} toByteString :: MIDIFile.T -> B.ByteString toByteString = Writer.runByteString . StatusWriter.toWriterWithoutStatus . put {- | Convert a MIDI file to a lazy 'B.ByteString'. It converts @NoteOff p 64@ to @NoteOn p 0@ and then uses the running MIDI status in order to compress the file. -} toCompressedByteString :: MIDIFile.T -> B.ByteString toCompressedByteString = Writer.runByteString . StatusWriter.toWriterWithStatus . put . MIDIFile.implicitNoteOff put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer put (MIDIFile.Cons mft divisn trks) = (putChunk "MThd" $ StatusWriter.lift $ Writer.putInt 2 (fromEnum mft) +#+ -- format (type 0, 1 or 2) Writer.putInt 2 (length trks) +#+ -- number of tracks to come putDivision divisn) -- time unit +#+ M.concatMap putTrack trks putDivision :: Writer.C writer => Division -> writer putDivision (Ticks nticks) = Writer.putInt 2 (NonNeg.toNumber nticks) putDivision (SMPTE mode nticks) = Writer.putIntAsByte (256-mode) +#+ Writer.putIntAsByte nticks putTrack :: Writer.C writer => Track -> StatusWriter.T writer putTrack trk = putChunk "MTrk" $ EventList.concatMapMonoid (StatusWriter.lift . Writer.putVar) Event.put $ EventList.snoc trk 0 (Event.MetaEvent MetaEvent.EndOfTrack) putChunk :: Writer.C writer => String -> StatusWriter.T writer -> StatusWriter.T writer putChunk tag m = StatusWriter.lift (putTag tag) +#+ StatusWriter.Cons (Reader.Cons $ \compress -> Trans.lift $ Writer.putLengthBlock 4 $ StatusWriter.toWriter compress m) putTag :: Writer.C writer => String -> writer putTag tag@(_:_:_:_:[]) = Writer.putStr tag putTag tag = error ("SaveMIDI.putChunk: Chunk name " ++ tag ++ " does not consist of 4 characters.") midi-0.2.0.1/src/Sound/MIDI/File/Event.hs0000644000000000000000000000670611753275103015672 0ustar0000000000000000{- | MIDI messages in MIDI files. They are not a superset of the messages, that are used for real-time communication between MIDI devices. For these refer to "Sound.MIDI.Message". Namely System Common and System Real Time messages are missing. If you need both real-time and file messages (say for ALSA sequencer), you need a custom datatype. -} module Sound.MIDI.File.Event ( T(..), get, put, TrackEvent, getTrackEvent, ElapsedTime, fromElapsedTime, toElapsedTime, mapBody, maybeMIDIEvent, maybeMetaEvent, maybeVoice, mapVoice, ) where import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as Voice import qualified Sound.MIDI.File.Event.SystemExclusive as SysEx import qualified Sound.MIDI.File.Event.Meta as MetaEvent import Sound.MIDI.Message.Channel (Channel) import Sound.MIDI.File.Event.Meta ( ElapsedTime, fromElapsedTime, toElapsedTime, ) import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Status as StatusParser import qualified Sound.MIDI.Parser.Class as Parser import Control.Monad (liftM, liftM2, ) import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) import Sound.MIDI.Utility (mapSnd) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC type TrackEvent = (ElapsedTime, T) mapBody :: (T -> T) -> (TrackEvent -> TrackEvent) mapBody = mapSnd data T = MIDIEvent ChannelMsg.T | MetaEvent MetaEvent.T | SystemExclusive SysEx.T deriving (Show,Eq,Ord) instance Arbitrary T where arbitrary = QC.frequency $ (100, liftM MIDIEvent arbitrary) : ( 1, liftM MetaEvent arbitrary) : [] maybeMIDIEvent :: T -> Maybe ChannelMsg.T maybeMIDIEvent (MIDIEvent msg) = Just msg maybeMIDIEvent _ = Nothing maybeMetaEvent :: T -> Maybe MetaEvent.T maybeMetaEvent (MetaEvent mev) = Just mev maybeMetaEvent _ = Nothing maybeVoice :: T -> Maybe (Channel, Voice.T) maybeVoice (MIDIEvent (ChannelMsg.Cons ch (ChannelMsg.Voice ev))) = Just (ch,ev) maybeVoice _ = Nothing mapVoice :: (Voice.T -> Voice.T) -> T -> T mapVoice f (MIDIEvent (ChannelMsg.Cons ch (ChannelMsg.Voice ev))) = MIDIEvent (ChannelMsg.Cons ch (ChannelMsg.Voice (f ev))) mapVoice _ msg = msg -- * serialization get :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T get = StatusParser.lift get1 >>= \tag -> if tag < 0xF0 then liftM MIDIEvent $ ChannelMsg.getWithStatus tag else StatusParser.set Nothing >> (StatusParser.lift $ if tag == 0xFF then liftM MetaEvent $ MetaEvent.get else liftM SystemExclusive $ SysEx.get tag) {- | Each event is preceded by the delta time: the time in ticks between the last event and the current event. Parse a time and an event, ignoring System Exclusive messages. -} getTrackEvent :: Parser.C parser => Parser.Fallible (StatusParser.T parser) TrackEvent getTrackEvent = liftM2 (,) (StatusParser.lift getVar) get {- | The following functions encode various 'MIDIFile.T' elements into the raw data of a standard MIDI file. -} put :: Writer.C writer => T -> StatusWriter.T writer put e = case e of MIDIEvent m -> StatusWriter.lift (ChannelMsg.put m) MetaEvent m -> StatusWriter.clear +#+ StatusWriter.lift (MetaEvent.put m) SystemExclusive m -> StatusWriter.clear +#+ StatusWriter.lift (SysEx.put m) midi-0.2.0.1/src/Sound/MIDI/File/Event/0000755000000000000000000000000011753275103015325 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/File/Event/Meta.hs0000644000000000000000000001352711753275103016557 0ustar0000000000000000module Sound.MIDI.File.Event.Meta ( T(..), ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, defltTempo, SMPTEHours, SMPTEMinutes, SMPTESeconds, SMPTEFrames, SMPTEBits, get, put, ) where import Sound.MIDI.Message.Channel (Channel, toChannel, fromChannel, ) import qualified Sound.MIDI.KeySignature as KeySig import Sound.MIDI.Parser.Primitive (get1, get2, get3, getVar, getBigN, ) import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as ParserRestricted import Control.Monad (liftM, liftM4, liftM5, ) import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit import Sound.MIDI.Monoid ((+#+)) import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, listCharFromByte, listByteFromChar, ) import Sound.MIDI.Utility (arbitraryString, arbitraryByteList, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC import Prelude hiding (putStr, ) {- * Meta Events -} type ElapsedTime = NonNeg.Integer type Tempo = NonNeg.Int type SMPTEHours = Int type SMPTEMinutes = Int type SMPTESeconds = Int type SMPTEFrames = Int type SMPTEBits = Int data T = SequenceNum Int | TextEvent String | Copyright String | TrackName String | InstrumentName String | Lyric String | Marker String | CuePoint String | MIDIPrefix Channel | EndOfTrack | SetTempo Tempo | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits | TimeSig Int Int Int Int | KeySig KeySig.T | SequencerSpecific ByteList | Unknown Int ByteList deriving (Show, Eq, Ord) instance Arbitrary T where arbitrary = QC.oneof $ liftM SequenceNum (QC.choose (0,0xFFFF)) : liftM TextEvent arbitraryString : liftM Copyright arbitraryString : liftM TrackName arbitraryString : liftM InstrumentName arbitraryString : liftM Lyric arbitraryString : liftM Marker arbitraryString : liftM CuePoint arbitraryString : liftM (MIDIPrefix . toChannel) (QC.choose (0,15)) : -- return EndOfTrack : liftM (SetTempo . NonNeg.fromNumberMsg "Tempo always positive") (QC.choose (0,0xFFFFFF)) : liftM5 SMPTEOffset arbitraryByte arbitraryByte arbitraryByte arbitraryByte arbitraryByte : liftM4 TimeSig arbitraryByte arbitraryByte arbitraryByte arbitraryByte : liftM KeySig arbitrary : liftM SequencerSpecific arbitraryByteList : -- liftM Unknown arbitrary arbitraryByteList : [] arbitraryByte :: QC.Gen Int arbitraryByte = QC.choose (0,0xFF::Int) toElapsedTime :: Integer -> ElapsedTime toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime" fromElapsedTime :: ElapsedTime -> Integer fromElapsedTime = NonNeg.toNumber toTempo :: Int -> Tempo toTempo = NonNeg.fromNumberMsg "toTempo" fromTempo :: Tempo -> Int fromTempo = NonNeg.toNumber {- | The default SetTempo value, in microseconds per quarter note. This expresses the default of 120 beats per minute. -} defltTempo :: Tempo defltTempo = 500000 -- * serialization get :: Parser.C parser => Parser.Fallible parser T get = do code <- get1 len <- getVar let parse = ParserRestricted.runFallible len let returnText cons = liftM (cons . listCharFromByte) $ getBigN len case code of 000 -> parse $ liftM SequenceNum get2 001 -> returnText TextEvent 002 -> returnText Copyright 003 -> returnText TrackName 004 -> returnText InstrumentName 005 -> returnText Lyric 006 -> returnText Marker 007 -> returnText CuePoint 032 -> parse $ liftM (MIDIPrefix . toChannel) get1 047 -> return EndOfTrack 081 -> parse $ liftM (SetTempo . toTempo) get3 084 -> parse $ do {hrs <- get1 ; mins <- get1 ; secs <- get1; frames <- get1 ; bits <- get1 ; return (SMPTEOffset hrs mins secs frames bits)} 088 -> parse $ do n <- get1 d <- get1 c <- get1 b <- get1 return (TimeSig n d c b) 089 -> parse $ liftM KeySig KeySig.get 127 -> liftM SequencerSpecific $ getBigN len _ -> liftM (Unknown code) $ getBigN len put :: Writer.C writer => T -> writer put ev = Writer.putByte 255 +#+ case ev of SequenceNum num -> putInt 0 2 num TextEvent s -> putStr 1 s Copyright s -> putStr 2 s TrackName s -> putStr 3 s InstrumentName s -> putStr 4 s Lyric s -> putStr 5 s Marker s -> putStr 6 s CuePoint s -> putStr 7 s MIDIPrefix c -> putList 32 [fromChannel c] EndOfTrack -> putList 47 [] SetTempo tp -> putInt 81 3 (fromTempo tp) SMPTEOffset hr mn se fr ff -> putList 84 [hr,mn,se,fr,ff] TimeSig n d c b -> putList 88 [n,d,c,b] KeySig key -> putList 89 $ KeySig.toBytes key SequencerSpecific codes -> putByteList 127 codes Unknown typ s -> putByteList typ s putByteList :: Writer.C writer => Int -> ByteList -> writer putByteList code bytes = Writer.putIntAsByte code +#+ Writer.putLenByteList bytes putInt :: Writer.C writer => Int -> Int -> Int -> writer putInt code numBytes x = Writer.putIntAsByte code +#+ Writer.putVar (fromIntegral numBytes) +#+ Writer.putByteList (map fromIntegral $ Bit.someBytes numBytes x) putStr :: Writer.C writer => Int -> String -> writer putStr code = putByteList code . listByteFromChar putList :: Writer.C writer => Int -> [Int] -> writer putList code = putByteList code . map fromIntegral midi-0.2.0.1/src/Sound/MIDI/File/Event/SystemExclusive.hs0000644000000000000000000000255511753275103021044 0ustar0000000000000000module Sound.MIDI.File.Event.SystemExclusive (T(..), get, put, ) where import Sound.MIDI.IO (ByteList) import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) import Control.Monad (liftM, ) {-# DEPRECATED T "implement this data type properly" #-} {- | There are three forms of System Exclusive Messages in MIDI files: monolithic, chopped into packets, escape form (with unrestricted binary data). Currently we only support first and last type explicitly. But we leave the trailing 0xF7 markers which can be used to detect whether the messages are actually meant as packets. Since I don't know where manufacturer information is in the packets form, I omit manufacturer handling for now. -} data T = Regular ByteList -- F0 | Escape ByteList -- F7 deriving (Show, Eq, Ord) get :: Parser.C parser => Int -> Parser.Fallible parser T get tag = case tag of 0xF0 -> liftM Regular $ getBigN =<< getVar 0xF7 -> liftM Escape $ getBigN =<< getVar _ -> Parser.giveUp "SystemExclusive: unkown message type" put :: Writer.C writer => T -> writer put sysex = case sysex of Regular bytes -> Writer.putByte 0xF0 +#+ Writer.putLenByteList bytes Escape bytes -> Writer.putByte 0xF7 +#+ Writer.putLenByteList bytes midi-0.2.0.1/src/Sound/MIDI/Writer/0000755000000000000000000000000011753275103014641 5ustar0000000000000000midi-0.2.0.1/src/Sound/MIDI/Writer/Status.hs0000644000000000000000000000332111753275103016457 0ustar0000000000000000module Sound.MIDI.Writer.Status ( module Sound.MIDI.Writer.Status, lift, ) where -- import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Parser.Status (Channel) import qualified Data.Monoid.State as State import qualified Data.Monoid.Reader as Reader import qualified Data.Monoid.Transformer as Trans import Data.Monoid.Transformer (lift, ) import Data.Monoid (Monoid, mempty, mappend, mconcat, ) import Sound.MIDI.Monoid (genAppend, genConcat, ) type Status = Maybe (Int,Channel) {- | The ReaderT Bool handles whether running status should be respected (True) or ignored (False). -} newtype T writer = Cons {decons :: Reader.T Bool (State.T (Maybe Status) writer)} instance Monoid writer => Monoid (T writer) where mempty = Cons $ mempty mappend = genAppend Cons decons mconcat = genConcat Cons decons {- | Given a writer that emits a status, generate a stateful writer, that decides whether to run the status emittor. -} change :: (Monoid writer) => Status -> writer -> T writer change x emit = Cons $ Reader.Cons $ \b -> State.Cons $ \my -> let mx = Just x in (if not b || mx/=my then emit else mempty, mx) clear :: (Monoid writer) => T writer clear = Cons $ lift $ State.put Nothing instance Trans.C T where lift = fromWriter fromWriter :: (Monoid writer) => writer -> T writer fromWriter = Cons . lift . lift toWriter :: (Monoid writer) => Bool -> T writer -> writer toWriter withStatus = State.evaluate Nothing . flip Reader.run withStatus . decons toWriterWithStatus :: (Monoid writer) => T writer -> writer toWriterWithStatus = toWriter True toWriterWithoutStatus :: (Monoid writer) => T writer -> writer toWriterWithoutStatus = toWriter False midi-0.2.0.1/src/Sound/MIDI/Writer/Basic.hs0000644000000000000000000001152311753275103016220 0ustar0000000000000000module Sound.MIDI.Writer.Basic where import qualified Numeric.NonNegative.Wrapper as NonNeg import qualified Sound.MIDI.Bit as Bit import qualified Sound.MIDI.IO as MIO import qualified Sound.MIDI.Monoid as M import qualified Data.Monoid as Monoid import Data.Bits ((.|.)) import Sound.MIDI.IO (listByteFromChar, ) import Data.Monoid (Monoid, mempty, mappend, mconcat, ) import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, ) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, ) import Control.Monad.Trans.Class (lift, ) import Data.List (genericLength, ) import Data.Word (Word8, ) import Data.Char (chr, ) import qualified Data.ByteString.Lazy as B import qualified Data.Binary.Builder as Builder import Data.Binary.Builder (Builder, fromLazyByteString, ) import Control.Exception (bracket, ) import qualified System.IO as IO import System.IO (openBinaryFile, hClose, hPutChar, Handle, IOMode(WriteMode)) -- import System.IO.Error (ioError, userError) import Prelude hiding (putStr, ) class Monoid m => C m where putByte :: Word8 -> m {- | @putLengthBlock n writeBody@ write @n@ bytes indicating the number of bytes written by @writeBody@ and then it runs @writeBody@. -} putLengthBlock :: Int -> m -> m -- differences list newtype ByteList = ByteList {unByteList :: Monoid.Endo MIO.ByteList} instance Monoid ByteList where mempty = ByteList mempty mappend = genAppend ByteList unByteList mconcat = genConcat ByteList unByteList instance C ByteList where putByte = ByteList . Monoid.Endo . (:) putLengthBlock n writeBody = let body = runByteList writeBody in putInt n (length body) `mappend` putByteListSpec body -- we could call 'writeBody' but this would recompute the data -- | 'putByteList' specialised to 'ByteList' putByteListSpec :: MIO.ByteList -> ByteList putByteListSpec = ByteList . Monoid.Endo . (++) runByteList :: ByteList -> MIO.ByteList runByteList = flip Monoid.appEndo [] . unByteList newtype ByteString = ByteString {unByteString :: Builder} instance Monoid ByteString where mempty = ByteString $ mempty mappend = genAppend ByteString unByteString mconcat = genConcat ByteString unByteString instance C ByteString where putByte = ByteString . Builder.singleton putLengthBlock n writeBody = let body = runByteString writeBody len = B.length body errLen = if len >= div (256^n) 2 then error "Chunk too large" else fromIntegral len in putInt n errLen +#+ ByteString (fromLazyByteString body) runByteString :: ByteString -> B.ByteString runByteString = Builder.toLazyByteString . unByteString newtype SeekableFile = SeekableFile {unSeekableFile :: ReaderT Handle IO ()} instance Monoid SeekableFile where mempty = SeekableFile $ return () mappend x y = SeekableFile $ unSeekableFile x >> unSeekableFile y mconcat xs = SeekableFile $ mapM_ unSeekableFile xs instance C SeekableFile where putByte c = SeekableFile $ ask >>= \h -> lift $ hPutChar h (chr $ fromIntegral c) putLengthBlock n writeBody = SeekableFile $ ask >>= \h -> lift $ do lenPos <- IO.hGetPosn h IO.hPutStr h (replicate n '\000') startPos <- IO.hTell h runSeekableHandle h writeBody stopPos <- IO.hTell h contPos <- IO.hGetPosn h IO.hSetPosn lenPos let len = stopPos - startPos if len >= 2^(31::Int) then ioError (userError ("chunk too large, size " ++ show len)) else runSeekableHandle h (putInt n (fromInteger len)) IO.hSetPosn contPos runSeekableFile :: FilePath -> SeekableFile -> IO () runSeekableFile name w = bracket (openBinaryFile name WriteMode) hClose (flip runSeekableHandle w) runSeekableHandle :: Handle -> SeekableFile -> IO () runSeekableHandle h w = runReaderT (unSeekableFile w) h putInt :: C writer => Int -> Int -> writer putInt a = putByteList . map fromIntegral . Bit.someBytes a putStr :: C writer => String -> writer putStr = putByteList . listByteFromChar putIntAsByte :: C writer => Int -> writer putIntAsByte x = putByte $ fromIntegral x putByteList :: C writer => MIO.ByteList -> writer putByteList = M.concatMap putByte putLenByteList :: C writer => MIO.ByteList -> writer putLenByteList bytes = putVar (genericLength bytes) +#+ putByteList bytes {- | Numbers of variable size are represented by sequences of 7-bit blocks tagged (in the top bit) with a bit indicating: (1) that more data follows; or (0) that this is the last block. -} putVar :: C writer => NonNeg.Integer -> writer putVar n = let bytes = map fromIntegral $ Bit.toBase 128 n in case bytes of [] -> putInt 1 0 (_:bs) -> let highBits = map (const 128) bs ++ [0] in putByteList (zipWith (.|.) highBits bytes) midi-0.2.0.1/test/0000755000000000000000000000000011753275103011743 5ustar0000000000000000midi-0.2.0.1/test/Main.hs0000644000000000000000000002077011753275103013171 0ustar0000000000000000{- ToDo: check whether load of randomly corrupted files yields Parser errors rather than 'undefined'. Check parsing and serialization of MIDI messages. -} module Main where import qualified Sound.MIDI.File as MidiFile import qualified Sound.MIDI.File.Load as Load import qualified Sound.MIDI.File.Save as Save import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as Event import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Parser.Report as Report import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Stream as StreamParser import qualified Data.EventList.Relative.TimeBody as EventList import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.ByteString.Lazy as B import qualified Data.List as List import Sound.MIDI.Utility (viewR, dropMatch, ) import Control.Monad.Trans.Class (lift, ) import Control.Monad (when, ) import System.Random (mkStdGen, randomR, ) import qualified Numeric.NonNegative.Wrapper as NonNeg import Test.QuickCheck (quickCheck, ) -- import Debug.Trace (trace) testMidiName :: FilePath testMidiName = "quickcheck-test.mid" exampleEmpty :: MidiFile.T exampleEmpty = MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) [EventList.empty] exampleMeta :: MidiFile.T exampleMeta = MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) [EventList.cons 0 (Event.MetaEvent (MetaEvent.Lyric "foobarz")) EventList.empty] exampleStatus :: MidiFile.T exampleStatus = let chan = ChannelMsg.toChannel 3 vel = VoiceMsg.toVelocity 64 in MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) [0 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 20) vel))) ./ 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 24) vel))) ./ 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 27) vel))) ./ 7 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 20) vel))) ./ 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 24) vel))) ./ 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 27) vel))) ./ EventList.empty] runExample :: MidiFile.T -> IO () runExample example = let bin = Save.toByteString example struct = Load.maybeFromByteString bin report = Report.Cons [] (Right example) in B.writeFile testMidiName bin >> print (struct == report) >> when (struct/=report) (print struct >> print report) -- provoke a test failure in order to see some examples of Arbitrary MIDI files checkArbitrary :: MidiFile.T -> Bool checkArbitrary (MidiFile.Cons _typ _division tracks) = length (EventList.toPairList (EventList.concat tracks)) < 10 saveLoadByteString :: MidiFile.T -> Bool saveLoadByteString midi = let bin = Save.toByteString midi struct = Load.maybeFromByteString bin report = Report.Cons [] (Right midi) in struct == report saveLoadCompressedByteString :: MidiFile.T -> Bool saveLoadCompressedByteString midi = let bin = Save.toCompressedByteString midi struct = Load.maybeFromByteString bin report = Report.Cons [] (Right (MidiFile.implicitNoteOff midi)) in struct == report saveLoadMaybeByteList :: MidiFile.T -> Bool saveLoadMaybeByteList midi = let bin = Save.toByteList midi struct = Load.maybeFromByteList bin report = Report.Cons [] (Right midi) in struct == report saveLoadByteList :: MidiFile.T -> Bool saveLoadByteList midi = midi == Load.fromByteList (Save.toByteList midi) saveLoadFile :: MidiFile.T -> IO Bool saveLoadFile midi = do Save.toSeekableFile testMidiName midi struct <- Load.fromFile testMidiName return $ struct == midi loadSaveByteString :: MidiFile.T -> Bool loadSaveByteString midi0 = let bin0 = Save.toByteString midi0 in case Load.maybeFromByteString bin0 of Report.Cons [] (Right midi1) -> bin0 == Save.toByteString midi1 _ -> False loadSaveCompressedByteString :: MidiFile.T -> Bool loadSaveCompressedByteString midi0 = let bin0 = Save.toCompressedByteString midi0 in case Load.maybeFromByteString bin0 of Report.Cons [] (Right midi1) -> bin0 == Save.toByteString midi1 _ -> False loadSaveByteList :: MidiFile.T -> Bool loadSaveByteList midi0 = let bin0 = Save.toByteList midi0 in case Load.maybeFromByteList bin0 of Report.Cons [] (Right midi1) -> bin0 == Save.toByteList midi1 _ -> False restrictionByteList :: MidiFile.T -> Bool restrictionByteList midi = let bin = Save.toByteList midi in Load.fromByteList bin == Load.fromByteList (bin++[undefined]) lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool lazinessZeroOrMoreByteList pos byte = let result = Report.result $ StreamParser.runIncomplete (lift (Parser.zeroOrMore Parser.getByte)) $ StreamParser.ByteList $ repeat $ fromIntegral byte char = show result !! mod (NonNeg.toNumber pos) 1000 in char == char lazinessByteList :: MidiFile.T -> Bool lazinessByteList (MidiFile.Cons typ divsn tracks00) = let tracks0 = filter (not . EventList.null) tracks00 bin0 = Save.toByteList (MidiFile.Cons typ divsn tracks0) {- remove trailing EndOfTrack and its time stamp and replace the last by bin1 = take (length bin0 - 5) bin0 ++ [undefined] -} bin1 = init bin0 ++ [undefined] (MidiFile.Cons _ _ tracks1) = Load.fromByteList bin1 in case viewR tracks0 of Just (initTracks0, lastTrack0) -> List.isPrefixOf initTracks0 tracks1 && let (lastTrack1:_) = dropMatch initTracks0 tracks1 in List.isPrefixOf (init (EventList.toPairList lastTrack0)) (EventList.toPairList lastTrack1) {- fmap fst (EventList.viewR lastTrack0) == fmap fst (EventList.viewR lastTrack1) -} _ -> True {- | Check whether corruptions in a file are properly detected and do not trap into an errors. -} corruptionByteString :: Int -> Int -> MidiFile.T -> Bool corruptionByteString seed replacement midi = let bin = Save.toByteString midi n = fst $ randomR (0, fromIntegral $ B.length bin :: Int) (mkStdGen seed) (pre, post) = B.splitAt (fromIntegral n) bin replaceByte = fromIntegral replacement corruptBin = B.append pre (if B.null post then B.singleton replaceByte else B.cons replaceByte (B.tail post)) in -- trace (show (B.unpack corruptBin)) $ case Load.maybeFromByteString corruptBin of Report.Cons _ _ -> True corruptionByteList :: Int -> Int -> MidiFile.T -> Bool corruptionByteList seed replacement midi = let bin = Save.toByteList midi n = fst $ randomR (0, length bin) (mkStdGen seed) (pre, post) = splitAt n bin corruptBin = pre ++ fromIntegral replacement : if null post then [] else tail post in case Load.maybeFromByteList corruptBin of Report.Cons _ _ -> True main :: IO () main = do runExample exampleEmpty runExample exampleMeta runExample exampleStatus saveLoadFile exampleStatus >>= print quickCheck saveLoadByteString quickCheck saveLoadCompressedByteString quickCheck saveLoadMaybeByteList quickCheck saveLoadByteList -- quickCheck saveLoadFile quickCheck loadSaveByteString quickCheck loadSaveCompressedByteString quickCheck loadSaveByteList quickCheck restrictionByteList quickCheck lazinessZeroOrMoreByteList quickCheck lazinessByteList quickCheck corruptionByteList quickCheck corruptionByteString {- laziness test: The following expressions should return the prefix of the track before running into "undefined". I don't know, how to formalize that. Load.fromByteList [77,84,104,100,0,0,0,6,0,1,0,1,0,10,77,84,114,107,0,0,0,28,0,147,20,64,4,147,24,64,4,147,27,64,7,131,20,64,4,131,24,64,4,131,27,64,0,255,47,undefined] Report.result $ StreamParser.runIncomplete Load.getTrackChunk $ StreamParser.ByteList [77,84,114,107,0,0,0,28,0,147,20,64,4,147,24,64,4,147,27,64,7,131,20,64,4,131,24,64,4,131,27,64,0,255,47,undefined] -}