-- |
-- 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
  (i -> IO ()) -> GrabSet i -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FrontEnd s i -> i -> IO ()
forall s i. FrontEnd s i -> i -> IO ()
frontUnsetGrab FrontEnd s i
f) (GrabSet i
before GrabSet i -> GrabSet i -> GrabSet i
forall a. Eq a => [a] -> [a] -> [a]
\\ GrabSet i
after)
  (i -> IO ()) -> GrabSet i -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FrontEnd s i -> i -> IO ()
forall s i. FrontEnd s i -> i -> IO ()
frontSetGrab FrontEnd s i
f) (GrabSet i
after GrabSet i -> GrabSet i -> GrabSet i
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 = Option s i -> Binding s i -> FrontEnd s i -> IO ()
forall i s.
Ord i =>
Option s i -> Binding s i -> FrontEnd s i -> IO ()
wildBind' Option s i
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 =
  (ReaderT (Option s i) IO () -> Option s i -> IO ())
-> Option s i -> ReaderT (Option s i) IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Option s i) IO () -> Option s i -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT Option s i
opt (ReaderT (Option s i) IO () -> IO ())
-> ReaderT (Option s i) IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (StateT (Binding s i, Maybe s) (ReaderT (Option s i) IO) ()
 -> (Binding s i, Maybe s) -> ReaderT (Option s i) IO ())
-> (Binding s i, Maybe s)
-> StateT (Binding s i, Maybe s) (ReaderT (Option s i) IO) ()
-> ReaderT (Option s i) IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Binding s i, Maybe s) (ReaderT (Option s i) IO) ()
-> (Binding s i, Maybe s) -> ReaderT (Option s i) IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (Binding s i
binding, Maybe s
forall a. Maybe a
Nothing) (StateT (Binding s i, Maybe s) (ReaderT (Option s i) IO) ()
 -> ReaderT (Option s i) IO ())
-> StateT (Binding s i, Maybe s) (ReaderT (Option s i) IO) ()
-> ReaderT (Option s i) IO ()
forall a b. (a -> b) -> a -> b
$ FrontEnd s i
-> StateT (Binding s i, Maybe s) (ReaderT (Option s i) IO) ()
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 = IO () -> [(i, ActionDescription)] -> IO ()
forall a b. a -> b -> a
const (IO () -> [(i, ActionDescription)] -> IO ())
-> IO () -> [(i, ActionDescription)] -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
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 = ReaderT (Option s i) IO (Option s i)
-> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i)
forall (m :: * -> *) a. Monad m => m a -> StateT (WBState s i) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Option s i) IO (Option s i)
 -> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i))
-> ReaderT (Option s i) IO (Option s i)
-> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i)
forall a b. (a -> b) -> a -> b
$ ReaderT (Option s i) IO (Option s i)
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 = ((i, Action IO (Binding s i)) -> (i, ActionDescription))
-> [(i, Action IO (Binding s i))] -> [(i, ActionDescription)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(i
i, Action IO (Binding s i)
act) -> (i
i, Action IO (Binding s i) -> ActionDescription
forall (m :: * -> *) a. Action m a -> ActionDescription
actDescription Action IO (Binding s i)
act)) ([(i, Action IO (Binding s i))] -> [(i, ActionDescription)])
-> [(i, Action IO (Binding s i))] -> [(i, ActionDescription)]
forall a b. (a -> b) -> a -> b
$ Binding s i -> s -> [(i, Action IO (Binding s i))]
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) <- StateT (WBState s i) (ReaderT (Option s i) IO) (WBState s i)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  let before_grabset :: [i]
before_grabset = [i] -> (s -> [i]) -> Maybe s -> [i]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Binding s i -> s -> [i]
forall s i. Binding s i -> s -> [i]
boundInputs Binding s i
before_binding) Maybe s
before_mstate
  WBState s i -> WBContext s i ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (WBState s i -> WBContext s i ())
-> WBState s i -> WBContext s i ()
forall a b. (a -> b) -> a -> b
$ (Binding s i
after_binding, s -> Maybe s
forall a. a -> Maybe a
Just s
after_state)
  IO () -> WBContext s i ()
forall a. IO a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WBContext s i ()) -> IO () -> WBContext s i ()
forall a b. (a -> b) -> a -> b
$ FrontEnd s i -> [i] -> [i] -> IO ()
forall i s. Eq i => FrontEnd s i -> GrabSet i -> GrabSet i -> IO ()
updateGrab FrontEnd s i
front [i]
before_grabset (Binding s i -> s -> [i]
forall s i. Binding s i -> s -> [i]
boundInputs Binding s i
after_binding s
after_state)
  [(i, ActionDescription)] -> IO ()
