-- |
-- Module: WildBind.Exec
-- Description: Functions to create executable actions.
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
module WildBind.Exec
    ( -- * Functions to build executable action
      wildBind
    , wildBind'
      -- * Option for executable
    , Option
    , defOption
      -- ** Accessor functions for 'Option'
    , 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)

-- | Combines the 'FrontEnd' and the 'Binding' and returns the executable.
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

-- | Build the executable with 'Option'.
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

-- | WildBind configuration options.
--
-- You can get the default value of 'Option' by 'defOption' funcion,
-- and modify its members via accessor functions listed below.
data Option s i
  = Option
      { forall s i. Option s i -> [(i, ActionDescription)] -> IO ()
optBindingHook :: [(i, ActionDescription)] -> IO ()
        -- ^ An action executed when current binding may be
        -- changed. Default: do nothing.
      , forall s i. Option s i -> s -> i -> SomeException -> IO ()
optCatch       :: s -> i -> SomeException -> IO ()
        -- ^ the handler for exceptions thrown from bound
        -- actions. Default: just print the 'SomeException' to
        -- 'stderr' and ignore it.
      }

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)
                   }

-- | Internal state. fst is the current Binding, snd is the current front-end state.
type WBState s i = (Binding s i, Maybe s)

-- | A monad keeping WildBind context.
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