wild-bind 0.1.0.3 → 0.1.1.0

raw patch · 12 files changed

+712/−66 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• src/WildBind.hs +9/−1
• src/WildBind/Binding.hs +138/−31
• src/WildBind/Description.hs +4/−0
• src/WildBind/FrontEnd.hs +1/−1
• src/WildBind/Input/NumPad.hs +1/−0
• src/WildBind/Seq.hs +121/−0
• test/WildBind/BindingSpec.hs +151/−23
• test/WildBind/ExecSpec.hs +2/−1
• test/WildBind/ForTest.hs +74/−2
• test/WildBind/SeqSpec.hs +193/−0
• wild-bind.cabal +7/−7

@@ -1,5 +1,16 @@ # Revision history for wild-bind +## 0.1.1.0  -- 2018-01-01++* Description: add `Describable` instance of `Either`.+* Binding: add some functions: +  `bindsF`, `bindsF'`, `bindingF`, `bindingF'`, `revise`, `revise'`,+  `justBefore`, `justAfter`+* FrontEnd: derive `Eq` and `Ord` for `FrontEvent`.+* Add `WildBind.Seq` module.+* .cabal: use `other-extensions` instead of `default-extensions`.++ ## 0.1.0.3  -- 2017-01-24  * Confirmed build with `hspec-2.4.0`.

