diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,18 @@ +0.2.1 to 0.3.0: + + * Revised naming of the MIDI data types. All data types now have + the prefix Midi (previously only MidiFile followed this scheme). + The rationale for this is client software, that might want a + higher-level representation, is then free to use the more + generic names Track, Message, etc. + + * @DeltaTime@ made a newtype wrapper rather than a type synonym. + + * Renamed the pretty print functions @track@ to @printMidiTrack@ + and @header@ to @printMidiHeader@. + + * Moved internal dataypes (SplitByte, Varlen) into a private + module. 0.2.0 to 0.2.1: diff --git a/demo/MidiCopy.hs b/demo/MidiCopy.hs --- a/demo/MidiCopy.hs +++ b/demo/MidiCopy.hs @@ -6,9 +6,7 @@ module Main where -import ZMidi.Core.ReadFile -import ZMidi.Core.WriteFile - +import ZMidi.Core import System.Environment @@ -31,7 +29,7 @@ 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... + Right a -> do { mapM_ putStrLn $ printMidiHeader $ mf_header a + ; writeMidi (filename ++ ".001") a } diff --git a/demo/MidiTune.hs b/demo/MidiTune.hs new file mode 100644 --- /dev/null +++ b/demo/MidiTune.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -Wall #-} + +-- +-- Write a MIDI \"tune\". +-- +-- The MIDI AST should be considered too low level to work with +-- directly... +-- + +module Main where + +import ZMidi.Core + +import System.Directory + + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + writeMidi "./out/midi_tune.mid" midi_tune01 + + +midi_tune01 :: MidiFile +midi_tune01 = MidiFile + { mf_header = MidiHeader { hdr_format = MF1 + , num_tracks = 2 + , time_division = TPB 480 + } + , mf_tracks = [ meta_track, sound_track ] + } + where + meta_track = MidiTrack [ (0, MetaEvent $ TextEvent SEQUENCE_NAME "Track 0") + , (0, MetaEvent $ EndOfTrack) + ] + + sound_track = MidiTrack [ (0, MetaEvent $ TextEvent SEQUENCE_NAME "Track 1") + , (0, MetaEvent $ SetTempo 500000) + , (0, VoiceEvent $ NoteOn 0 60 127) + , (480, VoiceEvent $ NoteOff 0 60 15) + , (0, VoiceEvent $ NoteOn 0 62 127) + , (480, VoiceEvent $ NoteOff 0 62 15) + , (0, VoiceEvent $ NoteOn 0 64 127) + , (480, VoiceEvent $ NoteOff 0 64 15) + , (0, VoiceEvent $ NoteOn 0 66 127) + , (480, VoiceEvent $ NoteOff 0 66 15) + , (0, MetaEvent $ EndOfTrack) + ] + + + diff --git a/src/ZMidi/Core/Datatypes.hs b/src/ZMidi/Core/Datatypes.hs --- a/src/ZMidi/Core/Datatypes.hs +++ b/src/ZMidi/Core/Datatypes.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -8,7 +9,7 @@ -- -- Maintainer : Stephen Tetley -- Stability : unstable --- Portability : As per dependencies. +-- Portability : GHC (at least generalized newtype deriving) -- -- Concrete syntax tree for MIDI files. -- @@ -26,45 +27,47 @@ module ZMidi.Core.Datatypes ( - -- * MidiFile representation. - MidiFile(..) - , Header(..) - , Track(..) - , Format(..) - , DeltaTime - , Message - , Event(..) - , DataEvent(..) - , VoiceEvent(..) - , SysExEvent(..) - , SysCommonEvent(..) - , SysRealTimeEvent(..) - , MetaEvent(..) - , TimeDivision(..) - , TextType(..) - , ScaleType(..) + -- * MidiFile syntax. + DeltaTime + , TagByte - -- * Interim types. - -- ** SplitByte - , SplitByte(..) - , splitByte - , joinByte - - -- ** Varlen - , Varlen(..) - , fromVarlen - , toVarlen + , MidiFile(..) + , MidiHeader(..) + , MidiTrack(..) + , MidiFormat(..) + , MidiMessage + , MidiEvent(..) - , hexStr + , MidiDataEvent(..) + , MidiVoiceEvent(..) + , MidiSysExEvent(..) + , MidiSysCommonEvent(..) + , MidiSysRealTimeEvent(..) + , MidiMetaEvent(..) + , MidiTimeDivision(..) + , MidiTextType(..) + , MidiScaleType(..) ) where -import Data.Bits import Data.Int import Data.Word -import Numeric (showHex) + +-- | All time values in a MIDI track are represented as a \delta\ +-- from the previous event rather than an absolute time. +-- +-- DeltaTime is a newtype wrapper over Word32, note that in MIDI +-- files it is represented as a @varlen@ to save space rather than +-- a four byte number. +-- +newtype DeltaTime = DeltaTime { getDeltaTime :: Word32 } + deriving (Enum,Eq,Ord,Num,Integral,Real) + +instance Show DeltaTime where + showsPrec p = showsPrec p . getDeltaTime + -- | TagByte is an alias to 'Word8'. -- type TagByte = Word8 @@ -73,8 +76,8 @@ -- | 'MidiFile' : @ header * tracks @ -- data MidiFile = MidiFile - { mf_header :: Header - , mf_tracks :: [Track] + { mf_header :: MidiHeader + , mf_tracks :: [MidiTrack] } deriving (Eq,Show) @@ -85,11 +88,11 @@ -- The header is the start of a MIDI file, it is indicated by the -- 4 character marker @MThd@. -- -data Header = Header - { hdr_format :: Format +data MidiHeader = MidiHeader + { hdr_format :: MidiFormat , num_tracks :: Word16 - , time_division :: TimeDivision - } + , time_division :: MidiTimeDivision + } deriving (Eq,Show) -- | 'Track' : @ [message] @ @@ -97,13 +100,13 @@ -- In MIDI files, the start of a track is indicated by the 4 -- character marker @MTrk@. -- -newtype Track = Track { getMessages :: [Message] } +newtype MidiTrack = MidiTrack { getTrackMessages :: [MidiMessage] } 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 +data MidiFormat -- | Format 0 file - single multi-channel track. = MF0 -- | Format 1 file - 1 or more tracks, played simultaneously. @@ -114,12 +117,12 @@ -- | Default unit of time in the MIDI file. -- -data TimeDivision +data MidiTimeDivision -- | Frames-per-second. -- = FPS Word16 - -- | Ticks-per-beat, i.e. the number of units for a quater + -- | Ticks-per-beat, i.e. the number of units for a quarter -- note. -- | TPB Word16 @@ -127,7 +130,7 @@ -- | Enumeration of the text meta event types. -- -data TextType +data MidiTextType = GENERIC_TEXT | COPYRIGHT_NOTICE | SEQUENCE_NAME @@ -137,13 +140,6 @@ | 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. @@ -151,7 +147,7 @@ -- Sequential messages with delta time 0 are played -- simultaneously. -- -type Message = (DeltaTime, Event) +type MidiMessage = (DeltaTime, MidiEvent) -- Note, the Ord instance for pairs is very useful for rendering. @@ -165,38 +161,38 @@ -- | Recognised event types - some types ('DataEvent' and -- 'SysEx') are not interpreted. -- -data Event +data MidiEvent -- | Data event - just initial tag byte, -- uninterpreted -- - = DataEvent DataEvent + = DataEvent MidiDataEvent -- | Voice event (e.g @note-on@, @note-off@) are relayed to specific -- channels. -- - | VoiceEvent VoiceEvent + | VoiceEvent MidiVoiceEvent -- | SysEx - system exclusive event. Usually synthesizer -- specific, not interpreted. -- - | SysExEvent SysExEvent + | SysExEvent MidiSysExEvent -- | SysCommon - system common event. -- - | SysCommonEvent SysCommonEvent + | SysCommonEvent MidiSysCommonEvent -- | SysRealTime - system realtime event. -- - | SysRealTimeEvent SysRealTimeEvent + | SysRealTimeEvent MidiSysRealTimeEvent -- | Meta event - interpreted (e.g. @end-of-track@, -- @set-tempo@). -- - | MetaEvent MetaEvent + | MetaEvent MidiMetaEvent deriving (Eq,Show,Ord) @@ -206,7 +202,7 @@ -- Data events have no payload - they are represented only by the -- tag byte. -- -data DataEvent = Data1 TagByte +newtype MidiDataEvent = MidiDataEvent { getTagByte :: TagByte } deriving (Eq,Ord,Show) -- | Voice events control the output of the synthesizer. @@ -221,7 +217,7 @@ -- delta-time. Changing the order of the constructors helps to -- sort for this. -- -data VoiceEvent +data MidiVoiceEvent -- | @ channel * controller_number * value @ -- -- Controller change, e.g. by a footswitch. @@ -269,7 +265,7 @@ -- | \SysEx\ - system exclusive event. -- -data SysExEvent +data MidiSysExEvent -- | @ length * data @ -- -- An uninterpreted sys-ex event. @@ -286,10 +282,13 @@ -- computer (as opposed to MIDI generated by a synthesizer or -- sequencer). -- -data SysCommonEvent +data MidiSysCommonEvent -- | Time code quarter frame. + -- + -- Note the payload is really a byte split into two 4-bit + -- values, however here it is uninterpreted. -- - = QuarterFrame SplitByte + = QuarterFrame Word8 -- | Song position pointer. -- @@ -323,7 +322,7 @@ -- computer (as opposed to MIDI generated by a synthesizer or -- sequencer). -- -data SysRealTimeEvent +data MidiSysRealTimeEvent -- | Timing signal. -- = TimingClock @@ -367,14 +366,14 @@ -- only appear in track 1. Certain events (e.g. end-of-track) -- can appear in any track where necessary. -- -data MetaEvent +data MidiMetaEvent -- | @ text_type * contents @ -- -- Free text field (e.g. copyright statement). The contents -- can notionally be any length. -- - = TextEvent TextType String + = TextEvent MidiTextType String -- | @ value @ -- @@ -424,7 +423,7 @@ -- -- @scale_type@ indicates major or minor. -- - | KeySignature Int8 ScaleType + | KeySignature Int8 MidiScaleType -- | @ length * data@ -- @@ -436,85 +435,7 @@ -- | Scale type - @major@ or @minor@. -- -data ScaleType = MAJOR | MINOR +data MidiScaleType = 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 :: (Show a, Integral a) => a -> String -hexStr i = (showString "0x" . showHex i) "" diff --git a/src/ZMidi/Core/Internal/ExtraTypes.hs b/src/ZMidi/Core/Internal/ExtraTypes.hs new file mode 100644 --- /dev/null +++ b/src/ZMidi/Core/Internal/ExtraTypes.hs @@ -0,0 +1,115 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : ZMidi.Core.Internal.ExtraTypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : unstable +-- Portability : As per dependencies. +-- +-- Internal types not exported by the package. +-- +-------------------------------------------------------------------------------- + + +module ZMidi.Core.Internal.ExtraTypes + ( + + -- * SplitByte + SplitByte(..) + , splitByte + , joinByte + + -- * Varlen + , Varlen(..) + , fromVarlen + , toVarlen + + , hexStr + + ) where + +import Data.Bits +import Data.Word +import Numeric (showHex) + + + +-- | 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 :: (Show a, Integral a) => a -> String +hexStr i = (showString "0x" . showHex i) "" diff --git a/src/ZMidi/Core/Pretty.hs b/src/ZMidi/Core/Pretty.hs --- a/src/ZMidi/Core/Pretty.hs +++ b/src/ZMidi/Core/Pretty.hs @@ -20,8 +20,8 @@ printMidi - , header - , track + , printMidiHeader + , printMidiTrack ) where @@ -40,10 +40,10 @@ printMidi :: MidiFile -> IO () printMidi (MidiFile hdr tracks) = do column_break - mapM_ putStrLn (header hdr) + mapM_ putStrLn (printMidiHeader hdr) mapM_ (\t -> column_break >> putTrack t) tracks where - putTrack = (mapM_ putStrLn) . track + putTrack = (mapM_ putStrLn) . printMidiTrack column_break = putStrLn $ replicate 60 '-' @@ -52,8 +52,8 @@ -- Results are returned as a list of String to avoid extraneous -- concatenation. -- -header :: Header -> [String] -header (Header fmt tcount td) = +printMidiHeader :: MidiHeader -> [String] +printMidiHeader (MidiHeader fmt tcount td) = map output [ppFormat fmt, ppNumTracks tcount, ppTimeDivision td] -- | Print a track. @@ -61,9 +61,10 @@ -- 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 +printMidiTrack :: MidiTrack -> [String] +printMidiTrack = snd . mapAccumL fn 0 . getTrackMessages where + fn acc b = msnd output $ message acc b msnd f (a,b) = (a,f b) -------------------------------------------------------------------------------- @@ -71,7 +72,7 @@ column2 :: String -> Doc -> Doc column2 s d2 = padr 20 (text s) `sep` char '|' `ssep` d2 -ppFormat :: Format -> Doc +ppFormat :: MidiFormat -> Doc ppFormat = column2 "MIDI Format" . step where step MF0 = text "Type 0 MIDI File" @@ -81,7 +82,7 @@ ppNumTracks :: Word16 -> Doc ppNumTracks = column2 "Number of tracks" . integral -ppTimeDivision :: TimeDivision -> Doc +ppTimeDivision :: MidiTimeDivision -> Doc ppTimeDivision = column2 "Time Division" . step where step (FPS i) = text "fps" `ssep` integral i @@ -92,15 +93,15 @@ dashsep :: Doc -> Doc -> Doc dashsep d1 d2 = d1 `ssep` char '-' `ssep` d2 -message :: Word32 -> Message -> (Word32,Doc) +message :: Word32 -> MidiMessage -> (Word32,Doc) message acc (delta,evt) = (n, acctime `dashsep` dtime `dashsep` ppEvent evt) where - n = acc + delta + n = acc + fromIntegral delta acctime = padl 12 (integral n) dtime = padl 6 (integral delta) -ppEvent :: Event -> Doc +ppEvent :: MidiEvent -> Doc ppEvent (DataEvent e) = ppDataEvent e ppEvent (VoiceEvent e) = ppVoiceEvent e ppEvent (SysExEvent e) = ppSysExEvent e @@ -112,10 +113,10 @@ event :: String -> Doc -> Doc event s d = padr 18 (text s) `dashsep` d -ppDataEvent :: DataEvent -> Doc -ppDataEvent (Data1 tag) = event "data" (hex2 tag) +ppDataEvent :: MidiDataEvent -> Doc +ppDataEvent (MidiDataEvent tag) = event "data" (hex2 tag) -ppVoiceEvent :: VoiceEvent -> Doc +ppVoiceEvent :: MidiVoiceEvent -> Doc ppVoiceEvent (Controller c n v) = event "controller" (hex2 c `ssep` hex2 n `ssep` hex2 v) @@ -138,12 +139,13 @@ event "pitch-bend" (hex2 c `ssep` hex4 v) -ppSysExEvent :: SysExEvent -> Doc +ppSysExEvent :: MidiSysExEvent -> Doc ppSysExEvent (SysEx n ws) = event "sys-ex" $ byteList n ws -ppSysCommonEvent :: SysCommonEvent -> Doc + +ppSysCommonEvent :: MidiSysCommonEvent -> Doc ppSysCommonEvent (QuarterFrame sb) = - event "time-code-quarter-frame" (hex2 $ joinByte sb) + event "time-code-quarter-frame" (hex2 sb) ppSysCommonEvent (SongPosPointer a b) = event "sys-common song pos. pointer" (hex2 a `ssep` hex2 b) @@ -157,7 +159,7 @@ ppSysCommonEvent EOX = text "end-of-sys-ex" -ppSysRealTimeEvent :: SysRealTimeEvent -> Doc +ppSysRealTimeEvent :: MidiSysRealTimeEvent -> 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" @@ -166,7 +168,8 @@ ppSysRealTimeEvent ActiveSensing = text "sys-real-time active sensing" ppSysRealTimeEvent SystemReset = text "system-reset" -ppMetaEvent :: MetaEvent -> Doc + +ppMetaEvent :: MidiMetaEvent -> Doc ppMetaEvent (TextEvent ty s) = event (textType ty) (text s) ppMetaEvent (SequenceNumber w) = event "sequence-number" (hex4 w) @@ -195,7 +198,7 @@ | otherwise = integral n `sep` multiply 10 '.' -textType :: TextType -> String +textType :: MidiTextType -> String textType GENERIC_TEXT = "generic-text" textType COPYRIGHT_NOTICE = "copyright-notice" textType SEQUENCE_NAME = "sequence-name" @@ -205,6 +208,6 @@ textType CUE_POINT = "cue-point" -ppScale :: ScaleType -> Doc +ppScale :: MidiScaleType -> Doc ppScale MAJOR = text "major" ppScale MINOR = text "minor" diff --git a/src/ZMidi/Core/ReadFile.hs b/src/ZMidi/Core/ReadFile.hs --- a/src/ZMidi/Core/ReadFile.hs +++ b/src/ZMidi/Core/ReadFile.hs @@ -27,6 +27,7 @@ ) where import ZMidi.Core.Datatypes +import ZMidi.Core.Internal.ExtraTypes import ZMidi.Core.Internal.ParserMonad @@ -46,41 +47,41 @@ midiFile :: ParserM MidiFile -midiFile = do +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 + trackCount :: MidiHeader -> Int + trackCount (MidiHeader _ n _) = fromIntegral n -header :: ParserM Header -header = Header <$> (assertString "MThd" *> assertWord32 (6::Int) *> format) - <*> word16be - <*> timeDivision +header :: ParserM MidiHeader +header = MidiHeader <$> (assertString "MThd" *> assertWord32 (6::Int) *> format) + <*> word16be + <*> timeDivision -track :: ParserM Track -track = liftM Track (trackHeader >>= messages) +track :: ParserM MidiTrack +track = liftM MidiTrack (trackHeader >>= messages) trackHeader :: ParserM Word32 trackHeader = assertString "MTrk" >> word32be -messages :: Word32 -> ParserM [Message] +messages :: Word32 -> ParserM [MidiMessage] messages i = boundRepeat (fromIntegral i) message -message :: ParserM Message +message :: ParserM MidiMessage message = (,) <$> deltaTime <*> event -deltaTime :: ParserM Word32 -deltaTime = "delta time" getVarlen +deltaTime :: ParserM DeltaTime +deltaTime = "delta time" fmap fromIntegral getVarlen -event :: ParserM Event +event :: ParserM MidiEvent event = word8 >>= step where -- 00..7f -- /data/ @@ -91,12 +92,12 @@ | 0x80 <= n = VoiceEvent <$> voiceEvent (splitByte n) | otherwise = DataEvent <$> dataEvent n -dataEvent :: Word8 -> ParserM DataEvent -dataEvent tag = pure $ Data1 tag +dataEvent :: Word8 -> ParserM MidiDataEvent +dataEvent tag = pure $ MidiDataEvent tag -voiceEvent :: SplitByte -> ParserM VoiceEvent +voiceEvent :: SplitByte -> ParserM MidiVoiceEvent voiceEvent (SB 0x8 ch) = "note-off" (NoteOff ch) <$> word8 <*> word8 @@ -121,9 +122,10 @@ voiceEvent (SB z _ ) = reportError $ "voiceEvent " ++ hexStr z -sysCommonEvent :: Word8 -> ParserM SysCommonEvent + +sysCommonEvent :: Word8 -> ParserM MidiSysCommonEvent sysCommonEvent 0xF1 = - "quarter frame" QuarterFrame . splitByte <$> word8 + "quarter frame" QuarterFrame <$> word8 sysCommonEvent 0xF2 = "song pos. pointer" SongPosPointer <$> word8 <*> word8 @@ -142,7 +144,7 @@ sysCommonEvent tag = pure $ Common_undefined tag -sysRealTimeEvent :: Word8 -> ParserM SysRealTimeEvent +sysRealTimeEvent :: Word8 -> ParserM MidiSysRealTimeEvent sysRealTimeEvent 0xF8 = pure TimingClock sysRealTimeEvent 0xF9 = pure $ RT_undefined 0xF9 sysRealTimeEvent 0xFA = pure StartSequence @@ -154,12 +156,12 @@ sysRealTimeEvent tag = pure $ RT_undefined tag -sysExEvent :: ParserM SysExEvent +sysExEvent :: ParserM MidiSysExEvent sysExEvent = "sys-ex" (uncurry SysEx) <$> getVarlenBytes -metaEvent :: Word8 -> ParserM MetaEvent +metaEvent :: Word8 -> ParserM MidiMetaEvent metaEvent 0x00 = "sequence number" SequenceNumber <$> (assertWord8 2 *> word16be) @@ -202,7 +204,7 @@ -format :: ParserM Format +format :: ParserM MidiFormat format = word16be >>= fn where fn 0 = return MF0 @@ -211,13 +213,13 @@ fn z = reportError $ "getFormat - unrecognized file format " ++ hexStr z -timeDivision :: ParserM TimeDivision +timeDivision :: ParserM MidiTimeDivision timeDivision = division <$> word16be where division i | i `testBit` 15 = FPS (i `clearBit` 15) | otherwise = TPB i -scale :: ParserM ScaleType +scale :: ParserM MidiScaleType scale = word8 >>= fn where fn 0 = return MAJOR @@ -225,7 +227,7 @@ fn z = reportError $ "scale expecting 0 or 1, got " ++ hexStr z -textEvent :: TextType -> ParserM MetaEvent +textEvent :: MidiTextType -> ParserM MidiMetaEvent textEvent ty = (TextEvent ty . snd) <$> getVarlenText -------------------------------------------------------------------------------- @@ -237,7 +239,7 @@ where msg = "assertWord8 - input did not match " ++ show i -assertWord32 :: (Show a, Integral a) => a -> ParserM Word32 +assertWord32 :: (Integral a, Show a) => a -> ParserM Word32 assertWord32 i = postCheck word32be ((==i) . fromIntegral) msg where msg = "assertWord32 - input did not match " ++ show i diff --git a/src/ZMidi/Core/VersionNumber.hs b/src/ZMidi/Core/VersionNumber.hs --- a/src/ZMidi/Core/VersionNumber.hs +++ b/src/ZMidi/Core/VersionNumber.hs @@ -22,7 +22,7 @@ -- | Version number -- --- > (0,2,1) +-- > (0,3,0) -- zmidi_core_version :: (Int,Int,Int) -zmidi_core_version = (0,2,1) +zmidi_core_version = (0,3,0) diff --git a/src/ZMidi/Core/WriteFile.hs b/src/ZMidi/Core/WriteFile.hs --- a/src/ZMidi/Core/WriteFile.hs +++ b/src/ZMidi/Core/WriteFile.hs @@ -14,7 +14,6 @@ -- -------------------------------------------------------------------------------- - module ZMidi.Core.WriteFile ( -- * Write a Midi structure to file @@ -22,7 +21,7 @@ ) where import ZMidi.Core.Datatypes - +import ZMidi.Core.Internal.ExtraTypes import Data.Binary.Put -- package: binary @@ -46,35 +45,35 @@ putMidiFile (MidiFile hdr trks) = putHeader hdr *> mapM_ putTrack trks -putHeader :: Header -> PutM () -putHeader (Header fmt n td) = +putHeader :: MidiHeader -> PutM () +putHeader (MidiHeader fmt n td) = putString "MThd" *> putWord32be 6 *> putFormat fmt *> putWord16be n *> putTimeDivision td -putTrack :: Track -> PutM () -putTrack (Track ms) = +putTrack :: MidiTrack -> PutM () +putTrack (MidiTrack ms) = putString "MTrk" *> (putWord32be $ fromIntegral $ L.length bs) *> putLazyByteString bs where bs = runPut (mapM_ putMessage ms) -putFormat :: Format -> PutM () +putFormat :: MidiFormat -> PutM () putFormat MF0 = putWord16be 0 putFormat MF1 = putWord16be 1 putFormat MF2 = putWord16be 2 -putTimeDivision :: TimeDivision -> PutM () +putTimeDivision :: MidiTimeDivision -> 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 +putMessage :: MidiMessage -> PutM () +putMessage (dt,evt) = putVarlen (fromIntegral dt) *> putEvent evt -putEvent :: Event -> PutM () +putEvent :: MidiEvent -> PutM () putEvent (DataEvent e) = putDataEvent e putEvent (VoiceEvent e) = putVoiceEvent e putEvent (SysExEvent e) = putSysExEvent e @@ -83,10 +82,10 @@ putEvent (MetaEvent e) = putMetaEvent e -putDataEvent :: DataEvent -> PutM () -putDataEvent (Data1 tag) = putWord8 tag +putDataEvent :: MidiDataEvent -> PutM () +putDataEvent (MidiDataEvent tag) = putWord8 tag -putVoiceEvent :: VoiceEvent -> PutM () +putVoiceEvent :: MidiVoiceEvent -> PutM () putVoiceEvent (NoteOff c n v) = putWord8 (0x8 `u4l4` c) *> putWord8 n *> putWord8 v @@ -108,13 +107,15 @@ putVoiceEvent (PitchBend c v) = putWord8 (0xE `u4l4` c) *> putWord16be v -putSysExEvent :: SysExEvent -> PutM () + +putSysExEvent :: MidiSysExEvent -> PutM () putSysExEvent (SysEx n ws) = putWord8 0xF0 *> putVarlen n *> mapM_ putWord8 ws -putSysCommonEvent :: SysCommonEvent -> PutM () + +putSysCommonEvent :: MidiSysCommonEvent -> PutM () putSysCommonEvent (QuarterFrame sb) = - putWord8 0xF1 *> putSplitByte sb + putWord8 0xF1 *> putWord8 sb putSysCommonEvent (SongPosPointer lsb msb) = putWord8 0xF2 *> putWord8 lsb *> putWord8 msb @@ -131,7 +132,8 @@ putSysCommonEvent EOX = putWord8 0xF7 -putSysRealTimeEvent :: SysRealTimeEvent -> PutM () + +putSysRealTimeEvent :: MidiSysRealTimeEvent -> PutM () putSysRealTimeEvent TimingClock = putWord8 0xF8 putSysRealTimeEvent (RT_undefined tag) = putWord8 tag putSysRealTimeEvent StartSequence = putWord8 0xFA @@ -140,7 +142,8 @@ putSysRealTimeEvent ActiveSensing = putWord8 0xFE putSysRealTimeEvent SystemReset = putWord8 0xFF -putMetaEvent :: MetaEvent -> PutM () + +putMetaEvent :: MidiMetaEvent -> PutM () putMetaEvent (TextEvent ty ss) = putWord8 0xFF *> putWord8 (texttype ty) *> putVarlen (fromIntegral $ length ss) @@ -189,8 +192,6 @@ prefixLen :: Word8 -> PutM () -> PutM () prefixLen n out = putWord8 n *> out -putSplitByte :: SplitByte -> PutM () -putSplitByte a = putWord8 (joinByte a) infixr 5 `u4l4` @@ -205,7 +206,7 @@ i' :: Int i' = fromIntegral i -wscale :: ScaleType -> Word8 +wscale :: MidiScaleType -> Word8 wscale MAJOR = 0x00 wscale MINOR = 0x01 @@ -239,7 +240,7 @@ -texttype :: TextType -> Word8 +texttype :: MidiTextType -> Word8 texttype GENERIC_TEXT = 0x01 texttype COPYRIGHT_NOTICE = 0x02 texttype SEQUENCE_NAME = 0x03 diff --git a/zmidi-core.cabal b/zmidi-core.cabal --- a/zmidi-core.cabal +++ b/zmidi-core.cabal @@ -1,5 +1,5 @@ name: zmidi-core -version: 0.2.1 +version: 0.3.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -8,11 +8,28 @@ 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. . Changelog: . + v0.2.1 to v0.3.0: + . + * Revised naming of the MIDI data types. All data types now have + the prefix Midi (previously only MidiFile followed this scheme). + The rationale for this is client software, that might want a + higher-level representation, is then free to use the more + generic names Track, Message, etc. + . + * @DeltaTime@ made a newtype wrapper rather than a type synonym. + . + * Renamed the pretty print functions @track@ to @printMidiTrack@ + and @header@ to @printMidiHeader@. + . + * Moved internal dataypes (SplitByte, Varlen) into a private + module. + . v0.2.0 to v0.2.1: . * Added Show class constraints to various type signatures to @@ -31,8 +48,9 @@ extra-source-files: CHANGES, + demo/MidiCopy.hs, demo/MidiPrint.hs, - demo/MidiCopy.hs + demo/MidiTune.hs library @@ -50,6 +68,7 @@ ZMidi.Core.WriteFile other-modules: + ZMidi.Core.Internal.ExtraTypes, ZMidi.Core.Internal.ParserMonad, ZMidi.Core.Internal.SimpleFormat