module WildBind.Exec
(
wildBind,
wildBind',
Option,
defOption,
optBindingHook,
optCatch
) where
import Control.Applicative ((<$>))
import Control.Exception (SomeException, catch)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.State as State
import Data.List ((\\))
import System.IO (hPutStrLn, stderr)
import WildBind.Description (ActionDescription)
import WildBind.FrontEnd
( FrontEvent(FEChange,FEInput),
FrontEnd(frontSetGrab, frontUnsetGrab, frontNextEvent)
)
import WildBind.Binding
( Action(actDo, actDescription),
Binding,
boundAction,
boundInputs,
boundActions
)
type GrabSet i = [i]
updateGrab :: (Eq i) => FrontEnd s i -> GrabSet i -> GrabSet i -> IO ()
updateGrab f before after = do
mapM_ (frontUnsetGrab f) (before \\ after)
mapM_ (frontSetGrab f) (after \\ before)
wildBind :: (Ord i) => Binding s i -> FrontEnd s i -> IO ()
wildBind = wildBind' defOption
wildBind' :: (Ord i) => Option s i -> Binding s i -> FrontEnd s i -> IO ()
wildBind' opt binding front =
flip Reader.runReaderT opt $ flip State.evalStateT (binding, Nothing) $ wildBindInContext front
data Option s i =
Option { optBindingHook :: [(i, ActionDescription)] -> IO (),
optCatch :: s -> i -> SomeException -> IO ()
}
defOption :: Option s i
defOption = Option { optBindingHook = const $ return (),
optCatch = \_ _ exception -> hPutStrLn stderr ("Exception from WildBind action: " ++ show exception)
}
type WBState s i = (Binding s i, Maybe s)
type WBContext s i = State.StateT (WBState s i) (Reader.ReaderT (Option s i) IO)
askOption :: WBContext s i (Option s i)
askOption = lift $ Reader.ask
boundDescriptions :: Binding s i -> s -> [(i, ActionDescription)]
boundDescriptions b s = fmap (\(i, act) -> (i, actDescription act)) $ boundActions b s
updateWBState :: (Eq i) => FrontEnd s i -> Binding s i -> s -> WBContext s i ()
updateWBState front after_binding after_state = do
(before_binding, before_mstate) <- State.get
let before_grabset = maybe [] (boundInputs before_binding) before_mstate
State.put $ (after_binding, Just after_state)
liftIO $ updateGrab front before_grabset (boundInputs after_binding after_state)
hook <- optBindingHook <$> askOption
liftIO $ hook $ boundDescriptions after_binding after_state
updateFrontState :: (Eq i) => FrontEnd s i -> s -> WBContext s i ()
updateFrontState front after_state = do
(cur_binding, _) <- State.get
updateWBState front cur_binding after_state
updateBinding :: (Eq i) => FrontEnd s i -> Binding s i -> WBContext s i ()
updateBinding front after_binding = do
(_, mstate) <- State.get
case mstate of
Nothing -> return ()
Just state -> updateWBState front after_binding state
wildBindInContext :: (Ord i) => FrontEnd s i -> WBContext s i ()
wildBindInContext front = impl where
impl = do
event <- liftIO $ frontNextEvent front
case event of
FEChange state ->
updateFrontState front state
FEInput input -> do
(cur_binding, mcur_state) <- State.get
case stateAndAction cur_binding mcur_state input of
Nothing -> return ()
Just (cur_state, action) -> do
handler <- getExceptionHandler cur_binding cur_state input
next_binding <- liftIO $ actDo action `catch` handler
updateBinding front next_binding
wildBindInContext front
stateAndAction binding mstate input = do
state <- mstate
action <- boundAction binding state input
return (state, action)
getExceptionHandler binding state input = do
opt_catch <- optCatch <$> askOption
return $ \e -> do
opt_catch state input e
return binding