module Render where

import qualified Midi

import qualified Sound.MIDI.File as MidiFile
import qualified Sound.MIDI.File.Event as FileEvent
import qualified Sound.MIDI.File.Save as Save
import qualified Sound.MIDI.File.Event.Meta as MetaEvent
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel       as ChannelMsg

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import Data.Monoid (mempty, mappend, )


class Message msg where
   makeMessage :: msg -> ChannelMsg.Body

class ChannelMessage msg where
   makeChannelMessage :: msg -> ChannelMsg.T

instance ChannelMessage Midi.Message where
   makeChannelMessage :: Message -> T
makeChannelMessage =
      Channel -> Body -> T
ChannelMsg.Cons (Int -> Channel
ChannelMsg.toChannel Int
0) (Body -> T) -> (Message -> Body) -> Message -> T
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Body
forall msg. Message msg => msg -> Body
makeMessage

instance Message Midi.Message where
   makeMessage :: Message -> Body
makeMessage Message
msg =
      T -> Body
ChannelMsg.Voice (T -> Body) -> T -> Body
forall a b. (a -> b) -> a -> b
$
      case Message
msg of
         Midi.On  Pitch
pitch Pitch
velocity ->
            Pitch -> Velocity -> T
VoiceMsg.NoteOn
               (Int -> Pitch
VoiceMsg.toPitch (Int -> Pitch) -> Int -> Pitch
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
pitch)
               (Int -> Velocity
VoiceMsg.toVelocity (Int -> Velocity) -> Int -> Velocity
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
velocity)
         Midi.Off Pitch
pitch Pitch
velocity ->
            Pitch -> Velocity -> T
VoiceMsg.NoteOff
               (Int -> Pitch
VoiceMsg.toPitch (Int -> Pitch) -> Int -> Pitch
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
pitch)
               (Int -> Velocity
VoiceMsg.toVelocity (Int -> Velocity) -> Int -> Velocity
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
velocity)
         Midi.PgmChange Pitch
pgm ->
            Program -> T
VoiceMsg.ProgramChange
               (Int -> Program
VoiceMsg.toProgram (Int -> Program) -> Int -> Program
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
pgm)
         Midi.Controller Pitch
ctrl Pitch
value ->
            T -> Int -> T
VoiceMsg.Control
               (Int -> T
VoiceMsg.toController (Int -> T) -> Int -> T
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
ctrl)
               (Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
value)

instance Message msg => ChannelMessage (Midi.Channel msg) where
   makeChannelMessage :: Channel msg -> T
makeChannelMessage (Midi.Channel Pitch
chan msg
msg) =
      Channel -> Body -> T
ChannelMsg.Cons (Int -> Channel
ChannelMsg.toChannel (Int -> Channel) -> Int -> Channel
forall a b. (a -> b) -> a -> b
$ Pitch -> Int
forall a. Num a => Pitch -> a
fromInteger Pitch
chan) (Body -> T) -> Body -> T
forall a b. (a -> b) -> a -> b
$
      msg -> Body
forall msg. Message msg => msg -> Body
makeMessage msg
msg


trackFromStream ::
   (ChannelMessage msg) => [Midi.Event msg] -> MidiFile.Track
trackFromStream :: forall msg. ChannelMessage msg => [Event msg] -> Track
trackFromStream [Event msg]
evs =
   (Event msg -> (T Pitch -> Track) -> T Pitch -> Track)
-> (T Pitch -> Track) -> [Event msg] -> T Pitch -> Track
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\Event msg
ev T Pitch -> Track
go T Pitch
time ->
         case Event msg
ev of
            Midi.Wait Pitch
pause ->
               T Pitch -> Track
go (T Pitch -> T Pitch -> T Pitch
forall a. Monoid a => a -> a -> a
mappend T Pitch
time (T Pitch -> T Pitch) -> T Pitch -> T Pitch
forall a b. (a -> b) -> a -> b
$
                   String -> Pitch -> T Pitch
forall a. (Ord a, Num a) => String -> a -> T a
NonNeg.fromNumberMsg String
"Render.trackFromStream: Wait" Pitch
pause)
            Midi.Say String
str ->
               T Pitch -> T -> Track -> Track
forall time body. time -> body -> T time body -> T time body
EventList.cons T Pitch
time (T -> T
FileEvent.MetaEvent (T -> T) -> T -> T
forall a b. (a -> b) -> a -> b
$ String -> T
MetaEvent.Lyric String
str) (Track -> Track) -> Track -> Track
forall a b. (a -> b) -> a -> b
$
               T Pitch -> Track
go T Pitch
0
            Midi.Event msg
msg ->
               T Pitch -> T -> Track -> Track
forall time body. time -> body -> T time body -> T time body
EventList.cons T Pitch
time (T -> T
FileEvent.MIDIEvent (T -> T) -> T -> T
forall a b. (a -> b) -> a -> b
$ msg -> T
forall msg. ChannelMessage msg => msg -> T
makeChannelMessage msg
msg) (Track -> Track) -> Track -> Track
forall a b. (a -> b) -> a -> b
$
               T Pitch -> Track
go T Pitch
0)
      (\ T Pitch
_time -> Track
forall time body. T time body
EventList.empty) [Event msg]
evs T Pitch
forall a. Monoid a => a
mempty

fileFromStream ::
   (ChannelMessage msg) => [Midi.Event msg] -> MidiFile.T
fileFromStream :: forall msg. ChannelMessage msg => [Event msg] -> T
fileFromStream =
   Type -> Division -> [Track] -> T
MidiFile.Cons Type
MidiFile.Mixed (Tempo -> Division
MidiFile.Ticks Tempo
500) ([Track] -> T) -> ([Event msg] -> [Track]) -> [Event msg] -> T
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Track -> [Track] -> [Track]
forall a. a -> [a] -> [a]
:[]) (Track -> [Track])
-> ([Event msg] -> Track) -> [Event msg] -> [Track]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- EventList.cons 0 (MetaEvent.SetTempo 500000) .
   [Event msg] -> Track
forall msg. ChannelMessage msg => [Event msg] -> Track
trackFromStream

writeStream ::
   (ChannelMessage msg) => FilePath -> [Midi.Event msg] -> IO ()
writeStream :: forall msg. ChannelMessage msg => String -> [Event msg] -> IO ()
writeStream String
path =
   String -> T -> IO ()
Save.toFile String
path (T -> IO ()) -> ([Event msg] -> T) -> [Event msg] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event msg] -> T
forall msg. ChannelMessage msg => [Event msg] -> T
fileFromStream