zmidi-core (empty) → 0.1.0
raw patch · 11 files changed
+1720/−0 lines, 11 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring
Files
- LICENSE +30/−0
- Setup.hs +4/−0
- demo/MidiCopy.hs +37/−0
- demo/MidiPrint.hs +27/−0
- src/ZMidi/Core/Datatypes.hs +517/−0
- src/ZMidi/Core/Internal/ParserMonad.hs +202/−0
- src/ZMidi/Core/Internal/SimpleFormat.hs +118/−0
- src/ZMidi/Core/Pretty.hs +210/−0
- src/ZMidi/Core/ReadFile.hs +276/−0
- src/ZMidi/Core/WriteFile.hs +250/−0
- zmidi-core.cabal +49/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Stephen Peter Tetley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ demo/MidiCopy.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS -Wall #-}++-- Read a MIDI file, output the syntax tree.+-- Are the files the same?+++module Main where++import ZMidi.Core.ReadFile+import ZMidi.Core.WriteFile+++import System.Environment+++main :: IO ()+main = do + args <- getArgs+ case args of+ [path] -> process path+ _ -> mapM_ putStrLn $ + [ "Usage: MidiCopy <filename>"+ , "--"+ , "Read the file, building a syntax tree, print the syntax tree."+ , "Tests that read and write are isomorphic." + ]+++process :: FilePath -> IO ()+process filename = do+ ans <- readMidi filename+ case ans of+ Left err -> print err+ Right a -> writeMidi (filename ++ ".001") a+ putStrLn $ take 1000 $ show ans -- not very good, need a pretty printer...++
+ demo/MidiPrint.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -Wall #-}++-- Dump the contents of a MIDI file++module Main where++import ZMidi.Core.Pretty+import ZMidi.Core.ReadFile++import System.Environment+++main :: IO ()+main = do + args <- getArgs+ case args of+ [path] -> process path+ _ -> putStrLn "Usage: MidiPrint <filename>"++process :: FilePath -> IO ()+process filename = do+ ans <- readMidi filename+ case ans of+ Left (n,msg) -> putStrLn $ "Parse failure at " ++ show n ++ ": " ++ msg+ Right m -> printMidi m++
+ src/ZMidi/Core/Datatypes.hs view
@@ -0,0 +1,517 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Datatypes+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Concrete syntax tree for MIDI files.+--+-- Values are sometimes not interpreted. This means that the+-- the data types do not fully represent the sematics of the +-- data, but all the data is either stored in the tree or +-- synthesizeable.+-- +-- @ readFile >>= writeFile @ will produce an identical binary \[1\]. +--+-- \[1\] Or it should, failure indicates a bug...+--+--------------------------------------------------------------------------------+++module ZMidi.Core.Datatypes + (+ -- * MidiFile representation.+ MidiFile(..)+ , Header(..) + , Track(..)+ , Format(..)+ , DeltaTime+ , Message+ , Event(..)+ , DataEvent(..)+ , VoiceEvent(..)+ , SysExEvent(..)+ , SysCommonEvent(..)+ , SysRealTimeEvent(..)+ , MetaEvent(..)+ , TimeDivision(..)+ , TextType(..)+ , ScaleType(..)++ -- * Interim types.+ -- ** SplitByte+ , SplitByte(..)+ , splitByte+ , joinByte+ + -- ** Varlen+ , Varlen(..)+ , fromVarlen+ , toVarlen++ , hexStr+ + ) where++import Data.Bits+import Data.Int+import Data.Word+import Numeric (showHex)++type TagByte = Word8+++-- | 'MidiFile' : @ header * tracks @+--+data MidiFile = MidiFile + { mf_header :: Header+ , mf_tracks :: [Track]+ }+ deriving (Eq,Show)++-- | 'Header' : @ format * num_tracks * time_division @ +--+-- 'TimeDivision' is often 384 or 480 ticks per beat.+--+-- The header is the start of a MIDI file, it is indicated by the +-- 4 character marker @MThd@. +--+data Header = Header { + hdr_format :: Format,+ num_tracks :: Word16,+ time_division :: TimeDivision+ }+ deriving (Eq,Show)++-- | 'Track' : @ [message] @+--+-- In MIDI files, the start of a track is indicated by the 4 +-- character marker @MTrk@. +--+newtype Track = Track { getMessages :: [Message] }+ deriving (Eq,Show)++-- | The file format - in a MIDI file this is a big-endian +-- word16 with 0,1 or 2 being the only valid values. +--+data Format + -- | Format 0 file - single multi-channel track.+ = MF0 + -- | Format 1 file - 1 or more tracks, played simultaneously.+ | MF1+ -- | Format 2 file - 1 or more independent tracks.+ | MF2+ deriving (Eq, Enum, Show) ++-- | Default unit of time in the MIDI file.+--+data TimeDivision + -- | Frames-per-second.+ --+ = FPS Word16+ + -- | Ticks-per-beat, i.e. the number of units for a quater + -- note.+ --+ | TPB Word16 + deriving (Eq,Show)+ +-- | Enumeration of the text meta event types.+--+data TextType + = GENERIC_TEXT + | COPYRIGHT_NOTICE + | SEQUENCE_NAME + | INSTRUMENT_NAME+ | LYRICS + | MARKER + | CUE_POINT + deriving (Eq,Enum,Ord,Show) ++-- | All time values in a MIDI track are represented as a \delta\ +-- from the previous event rather than an absolute time. +--+-- Although DeltaTime is a type synonym for Word32, in MIDI +-- files it is represented as a @varlen@ to save space. +--+type DeltaTime = Word32++-- | MIDI messages are pairs of 'DeltaTime' and 'Event' wrapped in +-- a newtype. +--+-- Sequential messages with delta time 0 are played +-- simultaneously. +--+type Message = (DeltaTime, Event)+++-- Note, the Ord instance for pairs is very useful for rendering.+-- When we have have a NoteOn and a NoteOff on the same channel at the +-- same time we want the NoteOff played first. An ordinary sort will +-- give us this.++ +++-- | Recognised event types - some types ('DataEvent' and +-- 'SysEx') are not interpreted.+--+data Event + -- | Data event - just initial tag byte, + -- uninterpreted+ --+ = DataEvent DataEvent++ -- | Voice event (e.g @note-on@, @note-off@) are relayed to specific+ -- channels.+ --+ | VoiceEvent VoiceEvent+++ -- | SysEx - system exclusive event. Usually synthesizer + -- specific, not interpreted.+ --+ | SysExEvent SysExEvent+++ -- | SysCommon - system common event.+ --+ | SysCommonEvent SysCommonEvent+++ -- | SysRealTime - system realtime event.+ --+ | SysRealTimeEvent SysRealTimeEvent+++ -- | Meta event - interpreted (e.g. @end-of-track@, + -- @set-tempo@).+ --+ | MetaEvent MetaEvent+++ deriving (Eq,Show,Ord)++-- | Data events are events with tags from 0x00 to 0x7F. +-- +-- Data events have no payload - they are represented only by the+-- tag byte. +--+data DataEvent = Data1 TagByte+ deriving (Eq,Ord,Show)++-- | Voice events control the output of the synthesizer.+--+-- Note - the constructors are not in the the same order as their +-- byte values. Controller and ProgramChange are higher than they +-- /naturally/ occur so the will come first after a comparison or +-- sort.+--+-- When generating MIDI, Controller and ProgramChange events +-- should be signalled before NoteOn or NoteOff events at the same +-- delta-time. Changing the order of the constructors helps to +-- sort for this.+--+data VoiceEvent + -- | @ channel * controller_number * value @ + -- + -- Controller change, e.g. by a footswitch.+ --+ = Controller Word8 Word8 Word8++ -- | @ channel * program_number @ - change the instrument + -- playing on the specified channel. For playback on + -- computers (rather than synthesizers) the program numbers+ -- will correspond to the /General MIDI/ instrument numbers.+ --+ | ProgramChange Word8 Word8++ -- | @ channel * note * velocity @ + -- + -- Turn off a sounding note.+ --+ | NoteOff Word8 Word8 Word8 ++ -- | @ channel * note * velocity @ + -- + -- Start playing a note.+ --+ | NoteOn Word8 Word8 Word8++ -- | @ channel * note * pressure_value @ + -- + -- Change of pressure applied to the synthesizer key. + --+ | NoteAftertouch Word8 Word8 Word8 ++ -- | @ channel * pressure_value @ + -- + | ChanAftertouch Word8 Word8++ -- | @ channel * value @ + -- + -- Change the pitch of a sounding note. Often used to + -- approximate microtonal tunings.+ -- + -- NOTE - currently value is uninterpreted.+ --+ | PitchBend Word8 Word16+ deriving (Eq,Show,Ord)++-- | \SysEx\ - system exclusive event. +--+data SysExEvent+ -- | @ length * data @ + -- + -- An uninterpreted sys-ex event.+ --+ = SysEx Word32 [Word8]+ deriving (Eq,Show,Ord)+++-- | System common event.+--+-- Common information for all channels in a system. +--+-- These events may not be pertinent to MIDI files generated on a +-- computer (as opposed to MIDI generated by a synthesizer or +-- sequencer).+--+data SysCommonEvent+ -- | Time code quarter frame.+ --+ = QuarterFrame SplitByte+ + -- | Song position pointer.+ --+ | SongPosPointer Word8 Word8++ -- | @ song_number @+ --+ -- Song number should be in the range 0..127.+ --+ | SongSelect Word8++ -- | Tag should be limited to 0xF4 or 0xF5.+ --+ -- Other values would indicate either a badly formed MIDI+ -- file or a failure with the parser.+ --+ | Common_undefined TagByte++ -- | Tune request message for analogue synthesizers.+ --+ | TuneRequest+ + -- | End-of-system-exclusive message.+ | EOX+ deriving (Eq,Show,Ord)+++-- | System real-time event.+--+-- These events may not be pertinent to MIDI files generated on a +-- computer (as opposed to MIDI generated by a synthesizer or +-- sequencer).+--+data SysRealTimeEvent+ -- | Timing signal.+ -- + = TimingClock+ + -- | Tag should be limited to either 0xF9 or 0xFD.+ --+ -- Other values would indicate either a badly formed MIDI+ -- file or a failure with the parser.+ --+ | RT_undefined TagByte+ + -- | Start playing a sequence.+ -- + | StartSequence+ + -- | Continue playing a stopped sequence.+ --+ | ContinueSequence++ -- | Stop playing a sequence.+ --+ | StopSequence++ -- | Synchronization pulse...+ -- + | ActiveSensing++ -- | Reset to power-up status.+ --+ | SystemReset+ deriving (Eq,Show,Ord)+++++++-- | Meta event +-- +-- In Format 1 files general events (e.g. text events) should+-- only appear in track 1. Certain events (e.g. end-of-track) +-- can appear in any track where necessary. +--+data MetaEvent++ -- | @ text_type * contents @ + -- + -- Free text field (e.g. copyright statement). The contents + -- can notionally be any length.+ --+ = TextEvent TextType String++ -- | @ value @ + -- + -- Format 1 files - only track 1 should have a sequence + -- number. + --+ -- Format 2 files - a sequence number should identify each + -- track.+ -- + -- The sequence number event should occur at the start of a + -- track, before any non-zero time events.+ --+ | SequenceNumber Word16++ -- | @ 1 * channel @ + -- + -- Relay all meta and sys-ex events to the given channel.+ --+ -- The first byte should always be 1.+ -- + | ChannelPrefix Word8 Word8++ -- | End-of-track event. + --+ | EndOfTrack++ -- | @ microseconds_per_quarter_note @+ --+ | SetTempo Word32++ -- | @ hour * minute * second * frac * subfrac @ + -- + -- The SMPTE time when a track should start. This event + -- should occur at the start of a track, before any non-zero + -- time events.+ --+ | SMPTEOffset Word8 Word8 Word8 Word8 Word8+ + -- | @ numerator * denominator * metro * num_32nd_notes @ + --+ | TimeSignature Word8 Word8 Word8 Word8+ + -- | @ key_type * scale_type @ + --+ -- @key_type@ is the number of sharps (postive numbers) or + -- flats (negative numbers), e.g. (-1) is 1 flat.+ --+ -- @scale_type@ indicates major or minor. + --+ | KeySignature Int8 ScaleType+ + -- | @ length * data@ + -- + -- Sequencer specific meta-event - uninterpreted.+ --+ | SSME Word32 [Word8]++ deriving (Eq,Show,Ord)++-- | Scale type - @major@ or @minor@. +--+data ScaleType = MAJOR | MINOR+ deriving (Eq,Enum,Ord,Show)++++--------------------------------------------------------------------------------++-- | SplitByte - divide a byte into the upper four and lower +-- 4 bits.+-- +data SplitByte = SB { upper4 :: Word8, lower4 :: Word8 }+ deriving (Eq,Ord,Show)++splitByte :: Word8 -> SplitByte+splitByte i = SB ((i .&. 0xF0) `shiftR` 4) (i .&. 0x0F)++joinByte :: SplitByte -> Word8+joinByte (SB a b) = (a `shiftL` 4) + (b .&. 0x0F)+++--------------------------------------------------------------------------------+-- helper for varlen+--------------------------------------------------------------------------------++-- | Space efficient representation of length fields.+-- +-- This data type is not used directly in the syntax tree where+-- it would be cumbersome. But it is used as an intermediate type+-- in the parser and emitter.+--+data Varlen = V1 !Word8+ | V2 !Word8 !Word8+ | V3 !Word8 !Word8 !Word8+ | V4 !Word8 !Word8 !Word8 !Word8+ deriving (Eq,Ord,Show)+++up :: Word8 -> Word32+up = fromIntegral . (0x7f .&.)++down :: Word32 -> Word8+down = (0x80 .|.) . fromIntegral++downl :: Word32 -> Word8+downl = (0x7f .&.) . fromIntegral+ ++fromVarlen :: Varlen -> Word32+fromVarlen (V1 a) = up a+fromVarlen (V2 a b) = (left7 $ up a) + up b+fromVarlen (V3 a b c) = (left14 $ up a) + (left7 $ up b) + up c+fromVarlen (V4 a b c d) = (left21 $ up a) + (left14 $ up b) + + (left7 $ up c) + up d++left7 :: Word32 -> Word32+left7 = (`shiftL` 7)++left14 :: Word32 -> Word32+left14 = (`shiftL` 14)++left21 :: Word32 -> Word32+left21 = (`shiftL` 21)++right7 :: Word32 -> Word32+right7 = (`shiftR` 7)++right14 :: Word32 -> Word32+right14 = (`shiftR` 14)++right21 :: Word32 -> Word32+right21 = (`shiftR` 21)++toVarlen :: Word32 -> Varlen+toVarlen i + | i < 0x80 = V1 (downl i)+ | i < 0x4000 = V2 (down $ right7 i) (downl i)+ | i < 0x200000 = V3 (down $ right14 i) (down $ right7 i) (downl i)+ | otherwise = V4 (down $ right21 i) (down $ right14 i)+ (down $ right7 i) (downl i)++hexStr :: (Integral a) => a -> String+hexStr i = (showString "0x" . showHex i) ""
+ src/ZMidi/Core/Internal/ParserMonad.hs view
@@ -0,0 +1,202 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Internal.ParseMonad+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- A parse monad - better error handling than Binary-Get.+--+--------------------------------------------------------------------------------++module ZMidi.Core.Internal.ParserMonad+ (++ ErrMsg+ , Pos+ , ParseErr+ , ParserM+ , runParser+ + , word8+ , int8++ , word16be+ , word24be+ , word32be+ , char8++ , (<??>)+ , reportError++ , count+ , gencount+ , text+ , boundRepeat++ ++ ) where++import Control.Applicative+import Data.Bits+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.Int+import Data.Word+++type Pos = Int++data ParserState = ParserState + { pos :: !Pos+ , input :: L.ByteString + }+++type ErrMsg = String++type ParseErr = (Pos,ErrMsg)++newtype ParserM a = ParserM + { getParserM :: ParserState -> (Either ParseErr a, ParserState) }+++instance Functor ParserM where+ fmap f mf = ParserM $ \s -> let (ans,s') = getParserM mf s in (fmap f ans,s')+ ++instance Applicative ParserM where+ pure a = ParserM $ \s -> (Right a, s)+ af <*> ma = ParserM $ \s -> let (ef,s') = getParserM af s+ in case ef of + Left e -> (Left e, s') + Right f -> let (a,s'') = getParserM ma s'+ in (fmap f a,s'')++instance Monad ParserM where+ return a = ParserM $ \s -> (Right a, s)+ m >>= k = ParserM $ \s -> let (ea,s') = getParserM m s+ in case ea of+ Left e -> (Left e, s')+ Right a -> (getParserM . k) a s'++runParser :: L.ByteString -> ParserM a -> Either ParseErr a+runParser bs mf = fst $ getParserM mf (ParserState { pos = 0, input = bs})+++getPos :: ParserM Int+getPos = ParserM $ \s -> (Right $ pos s, s)++word8 :: ParserM Word8+word8 = ParserM $ \s@(ParserState n bs) -> case L.uncons bs of + Nothing -> (Left (n,"word8 - no more data."), s)+ Just (a,bs') -> (Right a, ParserState (n+1) bs')+++-- NEEDS CHECKING!+--+int8 :: ParserM Int8+int8 = fromIntegral <$> word8+++word16be :: ParserM Word16+word16be = ParserM $ \s@(ParserState n bs) -> case uncons2 bs of+ Nothing -> (Left (n,"word16be - no more data."), s)+ Just (a,b,bs') -> (Right $ w16be a b, ParserState (n+2) bs')++word24be :: ParserM Word32+word24be = ParserM $ \s@(ParserState n bs) -> case uncons3 bs of+ Nothing -> (Left (n,"word24be - no more data."), s)+ Just (a,b,c,bs') -> (Right $ w24be a b c, ParserState (n+3) bs')++word32be :: ParserM Word32+word32be = ParserM $ \s@(ParserState n bs) -> case uncons4 bs of+ Nothing -> (Left (n, "word32be - no more data."), s)+ Just (a,b,c,d,bs') -> (Right $ w32be a b c d, ParserState (n+4) bs')+++char8 :: ParserM Char+char8 = (chr . fromIntegral) <$> word8++infixr 0 <??>++(<??>) :: ErrMsg -> ParserM a -> ParserM a+(<??>) msg p = ParserM $ \s -> case getParserM p s of+ (Left (n,_),s') -> (Left (n,msg),s')+ (Right a, s') -> (Right a,s')++reportError :: ErrMsg -> ParserM a+reportError msg = ParserM $ \s -> (Left (pos s, msg), s)+++++count :: Int -> ParserM a -> ParserM [a]+count i p + | i <= 0 = pure []+ | otherwise = (:) <$> p <*> count (i-1) p+++gencount :: Integral i => ParserM i -> ParserM a -> ParserM (i,[a]) +gencount plen p = plen >>= \i -> + count (fromIntegral i) p >>= \ans -> return (i,ans)+++text :: Int -> ParserM String+text i = count i char8+++boundRepeat :: Int -> ParserM a -> ParserM [a]+boundRepeat n p = getPos >>= \start -> step (start + n)+ where+ step lim = do { a <- p+ ; i <- getPos + ; case compare i lim of+ LT -> do { as <- step lim; return (a:as) }+ EQ -> return [a]+ GT -> reportError "boundRepeat - parser exceeds limit"+ }++++--------------------------------------------------------------------------------+-- helpers+++uncons2 :: L.ByteString -> Maybe (Word8,Word8,L.ByteString)+uncons2 bs = L.uncons bs >>= \(a,bs1) -> + L.uncons bs1 >>= \(b,bs2) -> return (a,b,bs2)+++uncons3 :: L.ByteString -> Maybe (Word8,Word8,Word8,L.ByteString)+uncons3 bs = L.uncons bs >>= \(a,bs1) -> + L.uncons bs1 >>= \(b,bs2) -> + L.uncons bs2 >>= \(c,bs3) -> return (a,b,c,bs3)++uncons4 :: L.ByteString -> Maybe (Word8,Word8,Word8,Word8,L.ByteString)+uncons4 bs = L.uncons bs >>= \(a,bs1) -> + L.uncons bs1 >>= \(b,bs2) -> + L.uncons bs2 >>= \(c,bs3) -> + L.uncons bs3 >>= \(d,bs4) -> return (a,b,c,d,bs4)+++w16be :: Word8 -> Word8 -> Word16+w16be a b = (shiftL `flip` 8 $ fromIntegral a) + fromIntegral b++w24be :: Word8 -> Word8 -> Word8 -> Word32+w24be a b c = (shiftL `flip` 16 $ fromIntegral a) + + (shiftL `flip` 8 $ fromIntegral b) + + fromIntegral c+++w32be :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+w32be a b c d = (shiftL `flip` 24 $ fromIntegral a) + + (shiftL `flip` 16 $ fromIntegral b) + + (shiftL `flip` 8 $ fromIntegral c) + + fromIntegral d
+ src/ZMidi/Core/Internal/SimpleFormat.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Internal.SimpleFormat+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Simple formating combinators.+--+--------------------------------------------------------------------------------++module ZMidi.Core.Internal.SimpleFormat+ (++ Doc+ , width+ , output++ , sep+ , ssep+ , char+ , text+ , multiply++ , padl+ , padr+ , hex2 + , hex4+ , integral++ ) where++import Data.Monoid+import Data.Word+import Numeric++-- Strings are represented as Hughes lists +--+-- ShowS is a Hughes list representation specialized to Strings+--+type H a = [a] -> [a]++type HString = H Char+++spaceH :: Int -> HString +spaceH n = showString $ replicate n ' '+++fromH :: H a -> [a]+fromH = ($ [])++-- | Docs represent a single line - they should not contain +-- newlines...+--+data Doc = Doc { width :: !Int, doch :: HString }++doc :: String -> Doc+doc s = Doc (length s) (showString s) ++output :: Doc -> String+output = fromH . doch++++instance Monoid Doc where+ mempty = Doc 0 id+ Doc i1 f1 `mappend` Doc i2 f2 = Doc (i1+i2) (f1 . f2)+++infixr 6 `sep`++sep :: Doc -> Doc -> Doc+sep = mappend++infixr 6 `ssep`++ssep :: Doc -> Doc -> Doc+ssep (Doc i1 f1) (Doc i2 f2) = Doc (1+i1+i2) (f1 . (' ':) . f2)+++char :: Char -> Doc +char c = Doc 1 (c:)++text :: String -> Doc+text = doc ++multiply :: Int -> Char -> Doc+multiply n c = Doc n (showString $ replicate n c)+++padl :: Int -> Doc -> Doc+padl i d@(Doc n f) | i > n = Doc i (spaceH (i-n) . f)+ | otherwise = d++padr :: Int -> Doc -> Doc+padr i d@(Doc n f) | i > n = Doc i (f . spaceH (i-n))+ | otherwise = d+++hex2 :: Word8 -> Doc+hex2 n | n < 0x10 = Doc 2 (('0' :) . showHex n)+ | otherwise = Doc 2 (showHex n) ++hex4 :: Word16 -> Doc+hex4 n | n < 0x10 = Doc 4 (('0':) . ('0':) . ('0':) . showHex n)+ | n < 0x100 = Doc 4 (('0':) . ('0':) . showHex n)+ | n < 0x1000 = Doc 4 (('0':) . showHex n)+ | otherwise = Doc 4 (showHex n) +++integral :: Integral a => a -> Doc+integral = doc . show
+ src/ZMidi/Core/Pretty.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.Pretty+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Pretty print the MIDI representation.+--+--------------------------------------------------------------------------------+++module ZMidi.Core.Pretty+ (++ printMidi++ , header+ , track++ ) where++import ZMidi.Core.Datatypes+import ZMidi.Core.Internal.SimpleFormat++import Data.List+import Data.Monoid+import Data.Word+++-- | Print the MIDI file to std-out.+--+-- One event is printed per line, so the output may be huge.+--+printMidi :: MidiFile -> IO ()+printMidi (MidiFile hdr tracks) = do+ column_break+ mapM_ putStrLn (header hdr) + mapM_ (\t -> column_break >> putTrack t) tracks+ where+ putTrack = (mapM_ putStrLn) . track+ column_break = putStrLn $ replicate 60 '-'+++-- | Print the MIDI header.+--+-- Results are returned as a list of String to avoid extraneous+-- concatenation.+-- +header :: Header -> [String]+header (Header fmt tcount td) = + map output [ppFormat fmt, ppNumTracks tcount, ppTimeDivision td] ++-- | Print a track.+--+-- Results are returned as a list of String to avoid extraneous+-- concatenation.+--+track :: Track -> [String]+track = snd . mapAccumL (\acc b -> msnd output $ message acc b) 0 . getMessages + where+ msnd f (a,b) = (a,f b)++--------------------------------------------------------------------------------++column2 :: String -> Doc -> Doc+column2 s d2 = padr 20 (text s) `sep` char '|' `ssep` d2 ++ppFormat :: Format -> Doc+ppFormat = column2 "MIDI Format" . step + where+ step MF0 = text "Type 0 MIDI File"+ step MF1 = text "Type 1 MIDI File"+ step MF2 = text "Type 2 MIDI File"++ppNumTracks :: Word16 -> Doc+ppNumTracks = column2 "Number of tracks" . integral++ppTimeDivision :: TimeDivision -> Doc+ppTimeDivision = column2 "Time Division" . step+ where+ step (FPS i) = text "fps" `ssep` integral i+ step (TPB i) = text "ticks" `ssep` integral i++infixr 7 `dashsep`++dashsep :: Doc -> Doc -> Doc+dashsep d1 d2 = d1 `ssep` char '-' `ssep` d2++message :: Word32 -> Message -> (Word32,Doc)+message acc (delta,evt) = + (n, acctime `dashsep` dtime `dashsep` ppEvent evt)+ where+ n = acc + delta + acctime = padl 12 (integral n)+ dtime = padl 6 (integral delta)++ppEvent :: Event -> Doc+ppEvent (DataEvent e) = ppDataEvent e+ppEvent (VoiceEvent e) = ppVoiceEvent e+ppEvent (SysExEvent e) = ppSysExEvent e+ppEvent (SysCommonEvent e) = ppSysCommonEvent e+ppEvent (SysRealTimeEvent e) = ppSysRealTimeEvent e+ppEvent (MetaEvent e) = ppMetaEvent e+++event :: String -> Doc -> Doc+event s d = padr 18 (text s) `dashsep` d++ppDataEvent :: DataEvent -> Doc+ppDataEvent (Data1 tag) = event "data" (hex2 tag)++ppVoiceEvent :: VoiceEvent -> Doc+ppVoiceEvent (Controller c n v) = + event "controller" (hex2 c `ssep` hex2 n `ssep` hex2 v)++ppVoiceEvent (ProgramChange c n) = + event "program-change" (hex2 c `ssep` hex2 n)++ppVoiceEvent (NoteOff c n v) =+ event "note-off" (hex2 c `ssep` hex2 n `ssep` hex2 v)++ppVoiceEvent (NoteOn c n v) = + event "note-on" (hex2 c `ssep` hex2 n `ssep` hex2 v)++ppVoiceEvent (NoteAftertouch c n v) =+ event "note-aftertouch" (hex2 c `ssep` hex2 n `ssep` hex2 v)++ppVoiceEvent (ChanAftertouch c v) = + event "channel-aftertouch" (hex2 c `ssep` hex2 v)++ppVoiceEvent (PitchBend c v) =+ event "pitch-bend" (hex2 c `ssep` hex4 v)+++ppSysExEvent :: SysExEvent -> Doc+ppSysExEvent (SysEx n ws) = event "sys-ex" $ byteList n ws++ppSysCommonEvent :: SysCommonEvent -> Doc+ppSysCommonEvent (QuarterFrame sb) = + event "time-code-quarter-frame" (hex2 $ joinByte sb)++ppSysCommonEvent (SongPosPointer a b) = + event "sys-common song pos. pointer" (hex2 a `ssep` hex2 b)++ppSysCommonEvent (SongSelect w) = event "song-select" (hex2 w)++ppSysCommonEvent (Common_undefined tag) = event "sys-common" (hex2 tag)++ppSysCommonEvent TuneRequest = text "tune-request"++ppSysCommonEvent EOX = text "end-of-sys-ex"+++ppSysRealTimeEvent :: SysRealTimeEvent -> Doc+ppSysRealTimeEvent TimingClock = text "sys-real-time timing-clock"+ppSysRealTimeEvent (RT_undefined tag) = event "sys-real-time" (hex2 tag)+ppSysRealTimeEvent StartSequence = text "sys-real-time start"+ppSysRealTimeEvent ContinueSequence = text "sys-real-time continue"+ppSysRealTimeEvent StopSequence = text "sys-real-time stop"+ppSysRealTimeEvent ActiveSensing = text "sys-real-time active sensing"+ppSysRealTimeEvent SystemReset = text "system-reset"++ppMetaEvent :: MetaEvent -> Doc+ppMetaEvent (TextEvent ty s) = event (textType ty) (text s)++ppMetaEvent (SequenceNumber w) = event "sequence-number" (hex4 w)++ppMetaEvent (ChannelPrefix a b) = + event "channel-prefix" (hex2 a `ssep` hex2 b)++ppMetaEvent EndOfTrack = text "end-of-track"++ppMetaEvent (SetTempo w) = event "set-tempo" (integral w) ++ppMetaEvent (SMPTEOffset h m s f sf) = + event "smpte-offest" (mconcat $ map hex2 [h,m,s,f,sf])++ppMetaEvent (TimeSignature n d m t) = + event "time-signature" (mconcat $ map hex2 [n,d,m,t])++ppMetaEvent (KeySignature n sc) = + event "key-signature" (integral n `ssep` ppScale sc)++ppMetaEvent (SSME n ws) = + event "sequencer-specific" (byteList n ws)++byteList :: Integral a => a -> [Word8] -> Doc +byteList n ws | n < 10 = integral n `sep` mconcat (map hex2 ws)+ | otherwise = integral n `sep` multiply 10 '.'+++textType :: TextType -> String+textType GENERIC_TEXT = "generic-text" +textType COPYRIGHT_NOTICE = "copyright-notice" +textType SEQUENCE_NAME = "sequence-name"+textType INSTRUMENT_NAME = "instrument-name"+textType LYRICS = "lyrics"+textType MARKER = "marker"+textType CUE_POINT = "cue-point"+ ++ppScale :: ScaleType -> Doc+ppScale MAJOR = text "major"+ppScale MINOR = text "minor"
+ src/ZMidi/Core/ReadFile.hs view
@@ -0,0 +1,276 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.ReadFile+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- A MIDI file parser. +--+--------------------------------------------------------------------------------++module ZMidi.Core.ReadFile + (+ -- * Read a MIDI file+ readMidi++ -- * Auxiallary types+ , ParseErr+ , Pos+ , ErrMsg+ + ) where++import ZMidi.Core.Datatypes+import ZMidi.Core.Internal.ParserMonad+++import Control.Applicative+import Control.Monad+import Data.Bits+import qualified Data.ByteString.Lazy as L+import Data.Word+++readMidi :: FilePath -> IO (Either ParseErr MidiFile)+readMidi filename =+ liftM (runParser `flip` midiFile) (L.readFile filename)++--------------------------------------------------------------------------------+-- ++ +midiFile :: ParserM MidiFile +midiFile = {- printHexAll >> -} do+ hdr <- header+ let i = trackCount hdr+ trks <- count i track+ return $ MidiFile hdr trks + where+ trackCount :: Header -> Int + trackCount (Header _ n _) = fromIntegral n++header :: ParserM Header +header = Header <$> (assertString "MThd" *> assertWord32 (6::Int) *> format)+ <*> word16be+ <*> timeDivision++++track :: ParserM Track+track = liftM Track (trackHeader >>= messages)++trackHeader :: ParserM Word32+trackHeader = assertString "MTrk" >> word32be++++messages :: Word32 -> ParserM [Message]+messages i = boundRepeat (fromIntegral i) message+++message :: ParserM Message+message = (,) <$> deltaTime <*> event++deltaTime :: ParserM Word32+deltaTime = "delta time" <??> getVarlen++event :: ParserM Event+event = word8 >>= step+ where+ -- 00..7f -- /data/+ step n | n == 0xFF = MetaEvent <$> (word8 >>= metaEvent)+ | 0xF8 <= n = SysRealTimeEvent <$> sysRealTimeEvent n+ | 0xF1 <= n = SysCommonEvent <$> sysCommonEvent n+ | n == 0xF0 = SysExEvent <$> sysExEvent+ | 0x80 <= n = VoiceEvent <$> voiceEvent (splitByte n)+ | otherwise = DataEvent <$> dataEvent n++dataEvent :: Word8 -> ParserM DataEvent+dataEvent tag = pure $ Data1 tag+++ +voiceEvent :: SplitByte -> ParserM VoiceEvent+voiceEvent (SB 0x8 ch) = + "note-off" <??> (NoteOff ch) <$> word8 <*> word8++voiceEvent (SB 0x9 ch) = + "note-on" <??> (NoteOn ch) <$> word8 <*> word8++voiceEvent (SB 0xA ch) = + "note aftertouch" <??> (NoteAftertouch ch) <$> word8 <*> word8+ +voiceEvent (SB 0xB ch) = + "controller" <??> (Controller ch) <$> word8 <*> word8++voiceEvent (SB 0xC ch) = + "program change" <??> (ProgramChange ch) <$> word8 ++voiceEvent (SB 0xD ch) = + "chan aftertouch" <??> (ChanAftertouch ch) <$> word8 ++voiceEvent (SB 0xE ch) = + "pitch bend" <??> (PitchBend ch) <$> word16be++voiceEvent (SB z _ ) = reportError $ "voiceEvent " ++ hexStr z +++sysCommonEvent :: Word8 -> ParserM SysCommonEvent+sysCommonEvent 0xF1 = + "quarter frame" <??> QuarterFrame . splitByte <$> word8++sysCommonEvent 0xF2 = + "song pos. pointer" <??> SongPosPointer <$> word8 <*> word8++sysCommonEvent 0xF3 = + "song select" <??> SongSelect <$> word8++sysCommonEvent 0xF4 = pure $ Common_undefined 0xF4++sysCommonEvent 0xF5 = pure $ Common_undefined 0xF5++sysCommonEvent 0xF6 = pure TuneRequest++sysCommonEvent 0xF7 = pure EOX++sysCommonEvent tag = pure $ Common_undefined tag+++sysRealTimeEvent :: Word8 -> ParserM SysRealTimeEvent+sysRealTimeEvent 0xF8 = pure TimingClock+sysRealTimeEvent 0xF9 = pure $ RT_undefined 0xF9+sysRealTimeEvent 0xFA = pure StartSequence+sysRealTimeEvent 0xFB = pure ContinueSequence+sysRealTimeEvent 0xFC = pure StopSequence+sysRealTimeEvent 0xFD = pure $ RT_undefined 0xFD+sysRealTimeEvent 0xFE = pure ActiveSensing+sysRealTimeEvent 0xFF = pure SystemReset+sysRealTimeEvent tag = pure $ RT_undefined tag+++sysExEvent :: ParserM SysExEvent+sysExEvent = "sys-ex" <??> (uncurry SysEx) <$> getVarlenBytes+ +++metaEvent :: Word8 -> ParserM MetaEvent+metaEvent 0x00 = + "sequence number" <??> SequenceNumber <$> (assertWord8 2 *> word16be)++metaEvent 0x01 = "generic text" <??> textEvent GENERIC_TEXT +metaEvent 0x02 = "copyrightn notice" <??> textEvent COPYRIGHT_NOTICE+metaEvent 0x03 = "sequence name" <??> textEvent SEQUENCE_NAME+metaEvent 0x04 = "instrument name" <??> textEvent INSTRUMENT_NAME+metaEvent 0x05 = "lyrics" <??> textEvent LYRICS+metaEvent 0x06 = "marker" <??> textEvent MARKER+metaEvent 0x07 = "cue point" <??> textEvent CUE_POINT++metaEvent 0x20 = + "channel prefix" <??> ChannelPrefix <$> word8 <*> word8++metaEvent 0x2F = + "end of track" <??> EndOfTrack <$ assertWord8 0 ++metaEvent 0x51 = + "set tempo" <??> SetTempo <$> (assertWord8 3 *> word24be)++metaEvent 0x54 = + "smpte offset" <??> SMPTEOffset <$> (assertWord8 5 *> word8) + <*> word8 <*> word8+ <*> word8 <*> word8++metaEvent 0x58 = + "time signature" <??> TimeSignature <$> (assertWord8 4 *> word8)+ <*> word8 <*> word8 + <*> word8 ++metaEvent 0x59 = + "key signature" <??> KeySignature <$> (assertWord8 2 *> int8) + <*> scale++metaEvent 0x7F = + "system specific meta event" <??> (uncurry SSME) <$> getVarlenBytes ++metaEvent z = reportError $ "unreconized meta-event " ++ hexStr z++++ +format :: ParserM Format+format = word16be >>= fn + where + fn 0 = return MF0+ fn 1 = return MF1+ fn 2 = return MF2+ fn z = reportError $ + "getFormat - unrecognized file format " ++ hexStr z+ +timeDivision :: ParserM TimeDivision+timeDivision = division <$> word16be+ where division i | i `testBit` 15 = FPS (i `clearBit` 15)+ | otherwise = TPB i+++scale :: ParserM ScaleType+scale = word8 >>= fn + where+ fn 0 = return MAJOR+ fn 1 = return MINOR+ fn z = reportError $ "scale expecting 0 or 1, got " ++ hexStr z+ + +textEvent :: TextType -> ParserM MetaEvent+textEvent ty = (TextEvent ty . snd) <$> getVarlenText++--------------------------------------------------------------------------------+-- helpers++ +assertWord8 :: Word8 -> ParserM Word8+assertWord8 i = postCheck word8 (==i) msg+ where + msg = "assertWord8 - input did not match " ++ show i+ +assertWord32 :: Integral a => a -> ParserM Word32+assertWord32 i = postCheck word32be ((==i) . fromIntegral) msg+ where+ msg = "assertWord32 - input did not match " ++ show i++assertString :: String -> ParserM String+assertString s = postCheck (text $ length s) (==s) msg+ where+ msg = "assertString - input did not match " ++ s+++getVarlenText :: ParserM (Word32,String) +getVarlenText = gencount getVarlen char8++getVarlenBytes :: ParserM (Word32,[Word8]) +getVarlenBytes = gencount getVarlen word8+++getVarlen :: ParserM Word32+getVarlen = liftM fromVarlen step1+ where+ high a = a `testBit` 7++ step1 = word8 >>= \a -> if high a then step2 a else return (V1 a)+ step2 a = word8 >>= \b -> if high b then step3 a b else return (V2 a b)+ step3 a b = word8 >>= \c -> if high c then do { d <- word8+ ; return (V4 a b c d)}+ else return (V3 a b c) +++++-- | Apply parse then apply the check, if the check fails report+-- the error message. +postCheck :: ParserM a -> (a -> Bool) -> String -> ParserM a+postCheck p check msg = p >>= \ans -> + if check ans then return ans else reportError msg
+ src/ZMidi/Core/WriteFile.hs view
@@ -0,0 +1,250 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ZMidi.Core.WriteFile+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- Stability : unstable+-- Portability : As per dependencies.+--+-- Write a MIDI file.+--+--------------------------------------------------------------------------------+++module ZMidi.Core.WriteFile + (+ -- * Write a Midi structure to file+ writeMidi+ ) where++import ZMidi.Core.Datatypes+++import Data.Binary.Put -- package: binary++import Control.Applicative+import Data.Bits+import qualified Data.ByteString.Lazy as L+import Data.Char (ord)+import Data.Int+import Data.Word++import System.IO+++writeMidi :: FilePath -> MidiFile -> IO ()+writeMidi filename midi = + openBinaryFile filename WriteMode >>= \hdl -> + L.hPut hdl (runPut $ putMidiFile midi) >>+ hClose hdl ++putMidiFile :: MidiFile -> PutM ()+putMidiFile (MidiFile hdr trks) = + putHeader hdr *> mapM_ putTrack trks+ +putHeader :: Header -> PutM ()+putHeader (Header fmt n td) =+ putString "MThd" *> putWord32be 6 *> + putFormat fmt *> putWord16be n *> putTimeDivision td+++putTrack :: Track -> PutM ()+putTrack (Track ms) = + putString "MTrk" *> (putWord32be $ fromIntegral $ L.length bs)+ *> putLazyByteString bs+ where + bs = runPut (mapM_ putMessage ms) +++putFormat :: Format -> PutM ()+putFormat MF0 = putWord16be 0+putFormat MF1 = putWord16be 1+putFormat MF2 = putWord16be 2++putTimeDivision :: TimeDivision -> PutM ()+putTimeDivision (FPS n) = putWord16be (n `setBit` 15)+putTimeDivision (TPB n) = putWord16be (n `clearBit` 15)++++putMessage :: Message -> PutM () +putMessage (dt,evt) = putVarlen dt *> putEvent evt++putEvent :: Event -> PutM ()+putEvent (DataEvent e) = putDataEvent e+putEvent (VoiceEvent e) = putVoiceEvent e+putEvent (SysExEvent e) = putSysExEvent e+putEvent (SysCommonEvent e) = putSysCommonEvent e+putEvent (SysRealTimeEvent e) = putSysRealTimeEvent e+putEvent (MetaEvent e) = putMetaEvent e+ ++putDataEvent :: DataEvent -> PutM ()+putDataEvent (Data1 tag) = putWord8 tag+ +putVoiceEvent :: VoiceEvent -> PutM ()+putVoiceEvent (NoteOff c n v) = + putWord8 (0x8 `u4l4` c) *> putWord8 n *> putWord8 v ++putVoiceEvent (NoteOn c n v) = + putWord8 (0x9 `u4l4` c) *> putWord8 n *> putWord8 v ++putVoiceEvent (NoteAftertouch c n v) = + putWord8 (0xA `u4l4` c) *> putWord8 n *> putWord8 v++putVoiceEvent (Controller c n v) = + putWord8 (0xB `u4l4` c) *> putWord8 n *> putWord8 v++putVoiceEvent (ProgramChange c n) = + putWord8 (0xC `u4l4` c) *> putWord8 n++putVoiceEvent (ChanAftertouch c v) = + putWord8 (0xD `u4l4` c) *> putWord8 v ++putVoiceEvent (PitchBend c v) = + putWord8 (0xE `u4l4` c) *> putWord16be v++putSysExEvent :: SysExEvent -> PutM ()+putSysExEvent (SysEx n ws) = + putWord8 0xF0 *> putVarlen n *> mapM_ putWord8 ws++putSysCommonEvent :: SysCommonEvent -> PutM ()+putSysCommonEvent (QuarterFrame sb) = + putWord8 0xF1 *> putSplitByte sb++putSysCommonEvent (SongPosPointer lsb msb) = + putWord8 0xF2 *> putWord8 lsb *> putWord8 msb++putSysCommonEvent (SongSelect w) = + putWord8 0xF3 *> putWord8 w++putSysCommonEvent (Common_undefined tag) = + putWord8 tag++putSysCommonEvent TuneRequest = + putWord8 0xF6++putSysCommonEvent EOX = + putWord8 0xF7++putSysRealTimeEvent :: SysRealTimeEvent -> PutM ()+putSysRealTimeEvent TimingClock = putWord8 0xF8+putSysRealTimeEvent (RT_undefined tag) = putWord8 tag+putSysRealTimeEvent StartSequence = putWord8 0xFA+putSysRealTimeEvent ContinueSequence = putWord8 0xFB+putSysRealTimeEvent StopSequence = putWord8 0xFC+putSysRealTimeEvent ActiveSensing = putWord8 0xFE+putSysRealTimeEvent SystemReset = putWord8 0xFF++putMetaEvent :: MetaEvent -> PutM ()+putMetaEvent (TextEvent ty ss) = + putWord8 0xFF *> putWord8 (texttype ty) + *> putVarlen (fromIntegral $ length ss) + *> putString ss+ +putMetaEvent (SequenceNumber n) = + putWord8 0xFF *> putWord8 0x00 *> prefixLen 2 (putWord16be n)+ +putMetaEvent (ChannelPrefix i ch) = + putWord8 0xFF *> putWord8 0x20 *> prefixLen i (putWord8 ch)+ +putMetaEvent (EndOfTrack) = + putWord8 0xFF *> putWord8 0x2F *> prefixLen 0 (pure ())+ +putMetaEvent (SetTempo t) = + putWord8 0xFF *> putWord8 0x51 *> prefixLen 3 (putWord24be t)+ +putMetaEvent (SMPTEOffset hr mn sc fr sfr) =+ putWord8 0xFF *> putWord8 0x54 *> prefixLen 5 body+ where+ body = putWord8 hr *> putWord8 mn *> putWord8 sc + *> putWord8 fr *> putWord8 sfr+ +putMetaEvent (TimeSignature nmr dnm met nps) =+ putWord8 0xFF *> putWord8 0x58 *> prefixLen 4 body+ where+ body = putWord8 nmr *> putWord8 dnm *> putWord8 met *> putWord8 nps + +putMetaEvent (KeySignature ky sc) =+ putWord8 0xFF *> putWord8 0x59 *> prefixLen 2 body+ where+ body = putWord8 (wrapint ky) *> putWord8 (wscale sc)++putMetaEvent (SSME i ws) = + putWord8 0xFF *> putWord8 0x7F *> putVarlen i *> mapM_ putWord8 ws+++ + ++++--------------------------------------------------------------------------------+-- Output helpers++prefixLen :: Word8 -> PutM () -> PutM ()+prefixLen n out = putWord8 n *> out ++putSplitByte :: SplitByte -> PutM ()+putSplitByte a = putWord8 (joinByte a)++infixr 5 `u4l4`++u4l4 :: Word8 -> Word8 -> Word8+a `u4l4` b = (a `shiftL` 4) + b + ++wrapint :: Int8 -> Word8+wrapint i | i < 0 = fromIntegral $ i' + 256+ | otherwise = fromIntegral i+ where+ i' :: Int+ i' = fromIntegral i + +wscale :: ScaleType -> Word8+wscale MAJOR = 0x00+wscale MINOR = 0x01+++putWord24be :: Word32 -> PutM ()+putWord24be i = putWord8 c *> putWord8 b *> putWord8 a + where + (a, r1) = lowerEight i + (b, r2) = lowerEight r1+ (c, _) = lowerEight r2+ + ++lowerEight :: (Bits a, Integral a) => a -> (Word8, a) +lowerEight n = (fromIntegral lower8, remain)+ where+ remain = n `shiftR` 8+ lower8 = n .&. 0xff + +putVarlen :: Word32 -> PutM ()+putVarlen = step . toVarlen where+ step (V1 a) = putWord8 a+ step (V2 a b) = putWord8 a *> putWord8 b+ step (V3 a b c) = putWord8 a *> putWord8 b *> putWord8 c+ step (V4 a b c d) = putWord8 a *> putWord8 b *> putWord8 c *> putWord8 d+ ++putString :: String -> PutM () +putString s = putLazyByteString (L.pack $ fmap (fromIntegral . ord) s) +++++texttype :: TextType -> Word8+texttype GENERIC_TEXT = 0x01+texttype COPYRIGHT_NOTICE = 0x02+texttype SEQUENCE_NAME = 0x03+texttype INSTRUMENT_NAME = 0x04+texttype LYRICS = 0x05+texttype MARKER = 0x06+texttype CUE_POINT = 0x07+
+ zmidi-core.cabal view
@@ -0,0 +1,49 @@+name: zmidi-core+version: 0.1.0+license: BSD3+license-file: LICENSE+copyright: Stephen Tetley <stephen.tetley@gmail.com>+maintainer: Stephen Tetley <stephen.tetley@gmail.com>+homepage: http://code.google.com/p/copperbox/+category: Music+synopsis: Read and write MIDI files.+description:+ Minimalist library to read and write MIDI files, with + dependencies only on ByteString and Data.Binary.+ .++build-type: Simple+stability: unstable+cabal-version: >= 1.2++extra-source-files:+ demo/MidiPrint.hs,+ demo/MidiCopy.hs+++library+ hs-source-dirs: src+ build-depends: base < 5,+ bytestring,+ binary >= 0.5+ + exposed-modules:+ ZMidi.Core.Datatypes,+ ZMidi.Core.Pretty,+ ZMidi.Core.ReadFile,+ ZMidi.Core.WriteFile++ other-modules:+ ZMidi.Core.Internal.ParserMonad,+ ZMidi.Core.Internal.SimpleFormat+ + extensions:+ ++ ghc-options:+ + includes: + ++ +