@@ -19,9 +19,17 @@                    module WildBind.Description,          -- | Defines 'ActionDescription'.-         +          module WildBind.Input.NumPad          -- | Defines input symbol types for number pad keys.++-- * Support modules+--+-- +-- | The following modules are not re-exported from this module.+--+-- - "WildBind.Seq": support module to build a binding to key+--   sequences. /Since: 0.1.1.0/        ) where  

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, OverloadedStrings #-} -- | -- Module: WildBind.Binding -- Description: Functions to build Binding@@ -24,11 +24,15 @@          Binder,          binds,          binds',+         bindsF,+         bindsF',          on,          run,          as,          binding,          binding',+         bindingF,+         bindingF',                    -- * Condition          @@ -45,14 +49,21 @@          whenBack,          whenBoth,          -- * Conversion-         advice,-         before,-         after,+         -- ** Stateful bindings          startFrom,          extend,+         -- ** Type conversion          convFront,          convInput,          convBack,+         -- ** Action conversion+         advice,+         revise,+         revise',+         before,+         after,+         justBefore,+         justAfter,          -- * Execution          boundAction,          boundAction',@@ -63,7 +74,9 @@        ) where  import Control.Applicative (Applicative, (<*), (*>))-import Control.Monad.Trans.State (StateT, runStateT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT(..), withReaderT)+import Control.Monad.Trans.State (StateT(..), runStateT, mapStateT) import Control.Monad.Trans.Writer (Writer, tell, execWriter, mapWriter) import qualified Data.Map as M import Data.Monoid (Monoid(..), Endo(Endo, appEndo))@@ -99,6 +112,21 @@       -> Action m a after hook act = act { actDo = actDo act <* hook } +-- | Same as 'before', but it returns 'Just'.+--+-- @since 0.1.1.0+justBefore :: (Applicative m) => m b -> Action m a -> Maybe (Action m a)+justBefore m a = Just $ before m a++-- | Same as 'after', but it returns 'Just'.+--+-- @since 0.1.1.0+justAfter :: (Applicative m) => m b -> Action m a -> Maybe (Action m a)+justAfter m a = Just $ after m a++-- | State/Reader/IO Monad+type SRIM bs fs = StateT bs (ReaderT fs IO)+ -- | WildBind back-end binding with both explicit and implicit -- states. @bs@ is the explicit back-end state, @fs@ is the front-end -- state, and @i@ is the input type.@@ -107,9 +135,27 @@ -- function. newtype Binding' bs fs i =   Binding'-  { unBinding' :: bs -> fs -> M.Map i (Action IO (Binding' bs fs i, bs))+  { unBinding' :: bs -> fs -> M.Map i (Action (SRIM bs fs) (Binding' bs fs i))   } +runSRIM :: bs -> fs -> SRIM bs fs a -> IO (a, bs)+runSRIM bs fs m = flip runReaderT fs $ flip runStateT bs m++redoSRIM :: IO (a, bs) -> SRIM bs fs a+redoSRIM m = StateT $ const $ lift m++mapActDo :: (m a -> n b) -> Action m a -> Action n b+mapActDo f act = act { actDo = f $ actDo act }++mapActResult :: Functor m => (a -> b) -> M.Map i (Action m a) -> M.Map i (Action m b)+mapActResult = fmap . fmap++liftActionR :: Monad m => Action m a -> Action (ReaderT fs m) a+liftActionR = mapActDo lift++withActionR :: (fs -> fs') -> Action (SRIM bs fs') a -> Action (SRIM bs fs) a+withActionR f = (mapActDo . mapStateT) (withReaderT f)+ -- | WildBind back-end binding between inputs and actions. @s@ is the -- front-end state type, and @i@ is the input type. type Binding s i = Binding' () s i@@ -123,8 +169,8 @@ instance Ord i => Monoid (Binding' bs fs i) where   mempty = noBinding   mappend abind bbind = Binding' $ \bs fs ->-    let amap = mapResult (`mappend` bbind) id $ unBinding' abind bs fs-        bmap = mapResult (abind `mappend`) id $ unBinding' bbind bs fs+    let amap = mapActResult (`mappend` bbind) $ unBinding' abind bs fs+        bmap = mapActResult (abind `mappend`) $ unBinding' bbind bs fs     in M.unionWith (\_ b -> b) amap bmap  -- | A 'Binding'' with no bindings. It's the same as 'mempty', except@@ -139,7 +185,7 @@ -- | Get the 'Action' bound to the specified back-end state @bs@, -- front-end state @fs@ and input @i@ boundAction' :: (Ord i) => Binding' bs fs i -> bs -> fs -> i -> Maybe (Action IO (Binding' bs fs i, bs))-boundAction' b bs fs input = M.lookup input $ unBinding' b bs fs+boundAction' b bs fs input = (fmap . mapActDo) (runSRIM bs fs) $ M.lookup input $ unBinding' b bs fs  -- | Get the list of all bound inputs @i@ and their corresponding -- actions for the specified front-end state @s@.@@ -150,7 +196,9 @@ -- actions for the specified back-end state @bs@ and front-end state -- @fs@. boundActions' :: Binding' bs fs i -> bs -> fs -> [(i, Action IO (Binding' bs fs i, bs))]-boundActions' b bs fs = M.toList $ unBinding' b bs fs+boundActions' b bs fs = map convertAction $ M.toList $ unBinding' b bs fs+  where+    convertAction (i, act) = (i, mapActDo (runSRIM bs fs) act)  -- | Get the list of all bound inputs @i@ for the specified front-end -- state @s@.@@ -182,12 +230,26 @@ binds :: Ord i => Binder i (Action IO r) a -> Binding' bs fs i binds = binding . flip runBinder [] +-- | Like 'binds', but this function allows actions to use the current+-- front-end state via 'ReaderT'.+--+-- @since 0.1.1.0+bindsF :: Ord i => Binder i (Action (ReaderT fs IO) r) a -> Binding' bs fs i+bindsF = bindingF . flip runBinder []+ -- | Build a 'Binding'' with an explicit state (but no implicit -- state). The bound actions are activated regardless of the back-end -- or front-end state. binds' :: Ord i => Binder i (Action (StateT bs IO) r) a -> Binding' bs fs i binds' = binding' . flip runBinder [] +-- | Like 'binds'', but this function allows actions to use the+-- current front-end state via 'ReaderT'.+--+-- @since 0.1.1.0+bindsF' :: Ord i => Binder i (Action (StateT bs (ReaderT fs IO)) r) a -> Binding' bs fs i+bindsF' = bindingF' . flip runBinder []+ -- | Create a 'Binder' that binds the action @v@ to the input @i@. on :: i -> v -> Binder i v () on i v = Binder $ tell $ Endo ((i,v) :)@@ -215,12 +277,20 @@   f_endo (Endo prepender) = Endo ((map f_pair $ prepender []) ++)   f_pair (i, v) = (i, f v) +statelessBinding :: M.Map i (Action (ReaderT fs IO) r) -> Binding' bs fs i+statelessBinding bind_map = impl where+  impl = Binding' $ \_ _ -> (fmap . mapActDo) lift $ mapActResult (const impl) $ bind_map  -- | Non-monadic version of 'binds'. binding :: Ord i => [(i, Action IO r)] -> Binding' bs fs i-binding blist = impl where-  impl = Binding' $ \bs _ -> (fmap . fmap) (const (impl, bs)) $ M.fromList blist+binding = statelessBinding . fmap liftActionR . M.fromList +-- | Non-monadic version of 'bindsF'.+--+-- @since 0.1.1.0+bindingF :: Ord i => [(i, Action (ReaderT fs IO) r)] -> Binding' bs fs i+bindingF = statelessBinding . M.fromList+ -- | Create a binding that behaves differently for different front-end -- states @fs@. ifFront :: (fs -> Bool) -- ^ The predicate@@ -245,8 +315,8 @@        -> Binding' bs fs i ifBoth p thenb elseb = Binding' $ \bs fs ->   if p bs fs-  then mapResult (\nextb -> ifBoth p nextb elseb) id $ unBinding' thenb bs fs-  else mapResult (\nextb -> ifBoth p thenb nextb) id $ unBinding' elseb bs fs+  then mapActResult (\nextb -> ifBoth p nextb elseb) $ unBinding' thenb bs fs+  else mapActResult (\nextb -> ifBoth p thenb nextb) $ unBinding' elseb bs fs  -- | Add a condition on the front-end state to 'Binding'. whenFront :: (fs -> Bool) -- ^ The predicate.@@ -267,18 +337,15 @@          -> Binding' bs fs i whenBoth p b = ifBoth p b noBinding -mapResult :: Functor m => (a -> a') -> (b -> b') -> M.Map i (Action m (a, b)) -> M.Map i (Action m (a',b'))-mapResult amapper bmapper = (fmap . fmap) (\(a, b) -> (amapper a, bmapper b))- -- | Contramap the front-end state. convFront :: (fs -> fs') -> Binding' bs fs' i -> Binding' bs fs i convFront cmapper orig_bind = Binding' $ \bs fs ->-  mapResult (convFront cmapper) id $ unBinding' orig_bind bs (cmapper fs)+  mapActResult (convFront cmapper) $ fmap (withActionR cmapper) $ unBinding' orig_bind bs (cmapper fs)  -- | Map the front-end input. convInput :: Ord i' => (i -> i') -> Binding' bs fs i -> Binding' bs fs i' convInput mapper orig_bind = Binding' $ \bs fs ->-  mapResult (convInput mapper) id $ M.mapKeys mapper $ unBinding' orig_bind bs fs+  mapActResult (convInput mapper) $ M.mapKeys mapper $ unBinding' orig_bind bs fs  -- | Convert the back-end state. Intuitively, it converts a small -- state type @bs@ into a bigger state type @bs'@, which includes@@ -295,7 +362,10 @@          -> Binding' bs fs i          -> Binding' bs' fs i convBack setter getter orig_bind = Binding' $ \bs' fs ->-  mapResult (convBack setter getter) (\bs -> setter bs bs') $ unBinding' orig_bind (getter bs') fs+  (fmap . mapActDo) convState $ unBinding' orig_bind (getter bs') fs+  where+    convState ms = StateT $ \bs' -> fmap (convResult bs') $ runStateT ms $ getter bs'+    convResult bs' (next_b, bs) = (convBack setter getter next_b, setter bs bs')  -- | Convert 'Binding'' to 'Binding' by hiding the explicit state -- @bs@.@@ -303,10 +373,15 @@           -> Binding' bs fs i -- ^ Binding' with explicit state           -> Binding fs i -- ^ Binding containing the state inside startFrom init_state b' = Binding' $ \() front_state ->-  (fmap . fmap) toB $ unBinding' b' init_state front_state+  mapActResult toB $ (fmap . mapActDo) (startSRIM init_state) $ unBinding' b' init_state front_state   where-    toB (next_b', next_state) = (startFrom next_state next_b', ())+    toB (next_b', next_state) = startFrom next_state next_b' +startSRIM :: bs -> SRIM bs fs a -> SRIM () fs (a, bs)+startSRIM bs m = StateT $ \() -> fmap toState $ runStateT m bs+  where+    toState (a, result_bs) = ((a, result_bs), ())+ -- | Extend 'Binding' to 'Binding''. In the result 'Binding'', the -- explicit back-end state is just ignored and unmodified. extend :: Binding fs i -> Binding' bs fs i@@ -314,13 +389,45 @@  -- | Non-monadic version of 'binds''. binding' :: Ord i => [(i, Action (StateT bs IO) r)] -> Binding' bs fs i-binding' blists = impl where-  impl = Binding' $ \bs _ -> fmap (runStatefulAction impl bs) $ M.fromList $ blists+binding' = statefulBinding . fmap addR . M.fromList where+  addR = mapActDo $ mapStateT lift -runStatefulAction :: Binding' bs fs i -> bs -> Action (StateT bs IO) r -> Action IO (Binding' bs fs i, bs)-runStatefulAction next_b' cur_bs state_action =-  state_action { actDo = recursive_io }-  where-  recursive_io = do-    (_, next_bs) <- runStateT (actDo state_action) cur_bs-    return (next_b', next_bs)+-- | Non-monadic version of 'bindsF''.+--+-- @since 0.1.1.0+bindingF' :: Ord i => [(i, Action (StateT bs (ReaderT fs IO)) r)] -> Binding' bs fs i+bindingF' = statefulBinding . M.fromList++statefulBinding :: M.Map i (Action (SRIM bs fs) r) -> Binding' bs fs i+statefulBinding bind_map = impl where+  impl = Binding' $ \_ _ -> mapActResult (const impl) bind_map++-- | Revise (modify) actions in the given 'Binding''.+--+-- @since 0.1.1.0+revise :: (forall a . bs -> fs -> i -> Action IO a -> Maybe (Action IO a))+       -- ^ A function to revise the action. If it returns 'Nothing',+       -- the action is unbound.+       -> Binding' bs fs i+       -- ^ original binding+       -> Binding' bs fs i+       -- ^ revised binding+revise f = reviseThis where+  reviseThis (Binding' orig) = Binding' $ \bs fs -> M.mapMaybeWithKey (f_to_map bs fs) (orig bs fs)+  f_to_map bs fs i orig_act = fmap convertResult $ f bs fs i $ mapActDo (runSRIM bs fs) orig_act+  convertResult = fmap reviseThis . mapActDo redoSRIM++-- | Like 'revise', but this function allows revising the back-end state.+--+-- @since 0.1.1.0+revise' :: (forall a . bs -> fs -> i -> Action (StateT bs IO) a -> Maybe (Action (StateT bs IO) a))+        -> Binding' bs fs i+        -> Binding' bs fs i+revise' f = reviseThis where+  reviseThis (Binding' orig) = Binding' $ \bs fs -> M.mapMaybeWithKey (f_to_map bs fs) (orig bs fs)+  f_to_map bs fs i orig_act = fmap convertResult $ f bs fs i $ mapActDo (runR fs) orig_act+  runR :: fs -> SRIM bs fs a -> StateT bs IO a+  runR fs m = mapStateT (flip runReaderT fs) m+  convertResult = fmap reviseThis . mapActDo toSRIM+  toSRIM :: StateT bs IO a -> SRIM bs fs a+  toSRIM m = mapStateT lift m

