diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/src/WildBind.hs b/src/WildBind.hs --- a/src/WildBind.hs +++ b/src/WildBind.hs @@ -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 diff --git a/src/WildBind/Binding.hs b/src/WildBind/Binding.hs --- a/src/WildBind/Binding.hs +++ b/src/WildBind/Binding.hs @@ -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 diff --git a/src/WildBind/Description.hs b/src/WildBind/Description.hs --- a/src/WildBind/Description.hs +++ b/src/WildBind/Description.hs @@ -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 diff --git a/src/WildBind/FrontEnd.hs b/src/WildBind/FrontEnd.hs --- a/src/WildBind/FrontEnd.hs +++ b/src/WildBind/FrontEnd.hs @@ -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. diff --git a/src/WildBind/Input/NumPad.hs b/src/WildBind/Input/NumPad.hs --- a/src/WildBind/Input/NumPad.hs +++ b/src/WildBind/Input/NumPad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | -- Module: WildBind.Input.NumPad -- Description: Types about number pads diff --git a/src/WildBind/Seq.hs b/src/WildBind/Seq.hs new file mode 100644 --- /dev/null +++ b/src/WildBind/Seq.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes #-} +-- | +-- Module: WildBind.Seq +-- Description: Support for binding sequence of input events. +-- Maintainer: Toshio Ito +-- +-- 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 diff --git a/test/WildBind/BindingSpec.hs b/test/WildBind/BindingSpec.hs --- a/test/WildBind/BindingSpec.hs +++ b/test/WildBind/BindingSpec.hs @@ -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")] + diff --git a/test/WildBind/ExecSpec.hs b/test/WildBind/ExecSpec.hs --- a/test/WildBind/ExecSpec.hs +++ b/test/WildBind/ExecSpec.hs @@ -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 diff --git a/test/WildBind/ForTest.hs b/test/WildBind/ForTest.hs --- a/test/WildBind/ForTest.hs +++ b/test/WildBind/ForTest.hs @@ -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 diff --git a/test/WildBind/SeqSpec.hs b/test/WildBind/SeqSpec.hs new file mode 100644 --- /dev/null +++ b/test/WildBind/SeqSpec.hs @@ -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] + + diff --git a/wild-bind.cabal b/wild-bind.cabal --- a/wild-bind.cabal +++ b/wild-bind.cabal @@ -1,5 +1,5 @@ name: wild-bind -version: 0.1.0.3 +version: 0.1.1.0 author: Toshio Ito maintainer: Toshio Ito 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,