{-# 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.
--
--------------------------------------------------------------------------------


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 :: (Show a, 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"