diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/demo/MidiCopy.hs b/demo/MidiCopy.hs new file mode 100644 --- /dev/null +++ b/demo/MidiCopy.hs @@ -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 " + , "--" + , "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... + + diff --git a/demo/MidiPrint.hs b/demo/MidiPrint.hs new file mode 100644 --- /dev/null +++ b/demo/MidiPrint.hs @@ -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 " + +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 + + diff --git a/src/ZMidi/Core/Datatypes.hs b/src/ZMidi/Core/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/Datatypes.hs @@ -0,0 +1,517 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.Datatypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- 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) "" diff --git a/src/ZMidi/Core/Internal/ParserMonad.hs b/src/ZMidi/Core/Internal/ParserMonad.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/Internal/ParserMonad.hs @@ -0,0 +1,202 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.Internal.ParseMonad +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- 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 diff --git a/src/ZMidi/Core/Internal/SimpleFormat.hs b/src/ZMidi/Core/Internal/SimpleFormat.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/Internal/SimpleFormat.hs @@ -0,0 +1,118 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.Internal.SimpleFormat +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- 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 diff --git a/src/ZMidi/Core/Pretty.hs b/src/ZMidi/Core/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/Pretty.hs @@ -0,0 +1,210 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.Pretty +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- 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" diff --git a/src/ZMidi/Core/ReadFile.hs b/src/ZMidi/Core/ReadFile.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/ReadFile.hs @@ -0,0 +1,276 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.ReadFile +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- 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 diff --git a/src/ZMidi/Core/WriteFile.hs b/src/ZMidi/Core/WriteFile.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/WriteFile.hs @@ -0,0 +1,250 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.WriteFile +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- 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 + diff --git a/zmidi-core.cabal b/zmidi-core.cabal new file mode 100644 --- /dev/null +++ b/zmidi-core.cabal @@ -0,0 +1,49 @@ +name: zmidi-core +version: 0.1.0 +license: BSD3 +license-file: LICENSE +copyright: Stephen Tetley +maintainer: Stephen Tetley +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: + + + +