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