live-sequencer-0.0.6.1: src/Controller.hs

-- |  controllers are widgets that are:
-- * specified in the program text,
-- * displayed in the GUI,
-- * read while executing the program.

module Controller (
    Assignments,
    Event,
    create,
    changeControllerModule,
    ) where

import qualified ControllerBase as C
import qualified Program
import qualified Module
import qualified Rule
import qualified Term
import qualified Exception
import ControllerBase
          ( Name, deconsName, Assignments,
            Value (Bool, Number), Values (boolValues, numberValues) )
import Program (Program)
import SourceText ( ModuleRange, emptyModuleRange )

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Monad.Trans.Class as MT
import Control.Monad.IO.Class ( liftIO )

import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ
import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )
import Graphics.UI.WX.Classes ( text, checked, selection )
import Graphics.UI.WX.Events ( on, command, select )
import Graphics.UI.WX.Layout ( layout, container, row, column, widget )

import qualified Data.Map as Map

import Data.Foldable ( forM_ )
import Control.Functor.HT ( void )


data Event = Event Name Value
    deriving Show



moduleName :: Module.Name
moduleName = Module.Name "Controller"

defltIdent :: Term.Term ModuleRange
defltIdent = Term.variable moduleName "deflt"

changeControllerModule :: Program -> Event -> Exception.Monad Program
changeControllerModule p0 (Event name val) =
    fmap (\p -> p{Program.controlValues =
                     updateValue name val $ Program.controlValues p}) .
    flip Program.replaceModule p0 .
    Module.addRule ( controllerRule name val ) =<<
    ME.fromMaybe
        ( Exception.messageInOutEditor moduleName
            "cannot find module for controller updates" )
        ( Map.lookup moduleName $ Program.modules p0 )

updateValue :: Name -> Value -> Values -> Values
updateValue name val vals =
    case val of
        Bool b ->
            vals{boolValues = Map.insert name b $ boolValues vals}
        Number x ->
            vals{numberValues = Map.insert name x $ numberValues vals}


controllerRule :: Name -> Value -> Rule.Rule ModuleRange
controllerRule name val =
    case val of
        Bool b ->
            Rule.Rule
                ( Term.identifier moduleName "checkBox" )
                [ Term.StringLiteral
                      ( emptyModuleRange moduleName )
                      ( deconsName name ),
                  defltIdent ]
                ( Term.variable moduleName $ show b )
        Number x ->
            Rule.Rule
                ( Term.identifier moduleName "slider" )
                [ Term.StringLiteral
                      ( emptyModuleRange moduleName )
                      ( deconsName name ),
                  Term.variable moduleName "lower",
                  Term.variable moduleName "upper",
                  defltIdent ]
                ( Term.Number ( emptyModuleRange moduleName )
                      ( fromIntegral x ) )

create ::
    WX.Frame () ->
    Assignments ->
    (Event -> IO ()) ->
    IO ()
create frame controls sink = do
    size <- WX.get frame WX.outerSize
    void $ WXCMZ.windowDestroyChildren frame
    panel <- WX.panel frame []
    (cs,ss) <- MW.runWriterT $ MW.execWriterT $ forM_ (Map.toList controls) $
            \ ( name, (_rng, con) ) ->
        case con of
            C.CheckBox val -> do
                cb <- liftIO $ WX.checkBox panel
                   [ text := deconsName name , checked := val ]
                liftIO $ set cb
                   [ on command := do
                         c <- get cb checked
                         sink $ Event name $ Bool c
                   ]
                MW.tell [ widget cb ]
            C.Slider lower upper val -> do
                sl <- liftIO $ WX.hslider panel False lower upper
                   [ selection := val ]
                sp <- liftIO $ WX.spinCtrl panel lower upper
                   [ selection := val ]
                liftIO $ set sl
                   [ on command := do
                         c <- get sl selection
                         set sp [ selection := c ]
                         sink $ Event name $ Number c
                   ]
                liftIO $ set sp
                   [ on select := do
                         c <- get sp selection
                         set sl [ selection := c ]
                         sink $ Event name $ Number c
                   ]
                MT.lift $ MW.tell [
                   WX.row 5 [ WX.hfill $ widget sl , widget sp,
                              WX.label (deconsName name) ]
                   ]
    set frame [
        layout :=
            container panel $ column 5 $
            WX.hfloatCenter (row 5 cs) : ss,
        WX.outerSize := size
        ]