{-# LANGUAGE CPP #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : ZMidi.Core.Pretty -- Copyright : (c) Stephen Tetley 2010-2013 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : unstable -- Portability : As per dependencies. -- -- Pretty print the MIDI representation. -- -- The output format is lossy - the content of Meta and SysEx -- events may be abbreviated. This makes the format unsuitable -- as a text representation of MIDI, however it can enable -- quick /disassembly/ of MIDI files in order to see the note -- events. -- -------------------------------------------------------------------------------- module ZMidi.Core.Pretty ( putMidi , printMidi , printMidiHeader , printMidiTrack ) where import ZMidi.Core.Datatypes import ZMidi.Core.Internal.SimpleFormat import ZMidi.Core.Pretty.Internal import ZMidi.Core.Pretty.Interp #ifndef MIN_VERSION_GLASGOW_HASKELL import Data.Monoid #endif -- | Print the MIDI file to stdout. -- -- One event is printed per line, so the output may be large. -- putMidi :: MidiFile -> IO () putMidi = mapM_ putStrLn . printMidi -- | Print the MIDI file to a list of Strings. -- -- Results are returned as a list of String to avoid extraneous -- concatenation. -- printMidi :: MidiFile -> [String] printMidi (MidiFile hdr tracks) = execTable body_columns $ do tellBreak tellMidiHeader hdr mapM_ (\t -> tellBreak >> tellTrack t) $ tracks -- | Print the MIDI header. -- -- Results are returned as a list of String to avoid extraneous -- concatenation. -- printMidiHeader :: MidiFile -> [String] printMidiHeader (MidiFile hdr _) = execTable body_columns $ tellMidiHeader hdr -- | Print a track. -- -- Results are returned as a list of String to avoid extraneous -- concatenation. -- printMidiTrack :: Int -> MidiFile -> [String] printMidiTrack track_num (MidiFile _ trks) = case findTrack track_num trks of Just trk -> execTable body_columns $ tellArbTrack track_num trk Nothing -> ["*** ERROR *** cannot find track " ++ show track_num ] where -- Numbering starts from 1.. findTrack 1 (t:_) = Just t findTrack n (_:ts) | n > 1 = findTrack (n-1) ts findTrack _ _ = Nothing -------------------------------------------------------------------------------- -- -- | Helper for printing arbitrary tracks. -- tellArbTrack :: Int -> MidiTrack -> Table () tellArbTrack track_num (MidiTrack xs) = arbTrack track_num >> mapM_ message xs -- | Increment the track number (in the monad) and write a track. -- tellTrack :: MidiTrack -> Table () tellTrack (MidiTrack xs) = nextTrack >> mapM_ message xs -- | Column specs for the track tables. -- body_columns :: ColumnSpecs body_columns = ColumnSpecs '|' [ PadR 3, PadL 14, PadL 11, PadR 23, PadR 23 ] -- | Log a message using the internal Writer of the Table monad. -- message :: MidiMessage -> Table () message (delta,evt) = do incrDelta $ fromIntegral delta tellRow $ \track_num acctime -> [ integral track_num , integral acctime , integral delta , descEvent evt , valEvent evt ] -------------------------------------------------------------------------------- -- Description column -- | Get description text. -- descEvent :: MidiEvent -> WString descEvent (MidiEventOther e) = descDataOther e descEvent (VoiceEvent rs e) = descVoiceEvent rs e descEvent (SysExEvent e) = descSysExEvent e descEvent (SysCommonEvent e) = descSysCommonEvent e descEvent (SysRealTimeEvent e) = descSysRealTimeEvent e descEvent (MetaEvent e) = descMetaEvent e -- | Get description text. -- descDataOther :: MidiDataOther -> WString descDataOther (MidiDataOther {}) = text "midi data other" -- | Get description text. -- descVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> WString descVoiceEvent _ (Controller {}) = text "controller" descVoiceEvent _ (ProgramChange {}) = text "program-change" descVoiceEvent _ (NoteOff {}) = text "note-off" descVoiceEvent rs (NoteOn _ _ v) | rs == RS_ON && v == 0 = text "note-on *RS,V0*" | otherwise = text "note-on" -- | Get description text. -- descVoiceEvent _ (NoteAftertouch {}) = text "note-aftertouch" descVoiceEvent _ (ChanAftertouch {}) = text "channel-aftertouch" descVoiceEvent _ (PitchBend {}) = text "pitch-bend" -- | Get description text. -- descSysExEvent :: MidiSysExEvent -> WString descSysExEvent (SysExSingle {}) = text "sys-ex" descSysExEvent (SysExCont {}) = text "sys-ex cont" descSysExEvent (SysExEscape {}) = text "sys-ex F7" -- | Get description text. -- descSysCommonEvent :: MidiSysCommonEvent -> WString descSysCommonEvent (QuarterFrame {}) = text "time-code-1/4-frame" descSysCommonEvent (SongPosPointer {}) = text "song position ptr" descSysCommonEvent (SongSelect {}) = text "song-select" descSysCommonEvent (UndefinedF4) = text "undefined 0xF4" descSysCommonEvent (UndefinedF5) = text "undefined 0xF5" descSysCommonEvent (TuneRequest) = text "tune-request" descSysCommonEvent (EOX) = text "end-of-sys-ex" -- | Get description text. -- descSysRealTimeEvent :: MidiSysRealTimeEvent -> WString descSysRealTimeEvent (TimingClock) = text "sysRT timing-clock" descSysRealTimeEvent (UndefinedF9) = text "sysRT 0xF9" descSysRealTimeEvent (StartSequence) = text "sysRT start seq." descSysRealTimeEvent (ContinueSequence) = text "sysRT continue" descSysRealTimeEvent (StopSequence) = text "sysRT stop seq." descSysRealTimeEvent (UndefinedFD) = text "sysRT 0xFD" descSysRealTimeEvent (ActiveSensing) = text "sysRT active sensing" descSysRealTimeEvent (SystemReset) = text "sysRT reset" -- | Get description text. -- descMetaEvent :: MidiMetaEvent -> WString descMetaEvent (TextEvent ty _) = text $ textType ty descMetaEvent (SequenceNumber {}) = text "sequence-number" descMetaEvent (ChannelPrefix {}) = text "channel-prefix" descMetaEvent (MidiPort {}) = text "midi-port" descMetaEvent (EndOfTrack) = text "end-of-track" descMetaEvent (SetTempo {}) = text "set-tempo" descMetaEvent (SMPTEOffset {}) = text "smpte-offest" descMetaEvent (TimeSignature {}) = text "time-signature" descMetaEvent (KeySignature {}) = text "key-signature" descMetaEvent (SSME {}) = text "sequencer-specific" descMetaEvent (MetaOther {}) = text "meta-other" -------------------------------------------------------------------------------- -- Value column -- | Get formatted value. -- valEvent :: MidiEvent -> WString valEvent (MidiEventOther e) = valDataOther e valEvent (VoiceEvent _ e) = valVoiceEvent e valEvent (SysExEvent e) = valSysExEvent e valEvent (SysCommonEvent e) = valSysCommonEvent e valEvent (SysRealTimeEvent e) = valSysRealTimeEvent e valEvent (MetaEvent e) = valMetaEvent e -- | Get formatted value. -- valDataOther :: MidiDataOther -> WString valDataOther (MidiDataOther n) = hex2 n -- | Get formatted value. -- valVoiceEvent :: MidiVoiceEvent -> WString valVoiceEvent (Controller c n v) = hex2 c <+> hex2 n <+> hex2 v valVoiceEvent (ProgramChange c n) = hex2 c <+> hex2 n valVoiceEvent (NoteOff c n v) = hex2 c <+> hex2 n <+> hex2 v valVoiceEvent (NoteOn c n v) = hex2 c <+> hex2 n <+> hex2 v valVoiceEvent (NoteAftertouch c n v) = hex2 c <+> hex2 n <+> hex2 v valVoiceEvent (ChanAftertouch c v) = hex2 c <+> hex2 v valVoiceEvent (PitchBend c v) = hex2 c <+> hex4 (fromIntegral v) -- | Get formatted value. -- valSysExEvent :: MidiSysExEvent -> WString valSysExEvent (SysExSingle n ws) = byteList n ws valSysExEvent (SysExCont n ws _) = byteList n ws valSysExEvent (SysExEscape n ws) = byteList n ws -- | Get formatted value. -- valSysCommonEvent :: MidiSysCommonEvent -> WString valSysCommonEvent (QuarterFrame sb) = hex2 sb valSysCommonEvent (SongPosPointer a b) = hex2 a <+> hex2 b valSysCommonEvent (SongSelect w) = hex2 w valSysCommonEvent (UndefinedF4) = mempty valSysCommonEvent (UndefinedF5) = mempty valSysCommonEvent (TuneRequest) = mempty valSysCommonEvent (EOX) = mempty -- | Get formatted value. -- valSysRealTimeEvent :: MidiSysRealTimeEvent -> WString valSysRealTimeEvent _ = mempty -- | Get formatted value. -- valMetaEvent :: MidiMetaEvent -> WString valMetaEvent (TextEvent _ s) = text $ safeString s valMetaEvent (SequenceNumber w) = hex4 w valMetaEvent (ChannelPrefix ch) = hex2 ch valMetaEvent (MidiPort w) = hex2 w valMetaEvent (EndOfTrack) = mempty valMetaEvent (SetTempo w) = integral w valMetaEvent (SMPTEOffset h m s f sf) = mconcat $ map hex2 [h,m,s,f,sf] valMetaEvent (TimeSignature n d m t) = let tsig = text $ timeSignatureName (fromIntegral n) (fromIntegral d) in tsig <+> hex2 m <+> hex2 t valMetaEvent (KeySignature n sc) = maybe (text "unrecognized") text $ midiScaleName sc (fromIntegral n) valMetaEvent (SSME n ws) = byteList n ws valMetaEvent (MetaOther ty len ws) = hex2 ty <+> byteList len ws