hook <- Option s i -> [(i, ActionDescription)] -> IO ()
forall s i. Option s i -> [(i, ActionDescription)] -> IO ()
optBindingHook (Option s i -> [(i, ActionDescription)] -> IO ())
-> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i)
-> StateT
     (WBState s i)
     (ReaderT (Option s i) IO)
     ([(i, ActionDescription)] -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i)
forall s i. WBContext s i (Option s i)
askOption
  IO () -> WBContext s i ()
forall a. IO a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WBContext s i ()) -> IO () -> WBContext s i ()
forall a b. (a -> b) -> a -> b
$ [(i, ActionDescription)] -> IO ()
hook ([(i, ActionDescription)] -> IO ())
-> [(i, ActionDescription)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Binding s i -> s -> [(i, ActionDescription)]
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
_) <- StateT (WBState s i) (ReaderT (Option s i) IO) (WBState s i)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  FrontEnd s i -> Binding s i -> s -> WBContext s i ()
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) <- StateT (WBState s i) (ReaderT (Option s i) IO) (WBState s i)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  case Maybe s
mstate of
    Maybe s
Nothing    -> () -> WBContext s i ()
forall a. a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just s
state -> FrontEnd s i -> Binding s i -> s -> WBContext s i ()
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 <- IO (FrontEvent s i)
-> StateT (WBState s i) (ReaderT (Option s i) IO) (FrontEvent s i)
forall a. IO a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FrontEvent s i)
 -> StateT (WBState s i) (ReaderT (Option s i) IO) (FrontEvent s i))
-> IO (FrontEvent s i)
-> StateT (WBState s i) (ReaderT (Option s i) IO) (FrontEvent s i)
forall a b. (a -> b) -> a -> b
$ FrontEnd s i -> IO (FrontEvent s i)
forall s i. FrontEnd s i -> IO (FrontEvent s i)
frontNextEvent FrontEnd s i
front
    case FrontEvent s i
event of
      FEChange s
state ->
        FrontEnd s i
-> s -> StateT (WBState s i) (ReaderT (Option s i) IO) ()
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) <- StateT (WBState s i) (ReaderT (Option s i) IO) (WBState s i)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
        case Binding s i -> Maybe s -> i -> Maybe (s, Action IO (Binding s i))
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 -> () -> StateT (WBState s i) (ReaderT (Option s i) IO) ()
forall a. a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
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 <- Binding s i
-> s
-> i
-> StateT
     (WBState s i)
     (ReaderT (Option s i) IO)
     (SomeException -> IO (Binding s i))
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 <- IO (Binding s i)
-> StateT (WBState s i) (ReaderT (Option s i) IO) (Binding s i)
forall a. IO a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Binding s i)
 -> StateT (WBState s i) (ReaderT (Option s i) IO) (Binding s i))
-> IO (Binding s i)
-> StateT (WBState s i) (ReaderT (Option s i) IO) (Binding s i)
forall a b. (a -> b) -> a -> b
$ Action IO (Binding s i) -> IO (Binding s i)
forall (m :: * -> *) a. Action m a -> m a
actDo Action IO (Binding s i)
action IO (Binding s i)
-> (SomeException -> IO (Binding s i)) -> IO (Binding s i)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (Binding s i)
handler
            FrontEnd s i
-> Binding s i -> StateT (WBState s i) (ReaderT (Option s i) IO) ()
forall i s. Eq i => FrontEnd s i -> Binding s i -> WBContext s i ()
updateBinding FrontEnd s i
front Binding s i
next_binding
    FrontEnd s i -> StateT (WBState s i) (ReaderT (Option s i) IO) ()
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 <- Binding a i -> a -> i -> Maybe (Action IO (Binding a i))
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
    (a, Action IO (Binding a i)) -> Maybe (a, Action IO (Binding a i))
forall a. a -> Maybe a
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 <- Option s i -> s -> i -> SomeException -> IO ()
forall s i. Option s i -> s -> i -> SomeException -> IO ()
optCatch (Option s i -> s -> i -> SomeException -> IO ())
-> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i)
-> StateT
     (WBState s i)
     (ReaderT (Option s i) IO)
     (s -> i -> SomeException -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (WBState s i) (ReaderT (Option s i) IO) (Option s i)
forall s i. WBContext s i (Option s i)
askOption
    (SomeException -> IO b)
-> StateT
     (WBState s i) (ReaderT (Option s i) IO) (SomeException -> IO b)
forall a. a -> StateT (WBState s i) (ReaderT (Option s i) IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((SomeException -> IO b)
 -> StateT
      (WBState s i) (ReaderT (Option s i) IO) (SomeException -> IO b))
-> (SomeException -> IO b)
-> StateT
     (WBState s i) (ReaderT (Option s i) IO) (SomeException -> IO b)
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
      s -> i -> SomeException -> IO ()
opt_catch s
state i
input SomeException
e
      b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
binding