diff --git a/alsa-gui.cabal b/alsa-gui.cabal --- a/alsa-gui.cabal +++ b/alsa-gui.cabal @@ -1,5 +1,5 @@ Name: alsa-gui -Version: 0.0 +Version: 0.0.1 Maintainer: Henning Thielemann Author: Henning Thielemann Category: Sound, Music, GUI @@ -25,11 +25,6 @@ type: darcs location: http://code.haskell.org/alsa/gui/ -Source-Repository this - type: darcs - location: http://code.haskell.org/alsa/gui/ - tag: 0.0 - Executable alsa-midi-mode Main-Is: mode.hs Other-Modules: Common @@ -37,6 +32,7 @@ GHC-Options: -Wall -threaded Build-Depends: wx >=0.12.1.6 && <0.13, + wxcore >=0.12.1.6 && <0.13, midi-alsa >=0.1.1 && <0.2, midi >=0.1.6 && <0.2, alsa-seq >=0.5.1 && <0.6, diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -7,8 +7,15 @@ import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Exception as AlsaExc -import Control.Monad (liftM2, ) +import Graphics.UI.WX (Prop((:=)), command, on, ) +import qualified Graphics.UI.WX as WX +import qualified Graphics.UI.WXCore as WXCore +import qualified Control.Concurrent.MVar as MVar +import Control.Concurrent (forkIO, ) + +import Control.Monad (liftM2, forever, ) + import qualified System.IO as IO @@ -44,9 +51,46 @@ withSequencer name act = flip AlsaExc.catch (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e) $ do - SndSeq.with SndSeq.defaultName SndSeq.Nonblock $ \h -> do + SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do Client.setName h name Port.withSimple h "inout" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) Port.typeApplication $ \ port -> do act $ Sequencer h port + + +-- | cf. http://snipplr.com/view/17538/ +myEventId :: Int +myEventId = WXCore.wxID_HIGHEST+1 -- the custom event ID + +-- | the custom event is registered as a menu event +createMyEvent :: IO (WXCore.CommandEvent ()) +createMyEvent = + WXCore.commandEventCreate WXCore.wxEVT_COMMAND_MENU_SELECTED myEventId + +registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO () +registerMyEvent win io = + WXCore.evtHandlerOnMenuCommand win myEventId io + + +reactOnEvent, reactOnEventTimer :: + SndSeq.AllowInput mode => + Int -> WX.Window a -> Sequencer mode -> + (Event.T -> IO ()) -> + IO () +reactOnEvent _interval frame (Sequencer h _) action = do + mvar <- MVar.newEmptyMVar + + _ <- forkIO $ forever $ do + MVar.putMVar mvar =<< Event.input h + WXCore.evtHandlerAddPendingEvent frame =<< createMyEvent + + registerMyEvent frame $ + MVar.takeMVar mvar >>= action + +-- naive implementation using a timer, requires Non-Blocking sequencer mode +reactOnEventTimer interval frame sequ action = + fmap (const ()) $ + WX.timer frame [ + WX.interval := interval, + on command := getWaitingEvents sequ >>= mapM_ action] diff --git a/src/controller.hs b/src/controller.hs --- a/src/controller.hs +++ b/src/controller.hs @@ -1,7 +1,3 @@ -{- -ToDo: - - avoid busy wait on ALSA events --} module Main where import Common @@ -12,12 +8,13 @@ import Graphics.UI.WX ((.+.), Prop((:=)), set, get, selection, command, on, button, close, container, hfloatCentre, widget, vfill, - layout, margin, column, row, select, spinCtrl, text, ) + layout, margin, select, spinCtrl, text, label, ) import qualified Graphics.UI.WX as WX import qualified Graphics.UI.WXCore as WXCore import Control.Monad (forM, forM_, when, ) +import qualified Data.List as List wxSL_INVERSE :: Int @@ -76,19 +73,26 @@ transferSelection command send val sval transferSelection select send sval val return $ Slider val sval ctrl chan - _ <- WX.timer f [ - WX.interval := 20, - on command := getWaitingEvents sequ >>= mapM_ (updateSliders sliders)] + reactOnEvent 20 f sequ (updateSliders sliders) quit <- button p [text := "Quit", on command := close f] let makeCol (Slider val sval ctrl chan) = - column 5 $ - vfill (widget val) : - widget sval : - widget ctrl : - widget chan : - [] + vfill (widget val) : + widget sval : + widget ctrl : + widget chan : + [] + labels = + map WX.valignCentre $ + WX.vglue : + label "Value" : + label "Controller" : + label "Channel" : + [] set f [layout := container p $ margin 10 $ - column 5 [row 5 (map makeCol sliders), hfloatCentre (widget quit)]] + WX.column 5 [ + WX.grid 5 5 $ List.transpose $ + labels : map makeCol sliders, + hfloatCentre (widget quit)]] sendCtrl :: Sequencer SndSeq.DuplexMode -> Int -> Int -> Int -> IO () diff --git a/src/mode.hs b/src/mode.hs --- a/src/mode.hs +++ b/src/mode.hs @@ -10,9 +10,9 @@ import qualified Sound.ALSA.Sequencer as SndSeq import Graphics.UI.WX - (Prop((:=)), set, get, selection, command, on, - button, close, container, hfloatCentre, widget, - layout, margin, column, spinCtrl, text, ) + (Prop((:=)), set, get, text, selection, command, on, + close, container, widget, + layout, margin, label, row, column, ) import qualified Graphics.UI.WX as WX @@ -21,9 +21,9 @@ makeGUI sequ = do f <- WX.frame [text := "MIDI Mode"] p <- WX.panel f [] - allNotesOff <- button p [text := "All Notes Off"] - allSoundOff <- button p [text := "All Sound Off"] - chan <- spinCtrl p 0 15 [] + allNotesOff <- WX.button p [text := "All Notes Off"] + allSoundOff <- WX.button p [text := "All Sound Off"] + chan <- WX.spinCtrl p 0 15 [] let getChan = fmap ChannelMsg.toChannel $ get chan selection set allNotesOff [ on command := getChan >>= @@ -33,13 +33,14 @@ on command := getChan >>= \c -> sendMode sequ c Mode.AllSoundOff ] - quit <- button p [text := "Quit", on command := close f] + quit <- WX.button p [text := "Quit", on command := close f] set f [layout := container p $ margin 10 $ - column 5 $ map hfloatCentre [ - widget allNotesOff, - widget allSoundOff, - widget chan, - widget quit]] + column 5 $ + WX.hfill (widget allNotesOff) : + WX.hfill (widget allSoundOff) : + (row 5 $ WX.valignCentre (label "Channel") : widget chan : []) : + WX.hfill (widget quit) : + []] sendMode :: Sequencer SndSeq.OutputMode -> ChannelMsg.Channel -> Mode.T -> IO () diff --git a/src/program.hs b/src/program.hs --- a/src/program.hs +++ b/src/program.hs @@ -1,7 +1,3 @@ -{- -ToDo: - - avoid busy wait on ALSA events --} module Main where import Common @@ -12,7 +8,7 @@ import Graphics.UI.WX (Prop((:=)), set, get, selection, command, on, button, close, container, hfloatCentre, widget, fill, - layout, margin, column, select, spinCtrl, text, ) + layout, margin, label, row, column, select, spinCtrl, text, ) import qualified Graphics.UI.WX as WX @@ -88,19 +84,15 @@ sendProgram sequ c pgm ] - _ <- - WX.timer f [ - WX.interval := 100, - on command := - getWaitingEvents sequ >>= - mapM_ (updateSelection chan list) - ] + reactOnEvent 100 f sequ (updateSelection chan list) quit <- button p [text := "Quit", on command := close f] set f [layout := container p $ margin 10 $ - column 5 [fill (widget list), - hfloatCentre (widget chan), - hfloatCentre (widget quit)]] + column 5 $ + fill (widget list) : + hfloatCentre (row 5 $ WX.valignCentre (label "Channel") : widget chan : []) : + hfloatCentre (widget quit) : + []] sendProgram :: Sequencer SndSeq.DuplexMode -> Int -> Int -> IO ()