@@ -17,3 +17,7 @@ -- | Class for something describable. class Describable d where   describe :: d -> ActionDescription++-- | @since 0.1.1.0+instance (Describable a, Describable b) => Describable (Either a b) where+  describe = either describe describe

@@ -17,7 +17,7 @@ -- | Event from the front-end. @s@ is the state of the front-end. @i@ is the input. data FrontEvent s i = FEInput i -- ^ An event that a new input is made.                     | FEChange s  -- ^ An event that the front-end state is changed.-                    deriving (Show)+                    deriving (Show,Eq,Ord)  -- | Interface to the front-end. @s@ is the state of the front-end, -- @i@ is the input.

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: WildBind.Input.NumPad -- Description: Types about number pads

@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings, RankNTypes #-}+-- |+-- Module: WildBind.Seq+-- Description: Support for binding sequence of input events.+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- This module defines convenient functions to build 'Binding's that+-- bind actions to key sequences.+--+-- For example, see+-- [WildBind.Task.X11.Seq.Example in wild-bind-task-x11](https://hackage.haskell.org/package/wild-bind-task-x11/docs/WildBind-Task-X11-Seq-Example.html) package.+--+-- @since 0.1.1.0+--+    +module WildBind.Seq+       ( -- * Simple API+         prefix,+         -- * Advanced API+         SeqBinding,+         toSeq,+         fromSeq,+         withPrefix,+         withCancel,+         reviseSeq+       ) where++import Control.Monad.Trans.State (State)+import qualified Control.Monad.Trans.State as State+import Data.Monoid (Monoid(..), (<>), mconcat)++import WildBind.Binding+  ( Binding, Binding', binds', whenBack, on, as, run, extend,+    startFrom, revise', justBefore, revise,+    Action+  )++-- | Intermediate type of building a 'Binding' for key sequences.+newtype SeqBinding fs i = SeqBinding ([i] -> Binding' [i] fs i)++-- | Follows the same rule as 'Binding'.+instance Ord i => Monoid (SeqBinding fs i) where+  mempty = SeqBinding $ const mempty+  mappend (SeqBinding a) (SeqBinding b) =+    SeqBinding $ \ps -> mappend (a ps) (b ps)++-- | Prepend prefix keys to the 'SeqBinding'.+--+-- 'SeqBinding' is composable in terms of prefixes, that is,+--+-- > (withPrefix [key1, key2] seq_b) == (withPrefix [key1] $ withPrefix [key2] seq_b)+withPrefix :: Ord i+           => [i] -- ^ prefix keys+           -> SeqBinding fs i+           -> SeqBinding fs i+withPrefix ps sb = foldr withPrefixSingle sb ps++withPrefixSingle :: Ord i => i -> SeqBinding fs i -> SeqBinding fs i+withPrefixSingle p (SeqBinding fb) = +  SeqBinding $ \cur_prefix -> nextBinding cur_prefix <> prefixBinding cur_prefix+  where+    prefixBinding cur_prefix = whenBack (== cur_prefix) $ binds' $ do+      on p `as` "prefix" `run` State.modify (++ [p])+    nextBinding cur_prefix = fb (cur_prefix ++ [p])++-- | Create a 'SeqBinding' from 'Binding'. The result 'SeqBinding' has+-- no prefixes yet.+toSeq :: Eq i => Binding fs i -> SeqBinding fs i+toSeq b = SeqBinding $ \ps -> whenBack (== ps) $ revise' cancelBefore $ extend b+  where+    cancelBefore _ _ _ = justBefore $ State.put []++-- | Resolve 'SeqBinding' to build a 'Binding' for key sequences.+fromSeq :: SeqBinding fs i -> Binding fs i+fromSeq (SeqBinding fb) = startFrom [] $ fb []++-- | A 'SeqBinding' that binds the given key for canceling the key+-- sequence.+cancelOn :: Ord i+         => i -- ^ cancel key+         -> SeqBinding fs i+cancelOn c = SeqBinding $ const $ whenBack (not . null) $ binds' $ on c `as` "cancel" `run` State.put []++-- | Add cancel keys to the 'SeqBinding'.+withCancel :: Ord i+           => [i] -- ^ cancel keys+           -> SeqBinding fs i+           -> SeqBinding fs i+withCancel cs sb = cancelBindings <> sb+  where+    cancelBindings = mconcat $ map cancelOn cs++-- | Prepend prefix keys to a 'Binding'. In the result 'Binding', the+-- original 'Binding' is enabled only after you input the prefix input+-- symbols in the same order.+--+-- During typing prefix keys, you can cancel and reset the key+-- sequence by typing the \"cancel keys\". This is analogous to @C-g@+-- in Emacs. The binding of cancel keys are weak, that is, they are+-- overridden by the original binding and prefix keys.+--+-- Note that this function creates an independent implicit state to+-- memorize prefix keys input so far. This means,+--+-- > (prefix [] [key1, key2] b) /= (prefix [] [key1] $ prefix [] [key2] b)+--+-- If you want a more composable way of building a sequence binding,+-- try 'SeqBinding'.+prefix :: Ord i+       => [i] -- ^ The cancel keys (input symbols for canceling the current key sequence.)+       -> [i] -- ^ list of prefix input symbols+       -> Binding fs i -- ^ the original binding.+       -> Binding fs i -- ^ the result binding.+prefix cs ps = fromSeq . withCancel cs . withPrefix ps . toSeq++-- | Revise actions in 'SeqBinding'. See 'WildBind.Binding.revise'.+reviseSeq :: (forall a . [i] -> fs -> i -> Action IO a -> Maybe (Action IO a))+             -- ^ Revising function. @[i]@ is the prefix keys input so far.+          -> SeqBinding fs i+          -> SeqBinding fs i+reviseSeq f (SeqBinding orig) = SeqBinding $ fmap (revise f) orig

