module Event where
import Term
import ALSA ( Sequencer(handle, queue, privatePort), sendEvent )
import qualified Exception
import qualified Log
import qualified Sound.MIDI.Message.Channel as CM
import qualified Sound.MIDI.Message.Channel.Voice as VM
import qualified Sound.MIDI.ALSA as MidiAlsa
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Event as SeqEvent
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import Control.Monad.Exception.Synchronous ( ExceptionalT, throwT )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad ( when, forever )
import Control.Functor.HT ( void )
import qualified System.Process as Proc
import qualified System.Exit as Exit
import qualified System.IO.Strict as StrictIO
import qualified System.IO as IO
import qualified Data.Accessor.Monad.Trans.State as AccM
import qualified Data.Accessor.Tuple as AccTuple
import Data.Accessor.Basic ((^.), )
import Data.Maybe ( isJust )
import Data.Bool.HT ( if' )
import Control.Concurrent.Chan ( Chan, readChan, writeChan )
import Control.Concurrent ( forkIO {- threadDelay -} )
type Time = Integer
data WaitMode = RealTime | SlowMotion Time | SingleStep
deriving (Eq, Show)
data WaitResult =
ModeChange WaitMode | ReachedTime SeqEvent.TimeStamp | NextStep
deriving (Show)
termException ::
(Monad m) =>
String -> Term -> ExceptionalT Exception.Message m ()
termException msg s =
throwT $
Exception.Message Exception.Term
(termRange s) (msg ++ " " ++ show s)
runIO :: (MonadIO m) => IO () -> ExceptionalT Exception.Message m ()
runIO action = MT.lift $ liftIO action
{-
FIXME:
minBound for Velocity is zero.
This is not very helpful, because zero velocity is treated as NoteOff.
-}
withRangeCheck ::
(Bounded a, Monad m) =>
String -> (Int -> a) -> (a -> Int) ->
Term ->
(a -> ExceptionalT Exception.Message m ()) ->
ExceptionalT Exception.Message m ()
withRangeCheck typ fromInt0 toInt0 (Number rng x) =
let aux ::
(Monad m) =>
(Int -> a) -> (a -> Int) ->
a -> a ->
(a -> ExceptionalT Exception.Message m ()) ->
ExceptionalT Exception.Message m ()
aux fromInt toInt minb maxb f =
if' (x < fromIntegral (toInt minb))
(throwT $ Exception.Message Exception.Term rng $
typ ++ " argument " ++ show x ++
" is less than minimum value " ++ show (toInt minb)) $
if' (fromIntegral (toInt maxb) < x)
(throwT $ Exception.Message Exception.Term rng $
typ ++ " argument " ++ show x ++
" is greater than maximum value " ++ show (toInt maxb)) $
f (fromInt $ fromInteger x)
in aux fromInt0 toInt0 minBound maxBound
withRangeCheck typ _ _ t =
\ _f ->
throwT $
Exception.Message Exception.Term
(termRange t) (typ ++ " argument is not a number")
newtype ControllerValue = ControllerValue {fromControllerValue :: Int}
deriving (Eq, Ord, Show)
instance Bounded ControllerValue where
minBound = ControllerValue 0
maxBound = ControllerValue 127
type State = (WaitMode, Time)
play ::
(SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
Sequencer mode ->
Chan WaitResult ->
(Exception.Message -> IO ()) ->
Term ->
ExceptionalT Exception.Message (MS.StateT State IO) ()
play sq waitChan throwAsync x = case Term.viewNode x of
Just ("Wait", [Number _ n]) ->
-- threadDelay (fromIntegral n * 1000)
MT.lift $ wait sq waitChan $ Just (n * 10^(6::Int))
Just ( "Say", [String_Literal rng arg] ) -> runIO $ do
let cmd = unwords
[ "echo", show arg, "|", "festival", "--tts" ]
Log.put cmd
void $ forkIO $ do
(inp,_out,err,pid) <-
Proc.runInteractiveProcess
"festival" [ "--tts" ] Nothing Nothing
void $ forkIO (IO.hPutStr inp arg >> IO.hClose inp)
errText <- StrictIO.hGetContents err
exitCode <- Proc.waitForProcess pid
case exitCode of
Exit.ExitSuccess ->
when (not (null errText)) $
throwAsync $
Exception.Message Exception.Term rng ("warning: " ++ errText)
Exit.ExitFailure _ ->
throwAsync $
Exception.Message Exception.Term rng errText
Just ("Event", [event]) -> case Term.viewNode event of
Just ("Channel", [chann, body]) ->
withRangeCheck "channel" CM.toChannel CM.fromChannel chann $ \chan ->
processChannelMsg sq waitChan chan body
_ -> processChannelMsg sq waitChan (CM.toChannel 0) event
-- termException "Event must contain Channel, but not " x
_ -> termException "can only process Wait or Event, but not " x
processChannelMsg ::
(SndSeq.AllowOutput mode) =>
Sequencer mode ->
Chan WaitResult ->
CM.Channel -> Term ->
ExceptionalT Exception.Message (MS.StateT State IO) ()
processChannelMsg sq waitChan chan body = do
case Term.viewNode body of
Just ("On", [pn, vn]) ->
withRangeCheck "pitch" CM.toPitch CM.fromPitch pn $ \p ->
withRangeCheck "velocity" CM.toVelocity CM.fromVelocity vn $ \v ->
runIO $
sendNote sq SeqEvent.NoteOn chan p v
Just ("Off", [pn, vn]) ->
withRangeCheck "pitch" CM.toPitch CM.fromPitch pn $ \p ->
withRangeCheck "velocity" CM.toVelocity CM.fromVelocity vn $ \v ->
runIO $
sendNote sq SeqEvent.NoteOff chan p v
Just ("PgmChange", [pn]) ->
withRangeCheck "program" CM.toProgram CM.fromProgram pn $ \p ->
runIO $
sendEvent sq $ SeqEvent.CtrlEv SeqEvent.PgmChange $
MidiAlsa.programChangeEvent chan p
Just ("Controller", [ccn, vn]) ->
withRangeCheck "controller" CM.toController CM.fromController ccn $ \cc ->
withRangeCheck "controller value" ControllerValue fromControllerValue vn $ \(ControllerValue v) ->
runIO $
sendEvent sq $ SeqEvent.CtrlEv SeqEvent.Controller $
MidiAlsa.controllerEvent chan cc (fromIntegral v)
_ -> termException "invalid channel event: " body
MT.lift $ wait sq waitChan Nothing
wait ::
(SndSeq.AllowOutput mode) =>
Sequencer mode ->
Chan WaitResult ->
Maybe Time ->
MS.StateT State IO ()
wait sq waitChan mdur = do
let loop target = do
liftIO $ Log.put $ "readChan waitChan"
ev <- liftIO $ readChan waitChan
liftIO $ Log.put $ "read from waitChan: " ++ show ev
case ev of
ModeChange newMode -> do
oldMode <- MS.gets fst
if newMode /= oldMode
then do
AccM.set AccTuple.first newMode
(cont,newTarget) <- prepare sq mdur
when cont $ loop newTarget
else loop target
ReachedTime stamp ->
case stamp of
SeqEvent.RealTime rt ->
let reached = RealTime.toInteger rt
in if Just reached == target
then AccM.set AccTuple.second reached
else loop target
_ -> loop target
NextStep ->
when (isJust target) $ loop target
(cont,targetTime) <- prepare sq mdur
when cont $ loop targetTime
prepare ::
(SndSeq.AllowOutput mode) =>
Sequencer mode -> Maybe Time ->
MS.StateT State IO (Bool, Maybe Time)
prepare sq mt = do
liftIO $ Log.put $ "prepare waiting for " ++ show mt
(waitMode,currentTime) <- MS.get
case waitMode of
RealTime -> do
case mt of
Nothing -> return (False, Nothing)
Just dur -> do
let t = currentTime + dur
sendEcho sq t
return (True, Just t)
SlowMotion dur -> do
let t = currentTime + dur * 10^(6::Int)
sendEcho sq t
return (True, Just t)
SingleStep ->
return (True, Nothing)
sendEcho ::
(MonadIO io, SndSeq.AllowOutput mode) =>
Sequencer mode -> Time ->
io ()
sendEcho sq t = do
c <- liftIO $ Client.getId (handle sq)
{-
liftIO $ Log.put . ("wait, send echo for " ++) . show =<< MS.get
-}
let dest =
Addr.Cons {
Addr.client = c,
Addr.port = privatePort sq
}
liftIO $ Log.put $ "send echo message to " ++ show dest
liftIO $ void $ SeqEvent.output (handle sq) $
(SeqEvent.simple
(Addr.Cons c Port.unknown)
(SeqEvent.CustomEv SeqEvent.Echo (SeqEvent.Custom 0 0 0)))
{ SeqEvent.queue = queue sq
, SeqEvent.timestamp =
SeqEvent.RealTime $ RealTime.fromInteger t
, SeqEvent.dest = dest
}
liftIO $ void $ SeqEvent.drainOutput (handle sq)
{-
We cannot concurrently wait for different kinds of events.
Thus we run one thread that listens to all incoming events
and distributes them to who they might concern.
-}
listen ::
(SndSeq.AllowInput mode) =>
Sequencer mode ->
(VM.Pitch -> IO ()) ->
Chan WaitResult -> IO ()
listen sq noteInput waitChan = do
Log.put "listen to ALSA port"
c <- Client.getId (handle sq)
let dest =
Addr.Cons {
Addr.client = c,
Addr.port = privatePort sq
}
forever $ do
Log.put "wait, wait for echo"
ev <- SeqEvent.input (handle sq)
Log.put $ "wait, get message " ++ show ev
case SeqEvent.body ev of
SeqEvent.NoteEv SeqEvent.NoteOn note ->
noteInput $ note ^. MidiAlsa.notePitch
SeqEvent.CustomEv SeqEvent.Echo _ ->
when (dest == SeqEvent.dest ev) $ do
Log.put "write waitChan"
writeChan waitChan $ ReachedTime $ SeqEvent.timestamp ev
_ -> return ()
sendNote ::
(SndSeq.AllowOutput mode) =>
Sequencer mode ->
SeqEvent.NoteEv ->
CM.Channel ->
CM.Pitch ->
CM.Velocity ->
IO ()
sendNote sq onoff chan pitch velocity =
sendEvent sq $
SeqEvent.NoteEv onoff $ MidiAlsa.noteEvent chan pitch velocity velocity 0