{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  ZMidi.Core.Pretty
-- Copyright   :  (c) Stephen Tetley 2010-2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- 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
  (

    printMidi

  , printMidiHeader
  , printMidiTrack

  ) where

import ZMidi.Core.Datatypes
import ZMidi.Core.Internal.SimpleFormat

import Data.Char
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 (printMidiHeader hdr)  
    mapM_ (\t -> column_break >> putTrack t) tracks
  where
    putTrack       = (mapM_ putStrLn) . printMidiTrack
    column_break   = putStrLn $ replicate 60 '-'


-- | Print the MIDI header.
--
-- Results are returned as a list of String to avoid extraneous
-- concatenation.
-- 
printMidiHeader :: MidiHeader -> [String]
printMidiHeader (MidiHeader 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.
--
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)

--------------------------------------------------------------------------------

column2 :: String -> Doc -> Doc
column2 s d2 = padr 20 (text s) `cat` char '|' `sep` d2 

ppFormat :: MidiFormat -> 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 :: MidiTimeDivision -> Doc
ppTimeDivision = column2 "Time Division" . step
  where
    step (FPS i)   = text "fps"   `sep` integral i
    step (TPB i)   = text "ticks" `sep` integral i

infixr 7 `dashsep`

dashsep :: Doc -> Doc -> Doc
dashsep d1 d2 = d1 `sep` char '-' `sep` d2

message :: Word32 -> MidiMessage -> (Word32,Doc)
message acc (delta,evt) = 
    (n, acctime `dashsep` dtime `dashsep` ppEvent evt)
  where
    n       = acc + fromIntegral delta 
    acctime = padl 12 (integral n)
    dtime   = padl 6  (integral delta)

ppEvent :: MidiEvent -> Doc
ppEvent (MidiEventOther e)    = ppMidiDataOther e
ppEvent (VoiceEvent rs e)     = ppVoiceEvent rs 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

ppMidiDataOther :: MidiDataOther -> Doc
ppMidiDataOther (MidiDataOther n)     = event "midi data other" (hex2 n)


-- | Voice event needs RunningStatus...

ppVoiceEvent :: MidiRunningStatus -> MidiVoiceEvent -> Doc
ppVoiceEvent _  (Controller c n v)     = 
    event "controller" (hex2 c `sep` hex2 n `sep` hex2 v)

ppVoiceEvent _  (ProgramChange c n)    = 
    event "program-change" (hex2 c `sep` hex2 n)

ppVoiceEvent _ (NoteOff c n v)        =
    event "note-off" (hex2 c `sep` hex2 n `sep` hex2 v)

ppVoiceEvent rs (NoteOn c n v)         
    | rs == RS_ON && v == 0 = event "note-off (RS,V0)" 
                                    (hex2 c `sep` hex2 n `sep` hex2 v)
    | otherwise = event "note-on" (hex2 c `sep` hex2 n `sep` hex2 v)


ppVoiceEvent _  (NoteAftertouch c n v) =
    event "note-aftertouch" (hex2 c `sep` hex2 n `sep` hex2 v)

ppVoiceEvent _  (ChanAftertouch c v)   = 
    event "channel-aftertouch" (hex2 c `sep` hex2 v)

ppVoiceEvent _  (PitchBend c v)        =
    event "pitch-bend" (hex2 c `sep` hex4 v)


ppSysExEvent :: MidiSysExEvent -> Doc
ppSysExEvent (SysEx n ws) = event "sys-ex" $ byteList n ws


ppSysCommonEvent :: MidiSysCommonEvent -> Doc
ppSysCommonEvent (QuarterFrame sb)      = 
    event "time-code-quarter-frame" (hex2 sb)

ppSysCommonEvent (SongPosPointer a b)   = 
    event "sys-common song pos. pointer" (hex2 a `sep` hex2 b)

ppSysCommonEvent (SongSelect w)         = event "song-select" (hex2 w)

ppSysCommonEvent (UndefinedF4)          = text "undefined 0xF4"

ppSysCommonEvent (UndefinedF5)          = text "undefined 0xF5"

ppSysCommonEvent (TuneRequest)          = text "tune-request"

ppSysCommonEvent (EOX)                  = text "end-of-sys-ex"


ppSysRealTimeEvent :: MidiSysRealTimeEvent -> Doc
ppSysRealTimeEvent (TimingClock)        = text "sys-real-time timing-clock"
ppSysRealTimeEvent (UndefinedF9)        = text "sys-real-time 0xF9"
ppSysRealTimeEvent (StartSequence)      = text "sys-real-time start"
ppSysRealTimeEvent (ContinueSequence)   = text "sys-real-time continue"
ppSysRealTimeEvent (StopSequence)       = text "sys-real-time stop"
ppSysRealTimeEvent (UndefinedFD)        = text "sys-real-time 0xFD"
ppSysRealTimeEvent (ActiveSensing)      = text "sys-real-time active sensing"
ppSysRealTimeEvent (SystemReset)        = text "system-reset"


ppMetaEvent :: MidiMetaEvent -> Doc
ppMetaEvent (TextEvent ty s)          = event (textType ty) (text $ safeString s)

ppMetaEvent (SequenceNumber w)        = event "sequence-number" (hex4 w)

ppMetaEvent (ChannelPrefix a b)       = 
    event "channel-prefix" (hex2 a `sep` hex2 b)

ppMetaEvent (MidiPort w)              = event "midi-port" (hex2 w)

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 `sep` ppScale sc)

ppMetaEvent (SSME n ws)               = 
    event "sequencer-specific" (byteList n ws)

ppMetaEvent (MetaOther ty len ws)     =
    event "meta-other" (hex2 ty `sep` byteList len ws)

byteList :: (Show a, Integral a) => a -> [Word8] -> Doc 
byteList n ws | n < 10    = integral n `cat` mconcat (map hex2 ws)
              | otherwise = integral n `cat` repeatChar 10 '.'


textType :: MidiTextType -> 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 :: MidiScaleType -> Doc
ppScale (MAJOR)         = text "major"
ppScale (MINOR)         = text "minor"
ppScale (SCALE_OTHER i) = text "unrecognized scale" `sep` hex2 i


-- | This is a temporary hack - characters above ASCII 163
-- cause an (invalid character) error when written to stdout.
--
-- Make the string safe.
--
safeString :: String -> String
safeString = map (f . ord) 
  where
    f i | i < 164   = chr i
        | otherwise = '#'