@@ -1,20 +1,26 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, OverloadedStrings #-} module WildBind.BindingSpec (main, spec) where  import Control.Applicative ((<$>), (<*>), pure)-import Control.Monad (void, join)+import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, 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.Maybe (isNothing, fromJust)-import Data.Monoid (mempty, (<>))+import Data.Monoid (mempty, (<>), mconcat) import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) import qualified Lens.Micro as Lens import Test.Hspec import Test.QuickCheck (Gen, Arbitrary(arbitrary), property, listOf, sample')  import qualified WildBind.Binding as WB-import WildBind.ForTest (SampleInput(..), SampleState(..), SampleBackState(..))+import WildBind.ForTest+  ( SampleInput(..), SampleState(..), SampleBackState(..),+    inputAll, execAll, evalStateEmpty, boundDescs, boundDescs',+    checkBoundDescs,+    withRefChecker+  )  main :: IO () main = hspec spec@@ -36,10 +42,7 @@ newStrRef = liftIO $ newIORef []  withStrRef :: MonadIO m => (IORef String -> (String -> m ()) -> m ()) -> m ()-withStrRef action = do-  out <- newStrRef-  let checkOut exp_str = liftIO $ readIORef out `shouldReturn` exp_str-  action out checkOut+withStrRef = withRefChecker []  outOn :: MonadIO m => IORef [a] -> i -> a -> (i, WB.Action m ()) outOn out_ref input out_elem = (input, WB.Action "" $ liftIO $ modifyIORef out_ref (++ [out_elem]))@@ -60,18 +63,6 @@ generate :: Gen a -> IO a generate = fmap head . sample' -inputAll :: Ord i => WB.Binding s i -> s -> [i] -> IO (WB.Binding s i)-inputAll b _ [] = return b-inputAll binding state (i:rest) = case WB.boundAction binding state i of-  Nothing -> inputAll binding state rest-  Just act -> join $ inputAll <$> WB.actDo act <*> return state <*> return rest--execAll :: Ord i => s -> [i] -> State.StateT (WB.Binding s i) IO ()-execAll state inputs = do-  b <- State.get-  next_b <- liftIO $ inputAll b state inputs-  State.put next_b- execAll' :: Ord i => [i] -> State.StateT (WB.Binding SampleState i) IO () execAll' = execAll (SS "") @@ -98,9 +89,6 @@ checkInputsS' :: (Show i, Eq i) => [i] -> State.StateT (WB.Binding SampleState i) IO () checkInputsS' = checkInputsS (SS "") -evalStateEmpty :: State.StateT (WB.Binding SampleState SampleInput) IO () -> IO ()-evalStateEmpty s = State.evalStateT s mempty_stateless- spec :: Spec spec = do   spec_stateless@@ -110,6 +98,8 @@   spec_extend   spec_conditionBoth   spec_monadic+  spec_reader+  spec_revise  spec_stateless :: Spec spec_stateless = do@@ -648,3 +638,141 @@       (WB.actDescription <$> WB.boundAction b (SS "") SIb) `shouldBe` Just "action for b"       (WB.actDescription <$> WB.boundAction b (SS "") SIc) `shouldBe` Nothing +spec_reader :: Spec+spec_reader = describe "binding with ReaderT action" $ do+  describe "bindsF" $ do+    it "allows actions to access front-end state" $ withStrRef $ \out checkOut -> do+      let b = WB.bindsF $ do+            WB.on SIa `WB.run` do+              fs <- Reader.ask+              liftIO $ modifyIORef out (++ unSS fs)+      actRun $ WB.boundAction b (SS "hoge") SIa+      checkOut "hoge"+      actRun $ WB.boundAction b (SS "_foobar") SIa+      checkOut "hoge_foobar"+  describe "bindsF'" $ do+    it "allows stateful actions to access front-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+      let ba = WB.bindsF' $ do+            WB.on SIa `WB.run` do+              (SB bs) <- State.get+              (SS fs) <- lift $ Reader.ask+              if bs >= 0+                then liftIO $ modifyIORef out (++ fs)+                else liftIO $ modifyIORef out (++ reverse fs)+          bb = WB.binds' $ do+            WB.on SIb `WB.run` State.modify (\(SB bs) -> SB (bs + 1))+          bc = WB.binds' $ do+            WB.on SIc `WB.run` State.modify (\(SB bs) -> SB (bs - 1))+          b = WB.startFrom (SB 0) (bb <> ba <> bc)+      State.put b+      execAll (SS "abc") [SIa, SIb, SIb]+      checkOut "abc"+      execAll (SS "123") [SIc, SIc, SIc, SIc, SIa]+      checkOut "abc321"+      execAll (SS "xyz") [SIa, SIb, SIb, SIa]+      checkOut "abc321zyxxyz"++spec_revise :: Spec+spec_revise = do+  describe "revise" $ do+    it "should allow unbinding" $ do+      let b = WB.binds $ do+            WB.on SIa `WB.as` "a" `WB.run` return ()+            WB.on SIb `WB.as` "b" `WB.run` return ()+          rev () _ i act = if i == SIa then Nothing else Just act+          got = WB.revise rev b+      boundDescs got (SS "")  `shouldMatchList` [(SIb, "b")]+    it "should allow revising description" $ do+      let b = WB.binds $ do+            WB.on SIa `WB.as` "a" `WB.run` return ()+            WB.on SIb `WB.as` "b" `WB.run` return ()+          rev () _ _ act = Just $ act { WB.actDescription = mconcat $ replicate 3 $ WB.actDescription act }+          got = WB.revise rev b+      boundDescs got (SS "") `shouldMatchList` [(SIa, "aaa"), (SIb, "bbb")]+    it "should revise conditionally on front-end state" $ do+      let b = WB.binds $ do+            WB.on SIa `WB.as` "a" `WB.run` return ()+            WB.on SIb `WB.as` "b" `WB.run` return ()+          rev () (SS fs) i act = if i == SIa && length fs >= 3+                                 then Nothing else Just act+          got = WB.revise rev b+      boundDescs got (SS "")  `shouldMatchList` [(SIa, "a"), (SIb, "b")]+      boundDescs got (SS "xx") `shouldMatchList` [(SIa, "a"), (SIb, "b")]+      boundDescs got (SS "xxx") `shouldMatchList` [(SIb, "b")]+      boundDescs got (SS "xxxx") `shouldMatchList` [(SIb, "b")]+    it "should revise conditionally on back-end state" $ do+      let b = WB.binds $ do+            WB.on SIa `WB.as` "a" `WB.run` return ()+            WB.on SIb `WB.as` "b" `WB.run` return ()+          rev (SB bs) _ i act = if bs >= 5 && i == SIb+                                then Nothing+                                else Just act+          got = WB.revise rev $ WB.extend b+      boundDescs' got (SB 3) (SS "") `shouldMatchList` [(SIa, "a"), (SIb, "b")]+      boundDescs' got (SB 5) (SS "") `shouldMatchList` [(SIa, "a")]+      boundDescs' got (SB 7) (SS "") `shouldMatchList` [(SIa, "a")]+    it "should allow modifying the action" $ withStrRef $ \out checkOut -> do+      let b = WB.binds' $ do+            WB.on SIa `WB.as` "a" `WB.run` do+              (SB bs) <- State.get+              liftIO $ modifyIORef out (++ show bs)+          rev (SB bs) (SS fs) _ = WB.justBefore bf . WB.after af+            where+              bf = modifyIORef out (++ replicate bs 'X')+              af = modifyIORef out (++ fs)+          got = WB.revise rev b+      actRun $ WB.boundAction' got (SB 4) (SS "FF") SIa+      checkOut "XXXX4FF"+    it "should be effective after change of back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+      let b = WB.startFrom (SB 0) $ WB.binds' $ do+            WB.on SIa `WB.run` do+              (SB bs) <- State.get+              liftIO $ modifyIORef out (++ show bs)+              State.put (SB $ bs + 1)+          rev _ _ _ = WB.justAfter $ modifyIORef out (++ "X")+          got = WB.revise rev b+      State.put got+      execAll (SS "") [SIa]+      checkOut "0X"+      execAll (SS "") [SIa]+      checkOut "0X1X"+      execAll (SS "") [SIa]+      checkOut "0X1X2X"+  describe "revise'" $ do+    it "should allow modifying the back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+      let b = WB.binds' $ do+            WB.on SIa `WB.as` "a" `WB.run` do+              (SB bs) <- State.get+              liftIO $ modifyIORef out (++ show bs)+          rev _ (SS fs) _ = WB.justAfter af . WB.before bf+            where+              bf = State.modify (\(SB s) -> SB (s + 1))+              af = State.put $ SB $ length fs+          got = WB.startFrom (SB 0) $ WB.revise' rev b+      State.put got+      execAll (SS "abc") [SIa]+      checkOut "1"+      execAll (SS "a") [SIa]+      checkOut "14"+      execAll (SS "") [SIa]+      checkOut "142"+    it "should allow unbind conditionally" $ evalStateEmpty $ do+      let b = WB.binds' $ do+            WB.on SIa `WB.as` "a" `WB.run` State.modify (\(SB bs) -> SB $ bs + 1)+            WB.on SIb `WB.as` "b" `WB.run` return ()+          rev (SB bs) (SS fs) i orig = if i == SIb && bs >= 3 && bs <= 6 && fs /= "XXX"+                                       then Nothing+                                       else Just orig+          got = WB.startFrom (SB 0) $ WB.revise' rev b+      State.put got+      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+      execAll (SS "") [SIa, SIa]+      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+      execAll (SS "") [SIa]+      checkBoundDescs (SS "") [(SIa, "a")]+      checkBoundDescs (SS "XXX") [(SIa, "a"), (SIb, "b")]+      execAll (SS "") [SIa, SIa, SIa]+      checkBoundDescs (SS "") [(SIa, "a")]+      execAll (SS "") [SIa]+      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+      

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module WildBind.ExecSpec (main, spec) where  import Control.Applicative ((<$>))@@ -41,7 +42,7 @@   liftIO $ atomically $ writeTChan out_chan out_elem   State.put next_state -withWildBind' :: Ord i => (WBF.FrontEnd s i -> IO ()) -> (EventChan s i -> GrabChan i -> IO ()) -> IO ()+withWildBind' :: (WBF.FrontEnd s i -> IO ()) -> (EventChan s i -> GrabChan i -> IO ()) -> IO () withWildBind' exec action = do   echan <- EventChan <$> newTChanIO   gchan <- GrabChan <$> newTChanIO

@@ -1,12 +1,33 @@ module WildBind.ForTest        ( SampleInput(..),          SampleState(..),-         SampleBackState(..)+         SampleBackState(..),+         inputAll,+         execAll,+         evalStateEmpty,+         boundDescs,+         boundDescs',+         curBoundInputs,+         curBoundDescs,+         curBoundDesc,+         checkBoundInputs,+         checkBoundDescs,+         checkBoundDesc,+         withRefChecker        ) where -import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad (join)+import Control.Monad.IO.Class (liftIO, MonadIO)+import qualified Control.Monad.Trans.State as State+import Data.IORef (IORef, newIORef, readIORef)+import Data.Monoid (mempty) import Test.QuickCheck (Arbitrary(arbitrary,shrink), arbitraryBoundedEnum)+import Test.Hspec (shouldReturn, shouldMatchList, shouldBe) +import qualified WildBind.Binding as WB+import qualified WildBind.Description as WBD+ data SampleInput = SIa | SIb | SIc                  deriving (Show, Eq, Ord, Enum, Bounded) @@ -28,3 +49,54 @@   toEnum = SB   fromEnum = unSB ++inputAll :: Ord i => WB.Binding s i -> s -> [i] -> IO (WB.Binding s i)+inputAll b _ [] = return b+inputAll binding state (i:rest) = case WB.boundAction binding state i of+  Nothing -> inputAll binding state rest+  Just act -> join $ inputAll <$> WB.actDo act <*> return state <*> return rest++execAll :: Ord i => s -> [i] -> State.StateT (WB.Binding s i) IO ()+execAll state inputs = do+  b <- State.get+  next_b <- liftIO $ inputAll b state inputs+  State.put next_b++evalStateEmpty :: State.StateT (WB.Binding SampleState SampleInput) IO () -> IO ()+evalStateEmpty s = State.evalStateT s mempty++toDesc :: (i, WB.Action m a) -> (i, WBD.ActionDescription)+toDesc (i, act) = (i, WB.actDescription act)++boundDescs :: WB.Binding s i -> s -> [(i, WBD.ActionDescription)]+boundDescs b s = map toDesc $ WB.boundActions b s++boundDescs' :: WB.Binding' bs fs i -> bs -> fs -> [(i, WBD.ActionDescription)]+boundDescs' b bs fs = map toDesc $ WB.boundActions' b bs fs++curBoundInputs :: s -> State.StateT (WB.Binding s i) IO [i]+curBoundInputs s = State.gets WB.boundInputs <*> pure s++curBoundDescs :: s -> State.StateT (WB.Binding s i) IO [(i, WBD.ActionDescription)]+curBoundDescs s = State.gets boundDescs <*> pure s++curBoundDesc :: Ord i => s -> i -> State.StateT (WB.Binding s i) IO (Maybe WBD.ActionDescription)+curBoundDesc s i = (fmap . fmap) WB.actDescription $ State.gets WB.boundAction <*> pure s <*> pure i++checkBoundInputs :: (Eq i, Show i) => s -> [i] -> State.StateT (WB.Binding s i) IO ()+checkBoundInputs fs expected = liftIO . (`shouldMatchList` expected) =<< curBoundInputs fs++checkBoundDescs :: (Eq i, Show i) => s -> [(i, WBD.ActionDescription)] -> State.StateT (WB.Binding s i) IO ()+checkBoundDescs fs expected = liftIO . (`shouldMatchList` expected) =<< curBoundDescs fs++checkBoundDesc :: (Ord i) => s -> i -> WBD.ActionDescription -> State.StateT (WB.Binding s i) IO ()+checkBoundDesc fs input expected = liftIO . (`shouldBe` Just expected) =<< curBoundDesc fs input+  +withRefChecker :: (Eq a, Show a, MonadIO m)+               => a+               -> (IORef a -> (a -> m ()) -> m ())+               -> m ()+withRefChecker init_ref action = do+  out <- liftIO $ newIORef init_ref+  let checkOut expected = liftIO $ readIORef out `shouldReturn` expected+  action out checkOut

@@ -0,0 +1,193 @@+{-# LANGUAGE OverloadedStrings #-}+module WildBind.SeqSpec (main,spec) where++import Control.Applicative ((<*>))+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import qualified Control.Monad.Trans.State as State+import Data.Monoid ((<>))+import Data.IORef (modifyIORef, newIORef, readIORef)+import Test.Hspec++import WildBind.Binding+  ( binds, on, run, as,+    boundActions, actDescription,+    boundInputs,+    Binding,+    justBefore+  )+import WildBind.Description (ActionDescription)+import WildBind.Seq+  ( prefix,+    toSeq, fromSeq,+    withPrefix, withCancel,+    reviseSeq+  )++import WildBind.ForTest+  ( SampleInput(..), SampleState(..),+    evalStateEmpty, execAll,+    boundDescs, curBoundInputs, curBoundDescs, curBoundDesc,+    checkBoundInputs,+    checkBoundDescs,+    checkBoundDesc,+    withRefChecker+  )++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  spec_prefix+  spec_SeqBinding+  spec_reviseSeq++spec_prefix :: Spec+spec_prefix = describe "prefix" $ do+  let base_b = binds $ do+        on SIa `as` "a" `run` return ()+        on SIb `as` "b" `run` return ()+  specify "no prefix" $ do+    let b = prefix [] [] base_b+    boundDescs b (SS "") `shouldMatchList`+      [ (SIa, "a"),+        (SIb, "b")+      ]+  specify "one prefix" $ evalStateEmpty $ do+    State.put $ prefix [] [SIc] base_b+    checkBoundInputs (SS "") [SIc]+    execAll (SS "") [SIc] +    checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+    execAll (SS "") [SIc]+    checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+    execAll (SS "") [SIa]+    checkBoundInputs (SS "") [SIc]+  specify "two prefixes" $ evalStateEmpty $ do+    State.put $ prefix [] [SIc, SIb] base_b+    checkBoundInputs (SS "") [SIc]+    execAll (SS "") [SIc]+    checkBoundInputs (SS "") [SIb]+    execAll (SS "") [SIb]+    checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+    execAll (SS "") [SIa]+    checkBoundInputs (SS "") [SIc]+  specify "cancel binding" $ evalStateEmpty $ do+    State.put $ prefix [SIa] [SIc, SIb] base_b+    checkBoundInputs (SS "") [SIc]+    execAll (SS "") [SIc] -- there is no cancel binding at the top level.+    checkBoundInputs (SS "") [SIa, SIb]+    checkBoundDesc (SS "") SIa "cancel"+    execAll (SS "") [SIa]+    checkBoundInputs (SS "") [SIc]+    execAll (SS "") [SIc, SIb]+    checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]  -- cancel binding should be weak and overridden.+    execAll (SS "") [SIb]+    checkBoundInputs (SS "") [SIc]+    execAll (SS "") [SIc, SIb]+    checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+    execAll (SS "") [SIa]+    checkBoundInputs (SS "") [SIc]+++spec_SeqBinding :: Spec+spec_SeqBinding = describe "SeqBinding" $ do+  let b_a = binds $ on SIa `as` "a" `run` return ()+      b_b = binds $ on SIb `as` "b" `run` return ()+  describe "withPrefix" $ do+    it "should allow nesting" $ evalStateEmpty $ do+      State.put $ fromSeq $ withPrefix [SIb] $ withPrefix [SIc] $ withPrefix [SIa] $ toSeq (b_a <> b_b)+      checkBoundInputs (SS "") [SIb]+      execAll (SS "") [SIb]+      checkBoundInputs (SS "") [SIc]+      execAll (SS "") [SIc]+      checkBoundInputs (SS "") [SIa]+      execAll (SS "") [SIa]+      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]+      execAll (SS "") [SIa]+      checkBoundInputs (SS "") [SIb]+  describe "mappend" $ do+    it "should be able to combine SeqBindings with different prefixes." $ evalStateEmpty $ do+      State.put $ fromSeq $ withPrefix [SIc] $ ( (withPrefix [SIa, SIc] $ toSeq $ b_a)+                                                 <> (withPrefix [SIa] $ toSeq $ b_b)+                                               )+      checkBoundInputs (SS "") [SIc]+      execAll (SS "") [SIc]+      checkBoundInputs (SS "") [SIa]+      execAll (SS "") [SIa]+      checkBoundInputs (SS "") [SIc, SIb]+      checkBoundDesc (SS "") SIb "b"+      execAll (SS "") [SIb]+      checkBoundInputs (SS "") [SIc]+      execAll (SS "") [SIc, SIa]+      checkBoundInputs (SS "") [SIc, SIb]+      execAll (SS "") [SIc]+      checkBoundDescs (SS "") [(SIa, "a")]+      execAll (SS "") [SIa]+      checkBoundInputs (SS "") [SIc]+  describe "withCancel" $ do+    it "should weakly add 'cancel' binding when at least one prefix is kept in the state." $ evalStateEmpty $ do+      State.put $ fromSeq $ withPrefix [SIa, SIc] $ withCancel [SIa, SIb, SIc] $ ( toSeq b_a+                                                                                   <> (withPrefix [SIc] $ toSeq b_b)+                                                                                 )+      let checkPrefixOne = do+            checkBoundInputs (SS "") [SIa]+            execAll (SS "") [SIa]+            checkBoundInputs (SS "") [SIa, SIb, SIc]+            forM_ [SIa, SIb] $ \c -> checkBoundDesc (SS "") c "cancel"+      checkPrefixOne+      execAll (SS "") [SIa]+      checkPrefixOne+      execAll (SS "") [SIc]+      checkBoundInputs (SS "") [SIa, SIb, SIc]+      checkBoundDesc (SS "") SIa "a"+      checkBoundDesc (SS "") SIb "cancel"+      execAll (SS "") [SIa]+      checkPrefixOne+      execAll (SS "") [SIc, SIb]+      checkPrefixOne+      execAll (SS "") [SIc, SIc]+      checkBoundDescs (SS "") [(SIa, "cancel"), (SIb, "b"), (SIc, "cancel")]+      execAll (SS "") [SIb]+      checkPrefixOne+      +spec_reviseSeq :: Spec+spec_reviseSeq = describe "reviseSeq" $ do+  it "should allow access to prefix keys input so far" $ evalStateEmpty $ withRefChecker [] $ \out checkOut -> do+    act_out <- liftIO $ newIORef ("" :: String)+    let sb = withCancel [SIa] $ withPrefix [SIa, SIb, SIc] $ toSeq $ base_b+        base_b = binds $ on SIb `as` "B" `run` modifyIORef act_out (++ "B executed")+        rev ps _ _ = justBefore $ modifyIORef out (++ [ps])+    State.put $ fromSeq $ reviseSeq rev sb+    execAll (SS "") [SIa, SIa]+    checkOut [[], [SIa]]+    execAll (SS "") [SIa, SIb, SIc]+    checkOut [[], [SIa], [], [SIa], [SIa, SIb]]+    liftIO $ readIORef act_out `shouldReturn` ""+    execAll (SS "") [SIb]+    checkOut [[], [SIa], [], [SIa], [SIa, SIb], [SIa, SIb, SIc]]+    liftIO $ readIORef act_out `shouldReturn` "B executed"+  it "should allow unbinding" $ evalStateEmpty $ do+    let sb = withPrefix [SIa]+             ( toSeq ba+               <> (withPrefix [SIb] $ toSeq bab)+               <> (withPrefix [SIa] $ toSeq baa)+             )+        ba  = binds $ on SIc `as` "c on a" `run` return ()+        bab = binds $ on SIc `as` "c on ab" `run` return ()+        baa = binds $ do+          on SIc `as` "c on aa" `run` return ()+          on SIb `as` "b on aa" `run` return ()+        rev ps _ i act = if (ps == [SIa] && i == SIb) || (ps == [SIa,SIa] && i == SIc)+                         then Nothing+                         else Just act+    State.put $ fromSeq $ reviseSeq rev sb+    checkBoundInputs (SS "") [SIa]+    execAll (SS "") [SIa]+    checkBoundInputs (SS "") [SIa, SIc] -- SIb should be canceled+    execAll (SS "") [SIa]+    checkBoundDescs (SS "") [(SIb, "b on aa")] -- SIc should be canceled+    execAll (SS "") [SIb]+    checkBoundInputs (SS "") [SIa]+    +    

@@ -1,5 +1,5 @@ name:                   wild-bind-version:                0.1.0.3+version:                0.1.1.0 author:                 Toshio Ito <debug.ito@gmail.com> maintainer:             Toshio Ito <debug.ito@gmail.com> license:                BSD3@@ -17,14 +17,14 @@   default-language:     Haskell2010   hs-source-dirs:       src   ghc-options:          -Wall -fno-warn-unused-imports-  default-extensions:   RankNTypes OverloadedStrings-  other-extensions:     GeneralizedNewtypeDeriving+  other-extensions:     GeneralizedNewtypeDeriving RankNTypes OverloadedStrings   exposed-modules:      WildBind,                         WildBind.Binding,                         WildBind.FrontEnd,                         WildBind.Description,                         WildBind.Exec,-                        WildBind.Input.NumPad+                        WildBind.Input.NumPad,+                        WildBind.Seq   -- other-modules:           build-depends:        base >=4.6 && <5.0,                         text >=1.2.0 && <1.3,@@ -46,10 +46,10 @@   hs-source-dirs:       test   ghc-options:          -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m"   main-is:              Spec.hs-  default-extensions:   OverloadedStrings FlexibleInstances MultiParamTypeClasses-  other-extensions:     RankNTypes+  other-extensions:     RankNTypes OverloadedStrings FlexibleInstances MultiParamTypeClasses   other-modules:        WildBind.ExecSpec,-                        WildBind.BindingSpec+                        WildBind.BindingSpec,+                        WildBind.SeqSpec,                         WildBind.ForTest   build-depends:        base, wild-bind, transformers,                         hspec >=2.1.7 && <2.5,