wild-bind (empty) → 0.1.0.0
raw patch · 15 files changed
+1682/−0 lines, 15 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, hspec, microlens, stm, text, transformers, wild-bind
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +30/−0
- Setup.hs +2/−0
- src/WildBind.hs +32/−0
- src/WildBind/Binding.hs +326/−0
- src/WildBind/Description.hs +19/−0
- src/WildBind/Exec.hs +133/−0
- src/WildBind/FrontEnd.hs +34/−0
- src/WildBind/Input/NumPad.hs +94/−0
- test/Spec.hs +1/−0
- test/WildBind/BindingSpec.hs +650/−0
- test/WildBind/ExecSpec.hs +234/−0
- test/WildBind/ForTest.hs +30/−0
- wild-bind.cabal +62/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for wild-bind-x11++## 0.1.0.0 -- 2016-09-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Toshio Ito++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Toshio Ito nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,30 @@+# wild-bind++WildBind is a dynamic and programmable key binding framework. See https://github.com/debug-ito/wild-bind for WildBind in general.++## Architecture and Terminology++WildBind consists of `FrontEnd` and `Binding`.++ +-------------------++ (user) --input-> | desktop env. |---[FrontEnd]---[Binding]+ | | |+ | (front-end state) | (back-end state)+ +-------------------+++- A `FrontEnd` interfaces with a desktop environment. It reads input from the user and the state of the desktop environment. The state is called "front-end state". `FrontEnd` passes those two kinds of data to `Binding`.+- A `Binding` binds actions to input symbols. Optionally it has its own state, which is called "back-end state".+++## wild-bind Packages++- wild-bind: WildBind core data types and functions. This package defines `FrontEnd`, `Binding` and other common types. Although WildBind is mainly targeted to number pads, its core is independent of any input types or desktop environments.+- wild-bind-x11: A `FrontEnd` implementation for X11 desktop environments.+- wild-bind-indicator: A GUI that describes current `Binding` to the user.+- wild-bind-task-x11: A bundle package that combines all packages above. End users should use this package first.+++## Author++Toshio Ito <debug.ito at gmail.com>+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/WildBind.hs view
@@ -0,0 +1,32 @@+-- |+-- Module: WildBind+-- Description: WildBind main module+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +module WildBind+ ( module WildBind.Binding,+ -- | Defines 'Binding' and many functions to build it.+ + module WildBind.FrontEnd,+ -- | Defines 'FrontEnd', an interface between 'Binding' and a+ -- desktop environment.+ + module WildBind.Exec,+ -- | Defines functions to combine 'Binding' and 'FrontEnd'+ -- into an executable action. You can customize its behavior+ -- via 'Option'.+ + module WildBind.Description,+ -- | Defines 'ActionDescription'.+ + module WildBind.Input.NumPad+ -- | Defines input symbol types for number pad keys.+ ) where+++import WildBind.Description+import WildBind.Binding+import WildBind.FrontEnd+import WildBind.Exec+import WildBind.Input.NumPad
+ src/WildBind/Binding.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module: WildBind.Binding+-- Description: Functions to build Binding+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- This module exports functions to build and manipulate 'Binding', an+-- object binding input symbols to actions.+-- +module WildBind.Binding+ ( -- * Types+ Action(Action,actDescription,actDo),+ Binding,+ Binding',+ + -- * Construction++ -- | Functions to create fundamental 'Binding's.+ --+ -- To create complex 'Binding's, use <#Condition Condition> functions+ -- described below and 'mappend' them together.+ + noBinding,+ Binder,+ binds,+ binds',+ on,+ run,+ as,+ binding,+ binding',+ + -- * Condition+ + -- | #Condition# With these functions, you can create+ -- 'Binding's that behave differently for different front-end+ -- and/or back-end states.+ --+ -- If you call the condition functions multiple times, the+ -- conditions are combined with AND logic.+ ifFront,+ ifBack,+ ifBoth,+ whenFront,+ whenBack,+ whenBoth,+ -- * Conversion+ advice,+ before,+ after,+ startFrom,+ extend,+ convFront,+ convInput,+ convBack,+ -- * Execution+ boundAction,+ boundAction',+ boundActions,+ boundActions',+ boundInputs,+ boundInputs'+ ) where++import Control.Applicative (Applicative, (<*), (*>))+import Control.Monad.Trans.State (StateT, runStateT)+import Control.Monad.Trans.Writer (Writer, tell, execWriter, mapWriter)+import qualified Data.Map as M+import Data.Monoid (Monoid(..), Endo(Endo, appEndo))++import WildBind.Description (ActionDescription)++-- | Action done by WildBind+data Action m a =+ Action+ { actDescription :: ActionDescription, -- ^ Human-readable description of the action.+ actDo :: m a -- ^ The actual job.+ }++instance Show (Action m a) where+ show a = "Action " ++ show (actDescription a)++instance Functor m => Functor (Action m) where+ fmap f a = a { actDo = fmap f (actDo a) }++-- | Make an 'Action' that runs the given monadic action before the+-- original 'Action'.+before :: (Applicative m)+ => m b -- ^ the monadic action prepended+ -> Action m a -- ^ the original 'Action'.+ -> Action m a+before hook act = act { actDo = hook *> actDo act }++-- | Make an 'Action' that runs the given monadic action after the+-- original 'Action'.+after :: (Applicative m)+ => m b -- ^ the monadic action appended.+ -> Action m a -- ^ the original 'Action'.+ -> Action m a+after hook act = act { actDo = actDo act <* hook }++-- | 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.+--+-- You can make the explicit state @bs@ implicit by 'startFrom'+-- function.+newtype Binding' bs fs i =+ Binding'+ { unBinding' :: bs -> fs -> M.Map i (Action IO (Binding' bs fs i, bs))+ }++-- | 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++-- | 'mempty' returns a 'Binding' where no binding is+-- defined. 'mappend' combines two 'Binding's while preserving their+-- individual implicit states. The right-hand 'Binding' has precedence+-- over the left-hand one. That is, if the two 'Binding's both have a+-- binding to the same key in the same front-end and back-end state,+-- the binding from the right-hand one is used.+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+ in M.unionWith (\_ b -> b) amap bmap++-- | A 'Binding'' with no bindings. It's the same as 'mempty', except+-- 'noBinding' requires no context.+noBinding :: Binding' bs fs i+noBinding = Binding' $ \_ _ -> M.empty++-- | Get the 'Action' bound to the specified state @s@ and input @i@.+boundAction :: (Ord i) => Binding s i -> s -> i -> Maybe (Action IO (Binding s i))+boundAction b state input = (fmap . fmap) fst $ boundAction' b () state input++-- | 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++-- | Get the list of all bound inputs @i@ and their corresponding+-- actions for the specified front-end state @s@.+boundActions :: Binding s i -> s -> [(i, Action IO (Binding s i))]+boundActions b state = fmap (\(i, act) -> (i, fmap fst act)) $ boundActions' b () state++-- | Get the list of all bound inputs @i@ and their corresponding+-- 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++-- | Get the list of all bound inputs @i@ for the specified front-end+-- state @s@.+boundInputs :: Binding s i -> s -> [i]+boundInputs b s = fmap fst $ boundActions b s++-- | Get the list of all bound inputs @i@ for the specified front-end+-- state @fs@ and the back-end state @bs@.+boundInputs' :: Binding' bs fs i -> bs -> fs -> [i]+boundInputs' b bs fs = fmap fst $ boundActions' b bs fs+++-- | A monad to construct 'Binding''. @i@ is the input symbol, and @v@+-- is supposed to be the 'Action' bound to @i@.+newtype Binder i v a = Binder { unBinder :: Writer (Endo [(i, v)]) a }+ deriving (Monad,Applicative,Functor)++runBinder :: Binder i v a -> [(i, v)] -> [(i, v)]+runBinder = appEndo . execWriter . unBinder++-- | Build a 'Binding' with no explicit or implicit state. The bound+-- actions are activated regardless of the back-end or front-end+-- state.+--+-- If different actions are bound to the same input, the latter action+-- wins.+--+-- Result of action (@r@) is discarded.+binds :: Ord i => Binder i (Action IO r) a -> Binding' bs fs i+binds = binding . 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 []++-- | 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) :)++-- | Transform the given action @m a@ into an 'Action' and apply the+-- continuation to it. It discards the result of action (type+-- @a@). Usually used as an operator.+run :: Functor m => (Action m () -> b) -> m a -> b+run cont raw_act = cont $ Action { actDescription = "", actDo = fmap (const ()) raw_act }++infixl 2 `run`++-- | Transform the given continuation so that the 'ActionDescription'+-- is set to the 'Action' passed to the continuation. Usually used as+-- an operator.+as :: (Action m a -> b) -> ActionDescription -> Action m a -> b+as cont desc act = cont $ act { actDescription = desc }++infixl 2 `as`++-- | Transform the actions in the given 'Binder'.+advice :: (v -> v') -> Binder i v a -> Binder i v' a+advice f = Binder . mapWriter f_writer . unBinder where+ f_writer (a, e) = (a, f_endo e)+ f_endo (Endo prepender) = Endo ((map f_pair $ prepender []) ++)+ f_pair (i, v) = (i, f v)+++-- | 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++-- | Create a binding that behaves differently for different front-end+-- states @fs@.+ifFront :: (fs -> Bool) -- ^ The predicate+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'True'+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'False'+ -> Binding' bs fs i+ifFront p = ifBoth $ \_ fs -> p fs++-- | Create a binding that behaves differently for different back-end+-- states @bs@.+ifBack :: (bs -> Bool) -- ^ The predicate+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'True'+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'False'+ -> Binding' bs fs i+ifBack p = ifBoth $ \bs _ -> p bs++-- | Create a binding that behaves differently for different front-end+-- and back-end states, @fs@ and @bs@.+ifBoth :: (bs -> fs -> Bool) -- ^ The predicate+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'True'+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'False'+ -> 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++-- | Add a condition on the front-end state to 'Binding'.+whenFront :: (fs -> Bool) -- ^ The predicate.+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'True'+ -> Binding' bs fs i+whenFront p = whenBoth $ \_ fs -> p fs++-- | Add a condition on the back-end state to 'Binding'.+whenBack :: (bs -> Bool) -- ^ The predicate.+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'True'+ -> Binding' bs fs i+whenBack p = whenBoth $ \bs _ -> p bs++-- | Add a condition on the back-end and front-end states to+-- 'Binding'.+whenBoth :: (bs -> fs -> Bool) -- ^ The predicate.+ -> Binding' bs fs i -- ^ Enabled if the predicate is 'True'.+ -> 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)++-- | 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++-- | Convert the back-end state. Intuitively, it converts a small+-- state type @bs@ into a bigger state type @bs'@, which includes+-- @bs@.+--+-- For example, if you have a 'Control.Lens.Lens'' @l@, you can do+--+-- > convBack (set l) (view l) b+convBack :: (bs -> bs' -> bs') -- ^ A setter. It's supposed to set+ -- @bs@ into the original @bs'@ and+ -- return the result.+ -> (bs' -> bs) -- ^ A getter. It's supposed to extract @bs@+ -- from @bs'@.+ -> 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++-- | Convert 'Binding'' to 'Binding' by hiding the explicit state+-- @bs@.+startFrom :: bs -- ^ Initial state+ -> 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+ where+ toB (next_b', next_state) = (startFrom next_state next_b', ())++-- | 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+extend = convBack (const id) (const ())++-- | 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++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)
+ src/WildBind/Description.hs view
@@ -0,0 +1,19 @@+-- |+-- Module: WildBind.Description+-- Description: Types about ActionDescription+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+module WildBind.Description+ ( ActionDescription,+ Describable(..)+ ) where++import Data.Text (Text)++-- | Human-readable description of an action. 'ActionDescription' is+-- used to describe the current binding to the user.+type ActionDescription = Text++-- | Class for something describable.+class Describable d where+ describe :: d -> ActionDescription
+ src/WildBind/Exec.hs view
@@ -0,0 +1,133 @@+-- |+-- 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.Description (ActionDescription)+import WildBind.FrontEnd+ ( FrontEvent(FEChange,FEInput),+ FrontEnd(frontSetGrab, frontUnsetGrab, frontNextEvent)+ )+import WildBind.Binding+ ( Action(actDo, actDescription),+ Binding,+ boundAction,+ boundInputs,+ boundActions+ )++type GrabSet i = [i]++updateGrab :: (Eq i) => FrontEnd s i -> GrabSet i -> GrabSet i -> IO ()+updateGrab f before after = do+ mapM_ (frontUnsetGrab f) (before \\ after)+ mapM_ (frontSetGrab f) (after \\ before)++-- | Combines the 'FrontEnd' and the 'Binding' and returns the executable.+wildBind :: (Ord i) => Binding s i -> FrontEnd s i -> IO ()+wildBind = wildBind' defOption++-- | Build the executable with 'Option'.+wildBind' :: (Ord i) => Option s i -> Binding s i -> FrontEnd s i -> IO ()+wildBind' opt binding front =+ flip Reader.runReaderT opt $ flip State.evalStateT (binding, Nothing) $ wildBindInContext 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 { optBindingHook :: [(i, ActionDescription)] -> IO (),+ -- ^ An action executed when current binding may be+ -- changed. Default: do nothing.++ 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 = Option { optBindingHook = const $ return (),+ optCatch = \_ _ exception -> hPutStrLn stderr ("Exception from WildBind action: " ++ show 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 = lift $ Reader.ask++boundDescriptions :: Binding s i -> s -> [(i, ActionDescription)]+boundDescriptions b s = fmap (\(i, act) -> (i, actDescription act)) $ boundActions b s++updateWBState :: (Eq i) => FrontEnd s i -> Binding s i -> s -> WBContext s i ()+updateWBState front after_binding after_state = do+ (before_binding, before_mstate) <- State.get+ let before_grabset = maybe [] (boundInputs before_binding) before_mstate+ State.put $ (after_binding, Just after_state)+ liftIO $ updateGrab front before_grabset (boundInputs after_binding after_state)+ hook <- optBindingHook <$> askOption+ liftIO $ hook $ boundDescriptions after_binding after_state++updateFrontState :: (Eq i) => FrontEnd s i -> s -> WBContext s i ()+updateFrontState front after_state = do+ (cur_binding, _) <- State.get+ updateWBState front cur_binding after_state++updateBinding :: (Eq i) => FrontEnd s i -> Binding s i -> WBContext s i ()+updateBinding front after_binding = do+ (_, mstate) <- State.get+ case mstate of+ Nothing -> return ()+ Just state -> updateWBState front after_binding state++wildBindInContext :: (Ord i) => FrontEnd s i -> WBContext s i ()+wildBindInContext front = impl where+ impl = do+ event <- liftIO $ frontNextEvent front+ case event of+ FEChange state ->+ updateFrontState front state+ FEInput input -> do+ (cur_binding, mcur_state) <- State.get+ case stateAndAction cur_binding mcur_state input of+ Nothing -> return ()+ Just (cur_state, action) -> do+ handler <- getExceptionHandler cur_binding cur_state input+ next_binding <- liftIO $ actDo action `catch` handler+ updateBinding front next_binding+ wildBindInContext front+ stateAndAction binding mstate input = do+ state <- mstate+ action <- boundAction binding state input+ return (state, action)+ getExceptionHandler binding state input = do+ opt_catch <- optCatch <$> askOption+ return $ \e -> do+ opt_catch state input e+ return binding
+ src/WildBind/FrontEnd.hs view
@@ -0,0 +1,34 @@+-- |+-- Module: WildBind.FrontEnd+-- Description: Data types and type classes about front-ends.+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- Data types and type classes about front-ends.+-- +-- You have to look at this module if you want to create a front-end+-- implementation.+module WildBind.FrontEnd+ ( FrontEvent(..),+ FrontEnd(..)+ ) where++import WildBind.Description (ActionDescription)++-- | 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)++-- | Interface to the front-end. @s@ is the state of the front-end,+-- @i@ is the input.+data FrontEnd s i =+ FrontEnd+ { frontDefaultDescription :: i -> ActionDescription,+ -- ^ Default 'ActionDescription' for inputs+ frontSetGrab :: i -> IO (),+ -- ^ Action to grab (or capture) the specified input symbol on the device. + frontUnsetGrab :: i -> IO (),+ -- ^ Action to release the grab for the input symbol.+ frontNextEvent :: IO (FrontEvent s i)+ -- ^ Action to retrieve the next event. It should block if no event is queued.+ }
+ src/WildBind/Input/NumPad.hs view
@@ -0,0 +1,94 @@+-- |+-- Module: WildBind.Input.NumPad+-- Description: Types about number pads+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- Input types for number pad keys.+module WildBind.Input.NumPad+ ( -- * NumLock disabled+ NumPadUnlocked(..),+ -- * NumLock enabled+ NumPadLocked(..),+ ) where++import WildBind.Description (Describable(describe))++-- | Number pad key input with NumLock disabled.+data NumPadUnlocked+ = NumInsert+ | NumEnd+ | NumDown+ | NumPageDown+ | NumLeft+ | NumCenter+ | NumRight+ | NumHome+ | NumUp+ | NumPageUp+ | NumDivide+ | NumMulti+ | NumMinus+ | NumPlus+ | NumEnter+ | NumDelete+ deriving (Eq,Ord,Show,Bounded,Enum)++instance Describable NumPadUnlocked where+ describe input = case input of+ NumHome -> "Home"+ NumUp -> "↑"+ NumPageUp -> "PageUp"+ NumLeft -> "←"+ NumCenter -> ""+ NumRight -> "→"+ NumEnd -> "End"+ NumDown -> "↓"+ NumPageDown -> "PageDown"+ NumDivide -> "/"+ NumMulti -> "*"+ NumMinus -> "-"+ NumPlus -> "+"+ NumEnter -> "Enter"+ NumInsert -> "Insert"+ NumDelete -> "Delete"+++-- | Number pad key input with NumLock enabled.+data NumPadLocked+ = NumL0+ | NumL1+ | NumL2+ | NumL3+ | NumL4+ | NumL5+ | NumL6+ | NumL7+ | NumL8+ | NumL9+ | NumLDivide+ | NumLMulti+ | NumLMinus+ | NumLPlus+ | NumLEnter+ | NumLPeriod+ deriving (Eq,Ord,Show,Bounded,Enum)++instance Describable NumPadLocked where+ describe input = case input of+ NumL0 -> "0"+ NumL1 -> "1"+ NumL2 -> "2"+ NumL3 -> "3"+ NumL4 -> "4"+ NumL5 -> "5"+ NumL6 -> "6"+ NumL7 -> "7"+ NumL8 -> "8"+ NumL9 -> "9"+ NumLDivide -> "/"+ NumLMulti -> "*"+ NumLMinus -> "-"+ NumLPlus -> "+"+ NumLEnter -> "Enter"+ NumLPeriod -> "."+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/WildBind/BindingSpec.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE RankNTypes #-}+module WildBind.BindingSpec (main, spec) where++import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad (void, join)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Trans.State as State+import Data.Maybe (isNothing, fromJust)+import Data.Monoid (mempty, (<>))+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(..))++main :: IO ()+main = hspec spec++data BiggerSampleBackState = BSB { _lSB :: SampleBackState, _rSB :: SampleBackState }+ deriving (Show, Eq, Ord)++lSB :: Lens.Lens' BiggerSampleBackState SampleBackState+lSB = Lens.lens _lSB (\bsb sb -> bsb { _lSB = sb })++rSB :: Lens.Lens' BiggerSampleBackState SampleBackState+rSB = Lens.lens _rSB (\bsb sb -> bsb { _rSB = sb })++-- 'view' is since microlens-0.3.5.0+view :: Lens.Lens' s a -> s -> a+view l s = s Lens.^. l++newStrRef :: MonadIO m => m (IORef String)+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++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]))++outOnS :: MonadIO m => IORef [a] -> i -> a -> (s -> s) -> (i, WB.Action (State.StateT s m) ())+outOnS out_ref input out_elem modifier = (,) input $ WB.Action "" $ do+ State.modify modifier+ liftIO $ modifyIORef out_ref (++ [out_elem])++genStatelessBinding :: Arbitrary a => IORef [a] -> Gen (WB.Binding s SampleInput)+genStatelessBinding out_list =+ WB.binding <$> (listOf $ (,) <$> arbitrary <*> (WB.Action "" <$> outputRandomElem))+ where+ outputRandomElem = do+ out_elem <- arbitrary+ return $ modifyIORef out_list (out_elem :)+ +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 "")++mempty_stateless :: WB.Binding SampleState SampleInput+mempty_stateless = mempty++checkMappend :: (WB.Binding SampleState SampleInput -> WB.Binding SampleState SampleInput) -> IO ()+checkMappend append_op = do+ out_ref <- newStrRef+ rand_binding <- generate $ genStatelessBinding out_ref+ let execute b = void $ inputAll b (SS "") =<< generate (listOf arbitrary)+ execute rand_binding+ out_orig <- readIORef out_ref+ writeIORef out_ref []+ execute (append_op rand_binding)+ readIORef out_ref `shouldReturn` out_orig++actRun :: Maybe (WB.Action IO a) -> IO ()+actRun = void . WB.actDo . fromJust++checkInputsS :: (Show i, Eq i) => s -> [i] -> State.StateT (WB.Binding s i) IO ()+checkInputsS state exp_in = State.get >>= \b -> lift $ WB.boundInputs b state `shouldMatchList` exp_in++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+ spec_conversions+ spec_convBack+ spec_stateful+ spec_extend+ spec_conditionBoth+ spec_monadic++spec_stateless :: Spec+spec_stateless = do+ describe "Binding (Monoid instances)" $ do+ it "mempty returns empty binding" $ property+ ( isNothing <$> (WB.boundAction mempty_stateless <$> arbitrary <*> arbitrary) )+ it "mempty `mappend` random == mempty" $ do+ checkMappend (mempty <>)+ it "random `mappend` mempty == mempty" $ do+ checkMappend (<> mempty)+ describe "binding" $ do+ it "returns a stateless Binding" $ withStrRef $ \out checkOut -> do+ let b = WB.binding [outOn out SIa 'A', outOn out SIb 'B']+ WB.boundInputs b (SS "") `shouldMatchList` [SIa, SIb]+ WB.boundAction b (SS "") SIc `shouldSatisfy` isNothing+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "A"+ actRun $ WB.boundAction b (SS "") SIb+ checkOut "AB"+ it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do+ let b = WB.binding [ outOn out SIa '1',+ outOn out SIa '2',+ outOn out SIa '3'+ ]+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "3"+ describe "whenFront" $ do+ it "adds a condition on the front-end state" $ withStrRef $ \out checkOut -> do+ let b = WB.whenFront (\(SS s) -> s == "hoge") $ WB.binding [outOn out SIa 'A']+ WB.boundInputs b (SS "") `shouldMatchList` []+ WB.boundAction b (SS "") SIa `shouldSatisfy` isNothing+ WB.boundInputs b (SS "foobar") `shouldMatchList` []+ WB.boundAction b (SS "foobar") SIa `shouldSatisfy` isNothing+ WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]+ actRun $ WB.boundAction b (SS "hoge") SIa+ checkOut "A"+ it "is AND condition" $ withStrRef $ \out checkOut -> do+ let raw_b = WB.binding [outOn out SIa 'A']+ b = WB.whenFront ((<= 5) . length . unSS) $ WB.whenFront ((3 <=) . length . unSS) $ raw_b+ WB.boundInputs b (SS "ho") `shouldMatchList` []+ WB.boundAction b (SS "ho") SIa `shouldSatisfy` isNothing+ WB.boundInputs b (SS "hogehoge") `shouldMatchList` []+ WB.boundAction b (SS "hogehoge") SIa `shouldSatisfy` isNothing+ WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]+ actRun $ WB.boundAction b (SS "hoge") SIa+ checkOut "A"+ it "should be effective for derived Bindings" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let raw_b = WB.binding [outOn out SIa 'A']+ State.put $ WB.whenFront (\(SS s) -> s == "foobar") $ raw_b+ checkInputsS (SS "hoge") []+ checkInputsS (SS "foobar") [SIa]+ execAll (SS "foobar") [SIa]+ checkOut "A"+ checkInputsS (SS "hoge") []+ checkInputsS (SS "foobar") [SIa]+ describe "ifFront" $ do+ it "chooses from independent Bindings" $ withStrRef $ \out checkOut -> do+ let b = WB.ifFront (\(SS s) -> length s <= 5)+ (WB.binding [outOn out SIa 'A']) (WB.binding [outOn out SIb 'B'])+ WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]+ WB.boundInputs b (SS "foobar") `shouldMatchList` [SIb]+ actRun $ WB.boundAction b (SS "foobar") SIb+ checkOut "B"+ it "adds AND conditions when nested" $ withStrRef $ \out checkOut -> do+ let b1 = WB.ifFront (\(SS s) -> length s <= 5)+ (WB.binding [outOn out SIa 'A']) (WB.binding [outOn out SIb 'B'])+ b = WB.ifFront (\(SS s) -> length s >= 3) b1 $ WB.binding [outOn out SIc 'C']+ WB.boundInputs b (SS "") `shouldMatchList` [SIc]+ WB.boundInputs b (SS "foo") `shouldMatchList` [SIa]+ WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]+ WB.boundInputs b (SS "foobar") `shouldMatchList` [SIb]+ actRun $ WB.boundAction b (SS "ho") SIc+ checkOut "C"+ describe "Binding (mappend)" $ do+ it "combines two stateless Bindings" $ withStrRef $ \out checkOut -> do+ let b1 = WB.binding [outOn out SIa 'A']+ b2 = WB.binding [outOn out SIb 'B']+ b = b1 <> b2+ WB.boundInputs b (SS "") `shouldMatchList` [SIa, SIb]+ void $ inputAll b (SS "") [SIa, SIb]+ checkOut "AB"+ it "front-end conditions are preserved" $ withStrRef $ \out _ -> do+ let b1 = WB.whenFront ((3 <=) . length . unSS) $ WB.binding [outOn out SIa 'A']+ b2 = WB.whenFront ((<= 5) . length . unSS) $ WB.binding [outOn out SIb 'B']+ b = b1 <> b2+ WB.boundInputs b (SS "aa") `shouldMatchList` [SIb]+ WB.boundInputs b (SS "aabb") `shouldMatchList` [SIa, SIb]+ WB.boundInputs b (SS "aabbcc") `shouldMatchList` [SIa]+ it "prefers the latter Binding" $ withStrRef $ \out checkOut -> do+ let b1 = WB.binding [outOn out SIa '1', outOn out SIb 'B']+ b2 = WB.binding [outOn out SIa '2']+ b = b1 <> b2+ WB.boundInputs b (SS "") `shouldMatchList` [SIa, SIb]+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "2"+ it "preserves implicit back-end states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let b1 = WB.startFrom (SB 0)+ $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa '0' (\_ -> SB 1)])+ $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIa '1' (\_ -> SB 0)])+ $ mempty+ b2 = WB.startFrom (SB 0)+ $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIb '2' (\_ -> SB 1)])+ $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb '3' (\_ -> SB 0)])+ $ mempty+ State.put (b1 <> b2)+ checkInputsS (SS "") [SIa, SIb]+ execAll (SS "") [SIa]+ checkOut "0"+ checkInputsS (SS "") [SIa, SIb]+ execAll (SS "") [SIb]+ checkOut "02"+ checkInputsS (SS "") [SIa, SIb]+ execAll (SS "") [SIa]+ checkOut "021"+ checkInputsS (SS "") [SIa, SIb]+ execAll (SS "") [SIb]+ checkOut "0213"+ checkInputsS (SS "") [SIa, SIb]+ execAll (SS "") [SIa]+ checkOut "02130"++spec_conversions :: Spec+spec_conversions = do+ describe "convFront" $ do+ it "converts front-end state" $ withStrRef $ \out checkOut -> do+ let orig_b = WB.whenFront (("hoge" ==) . unSS) $ WB.binding [outOn out SIa 'A']+ b = WB.convFront SS orig_b+ WB.boundInputs b "" `shouldMatchList` []+ WB.boundInputs b "hoge" `shouldMatchList` [SIa]+ actRun $ WB.boundAction b "hoge" SIa+ checkOut "A"+ describe "convInput" $ do+ it "converts input symbols" $ withStrRef $ \out checkOut -> do+ let orig_b = WB.binding [outOn out SIa 'A']+ b = WB.convInput show orig_b+ WB.boundInputs b (SS "") `shouldMatchList` ["SIa"]+ actRun $ WB.boundAction b (SS "") "SIa"+ checkOut "A"+ describe "advice" $ do+ it "converts all actions in Binder" $ withStrRef $ \out checkOut -> do+ let convert_action a = a { WB.actDescription = WB.actDescription a <> "!!",+ WB.actDo = WB.actDo a >> (modifyIORef out (++ "!"))+ }+ b = WB.binds $ WB.advice convert_action $ do+ WB.on SIa `WB.as` "action a" `WB.run` modifyIORef out (++ "A")+ WB.on SIb `WB.as` "action b" `WB.run` modifyIORef out (++ "B")+ (WB.actDescription <$> WB.boundAction b () SIa) `shouldBe` Just "action a!!"+ (WB.actDescription <$> WB.boundAction b () SIb) `shouldBe` Just "action b!!"+ void $ inputAll b () [SIa]+ checkOut "A!"+ void $ inputAll b () [SIb]+ checkOut "A!B!"+ it "preserves the order of binding." $ withStrRef $ \out checkOut -> do+ let b = WB.binds $ WB.advice (WB.before $ modifyIORef out (++ "A")) $ do+ WB.on SIa `WB.run` modifyIORef out (++ "1")+ WB.on SIa `WB.run` modifyIORef out (++ "2")+ WB.on SIa `WB.run` modifyIORef out (++ "3")+ void $ inputAll b () [SIa]+ checkOut "A3"+ it "can nest" $ withStrRef $ \out checkOut -> do+ let b = WB.binds $ do+ WB.on SIa `WB.run` modifyIORef out (++ "1")+ WB.advice (WB.before $ modifyIORef out (++ "*")) $ do+ WB.on SIb `WB.run` modifyIORef out (++ "3")+ WB.advice (WB.after $ modifyIORef out (++ "@")) $ do+ WB.on SIa `WB.run` modifyIORef out (++ "4")+ WB.on SIc `WB.run` modifyIORef out (++ "5")+ WB.advice (WB.after $ modifyIORef out (++ "#")) $ do+ WB.on SIb `WB.run` modifyIORef out (++ "6")+ WB.on SIc `WB.run` modifyIORef out (++ "7")+ WB.on SIa `WB.run` modifyIORef out (++ "8")+ void $ inputAll b () [SIa]+ checkOut "*8"+ void $ inputAll b () [SIb]+ checkOut "*8*6#"+ void $ inputAll b () [SIc]+ checkOut "*8*6#*7#"+ describe "before" $ do+ it "prepends a monadic action" $ withStrRef $ \out checkOut -> do+ let act = WB.Action { WB.actDescription = "desc",+ WB.actDo = modifyIORef out (++ "ORIG")+ }+ got = WB.before (modifyIORef out (++ "before")) act+ WB.actDescription got `shouldBe` "desc"+ WB.actDo got+ checkOut "beforeORIG"+ describe "after" $ do+ it "appends a monadic action" $ withStrRef $ \out checkOut -> do+ let act = WB.Action { WB.actDescription = "desc",+ WB.actDo = modifyIORef out (++ "ORIG")+ }+ got = WB.after (modifyIORef out (++ "after")) act+ WB.actDescription got `shouldBe` "desc"+ WB.actDo got+ checkOut "ORIGafter"++spec_convBack :: Spec+spec_convBack = do+ describe "convBack" $ do+ it "can convert the back-end state by isomorphism" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let act = do+ out_elem <- head <$> show <$> unSB <$> State.get+ liftIO $ modifyIORef out (++ [out_elem])+ State.modify succ+ orig_b = WB.binding' [(SIa, WB.Action "" act)]+ b = WB.convBack (\s _-> unSB s) SB orig_b+ State.put $ WB.startFrom 0 b+ checkInputsS' [SIa]+ execAll' [SIa]+ checkOut "0"+ execAll' [SIa]+ checkOut "01"+ execAll' [SIa]+ checkOut "012"+ it "can convert the back-end state by a lens" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let bl = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa '0' (\_ -> SB 1)])+ $ WB.whenBack (== (SB 1)) (WB.binding' [outOnS out SIa '1' (\_ -> SB 0)])+ br = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIb '2' (\_ -> SB 1)])+ $ WB.whenBack(== (SB 1)) (WB.binding' [outOnS out SIb '3' (\_ -> SB 0)])+ bg = WB.whenBack (== (BSB (SB 0) (SB 0))) $ WB.binding' [outOnS out SIc '4' (\_ -> BSB (SB 1) (SB 1))]+ convBackByLens :: Lens.Lens' s a -> WB.Binding' a f i -> WB.Binding' s f i+ convBackByLens l = WB.convBack (Lens.set l) (view l)+ b = (convBackByLens lSB bl) <> (convBackByLens rSB br) <> bg+ State.put $ WB.startFrom (BSB (SB 0) (SB 0)) b+ checkInputsS' [SIa, SIb, SIc]+ execAll' [SIa]+ checkOut "0"+ checkInputsS' [SIa, SIb]+ execAll' [SIb]+ checkOut "02"+ checkInputsS' [SIa, SIb]+ execAll' [SIb]+ checkOut "023"+ checkInputsS' [SIa, SIb]+ execAll' [SIa]+ checkOut "0231"+ checkInputsS' [SIa, SIb, SIc]+ execAll' [SIc]+ checkOut "02314"+ checkInputsS' [SIa, SIb]+ execAll' [SIa, SIb]+ checkOut "0231413"+ ++spec_stateful :: Spec+spec_stateful = do+ describe "binding'" $ do+ it "returns a stateful Binding" $ withStrRef $ \out checkOut -> do+ let act = do+ out_elem <- head <$> show <$> unSB <$> State.get+ liftIO $ modifyIORef out (++ [out_elem])+ State.modify succ+ b = WB.binding' [(SIa, WB.Action "" act)]+ WB.boundInputs' b (SB 0) (SS "") `shouldBe` [SIa]+ WB.boundInputs' b (SB 10) (SS "hoge") `shouldBe` [SIa]+ void $ inputAll (WB.startFrom (SB 0) b) (SS "") $ replicate 12 SIa+ checkOut "012345678911"+ it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do+ let b = WB.startFrom (SB 0) $ WB.binding' [ outOn out SIa '1',+ outOn out SIa '2',+ outOn out SIa '3'+ ]+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "3"+ it "can create a stateful Binding with different bound inputs for different back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ State.put $ WB.startFrom (SB 0)+ $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' (\_ -> SB 1)])+ $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb 'B' (\_ -> SB 2)])+ $ WB.ifBack (== (SB 2)) (WB.binding' [outOnS out SIc 'C' (\_ -> SB 0)])+ $ mempty+ checkOut ""+ checkInputsS (SS "") [SIa]+ execAll (SS "") [SIa]+ checkOut "A"+ checkInputsS (SS "") [SIb]+ execAll (SS "") [SIb]+ checkOut "AB"+ checkInputsS (SS "") [SIc]+ execAll (SS "") [SIc]+ checkOut "ABC"+ checkInputsS (SS "") [SIa]+ describe "Binding (mappend, stateful)" $ do+ it "shares the explicit back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let b1 = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' (\_ -> SB 1)])+ $ WB.ifBack (== (SB 1)) ( WB.binding' [outOnS out SIb 'B' (\_ -> SB 2),+ outOnS out SIc 'b' (\_ -> SB 2)]+ )+ $ WB.ifBack (== (SB 2)) (WB.binding' [outOnS out SIc 'C' (\_ -> SB 0)])+ $ mempty+ b2 = WB.whenBack (== (SB 1)) $ WB.binding' [outOnS out SIb 'D' (\_ -> SB 0)]+ b = b1 <> b2+ State.put $ WB.startFrom (SB 0) b+ checkInputsS (SS "") [SIa]+ execAll (SS "") [SIa]+ checkOut "A"+ checkInputsS (SS "") [SIb, SIc]+ execAll (SS "") [SIb]+ checkOut "AD"+ checkInputsS (SS "") [SIa]+ execAll (SS "") [SIa, SIc]+ checkOut "ADAb"+ checkInputsS (SS "") [SIc]+ execAll (SS "") [SIc]+ checkOut "ADAbC"+ checkInputsS (SS "") [SIa]+ + describe "ifBack" $ do+ it "chooses from unconditional bindings" $ withStrRef $ \out checkOut -> do+ let b = WB.ifBack (\(SB sb) -> sb < 5)+ (WB.binding [outOn out SIa 'A']) (WB.binding [outOn out SIb 'B'])+ ba = WB.startFrom (SB 4) b+ bb = WB.startFrom (SB 5) b+ WB.boundInputs ba (SS "") `shouldMatchList` [SIa]+ actRun $ WB.boundAction ba (SS "") SIa+ checkOut "A"+ WB.boundInputs bb (SS "") `shouldMatchList` [SIb]+ actRun $ WB.boundAction bb (SS "") SIb+ checkOut "AB"+ it "combines an extended stateless binding with a stateful binding" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let b_stateless = WB.binding [outOn out SIa 'A']+ b = WB.ifBack (\(SB sb) -> sb < 5)+ (b_stateless <> WB.binding' [outOnS out SIb 'B' $ const (SB 10)])+ $ WB.binding' [outOnS out SIc 'C' $ const (SB 3)]+ State.put $ WB.startFrom (SB 0) b+ checkInputsS' [SIa, SIb]+ execAll' [SIa]+ checkOut "A"+ checkInputsS' [SIa, SIb]+ execAll' [SIb]+ checkOut "AB"+ checkInputsS' [SIc]+ execAll' [SIc]+ checkOut "ABC"+ checkInputsS' [SIa, SIb]+ it "combines implicit stateful binding with a binding with newly introduced states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let b1 = WB.startFrom (SB 0)+ $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' $ const (SB 1)])+ $ WB.binding' [outOnS out SIb 'B' $ const (SB 0)]+ b = WB.startFrom (SB 0)+ $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'a' $ const (SB 1)])+ $ WB.extend b1 <> WB.binding' [outOnS out SIc 'c' $ const (SB 0)]+ State.put b+ checkInputsS' [SIa]+ execAll' [SIa]+ checkOut "a"+ checkInputsS' [SIa, SIc]+ execAll' [SIa]+ checkOut "aA"+ checkInputsS' [SIb, SIc]+ execAll' [SIb]+ checkOut "aAB"+ checkInputsS' [SIa, SIc]+ execAll' [SIc]+ checkOut "aABc"+ checkInputsS' [SIa]++ describe "whenBack" $ do+ it "adds a condition to the back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let raw_b = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa '0' (\_ -> SB 1)])+ $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb '1' (\_ -> SB 0)])+ $ mempty+ b = WB.whenBack (== SB 0) $ raw_b+ State.put $ WB.startFrom (SB 0) b+ checkInputsS' [SIa]+ execAll' [SIa]+ checkOut "0"+ checkInputsS' []++spec_extend :: Spec+spec_extend = do+ describe "extend" $ do+ it "extends a stateless Binding" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let bl :: WB.Binding SampleState SampleInput+ bl = WB.binding [+ outOn out SIa 'a',+ outOn out SIb 'b',+ outOn out SIc 'c']+ bs = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' (\_ -> SB 1)])+ $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb 'B' (\_ -> SB 2)])+ $ WB.ifBack (== (SB 2)) (WB.binding' [outOnS out SIc 'C' (\_ -> SB 0)])+ $ mempty+ State.put $ WB.startFrom (SB 0) $ (WB.extend bl <> bs)+ checkInputsS' [SIa, SIb, SIc]+ execAll' [SIb, SIc, SIa]+ checkOut "bcA"+ checkInputsS' [SIa, SIb, SIc]+ execAll' [SIa, SIc, SIb]+ checkOut "bcAacB"+ checkInputsS' [SIa, SIb, SIc]+ execAll' [SIa, SIb, SIc]+ checkOut "bcAacBabC"++spec_conditionBoth :: Spec+spec_conditionBoth = do+ describe "ifBoth" $ do+ it "chooses bindings according to front-end and back-end states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let b = WB.ifBoth (\ _ (SS fs) -> fs == "hoge") ( WB.binding' [ outOnS out SIa 'a' (SB . succ . unSB),+ outOnS out SIb 'b' (const $ SB 0)+ ]+ )+ $ WB.ifBoth (\ (SB bs) (SS fs) -> length fs < bs)+ (WB.binding' [ outOnS out SIc 'c' (SB . pred . unSB) ])+ (WB.binding' [ outOnS out SIb 'B' (SB . succ . unSB) ])+ State.put $ WB.startFrom (SB 10) $ b+ checkInputsS (SS "hoge") [SIa, SIb]+ checkInputsS (SS "") [SIc]+ checkInputsS (SS "foooooobaaaaaa") [SIb]+ execAll (SS "hoge") [SIb]+ checkOut "b"+ checkInputsS (SS "") [SIb]+ execAll (SS "") [SIb]+ checkOut "bB"+ checkInputsS (SS "hoge") [SIa, SIb]+ checkInputsS (SS "") [SIc]+ checkInputsS (SS "a") [SIb]+ execAll (SS "") [SIc]+ checkOut "bBc"+ checkInputsS (SS "hoge") [SIa, SIb]+ checkInputsS (SS "") [SIb]+ checkInputsS (SS "a") [SIb]+ execAll (SS "hoge") $ replicate 5 SIa+ checkOut "bBcaaaaa"+ checkInputsS (SS "hoge") [SIa, SIb]+ checkInputsS (SS "fooo") [SIc]+ checkInputsS (SS "foooo") [SIb]+ + describe "whenBoth" $ do+ let incr' out ret = outOnS out SIa ret (\(SB num) -> SB (num + 1))+ decr' out ret = outOnS out SIb ret (\(SB num) -> SB (num - 1))+ it "adds a condition to both front-end and back-end states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let incr = incr' out+ decr = decr' out+ raw_b = WB.ifBack (== (SB 0)) (WB.binding' [incr '+']) (WB.binding' [incr '+', decr '-'])+ b = WB.whenBoth (\(SB num) (SS str) -> length str == num) $ raw_b+ State.put $ WB.startFrom (SB 0) $ b+ checkInputsS (SS "hoge") []+ checkInputsS (SS "") [SIa]+ execAll (SS "") [SIa]+ checkOut "+"+ checkInputsS (SS "") []+ checkInputsS (SS "e") [SIa, SIb]+ execAll (SS "e") [SIa]+ checkOut "++"+ checkInputsS (SS "e") []+ checkInputsS (SS "eg") [SIa, SIb]+ execAll (SS "eg") [SIb]+ checkOut "++-"+ checkInputsS (SS "e") [SIa, SIb]+ it "creates independent conditions when combined with <>" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ let incr = incr' out+ decr = decr' out+ bn = WB.ifBack (== (SB 0)) (WB.binding' [incr '+']) (WB.binding' [incr '+', decr '-'])+ bn' = WB.whenBoth (\(SB num) (SS str) -> length str == num) bn+ ba = WB.ifBack (== (SB 0)) (WB.binding' [incr 'p']) (WB.binding' [incr 'p', decr 'm'])+ ba' = WB.whenBoth (\(SB num) (SS str) -> read str == num) ba+ State.put $ WB.startFrom (SB 1) (bn' <> ba')+ checkInputsS (SS "10") []+ checkInputsS (SS "4") [SIa, SIb]+ execAll (SS "4") [SIa]+ checkOut "+"+ checkInputsS (SS "2") [SIa, SIb]+ execAll (SS "2") [SIa]+ checkOut "+p"+ checkInputsS (SS "342") [SIa, SIb]+ execAll (SS "342") [SIb]+ checkOut "+p-"+ execAll (SS "2") [SIb]+ checkOut "+p-m"+ checkInputsS (SS "1") [SIa, SIb]+ execAll (SS "1") [SIb]+ checkOut "+p-mm"+ +spec_monadic :: Spec+spec_monadic = describe "Monadic construction of Binding" $ do+ describe "binds" $ do+ it "constructs stateless Binding" $ withStrRef $ \out checkOut -> do+ let putOut c = modifyIORef out (++ [c])+ b = WB.binds $ do+ WB.on SIa `WB.run` putOut 'a'+ WB.on SIb `WB.run` do+ putOut 'b'+ putOut 'B'+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "a"+ actRun $ WB.boundAction b (SS "") SIb+ checkOut "abB"+ it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do+ let b = WB.binds $ do+ WB.on SIa `WB.run` modifyIORef out (++ "1")+ WB.on SIa `WB.run` modifyIORef out (++ "2")+ WB.on SIa `WB.run` modifyIORef out (++ "3")+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "3"+ describe "Binder" $ do+ it "can bind actions with different result types" $ withStrRef $ \out checkOut -> do+ let ret_b :: String+ ret_b = "return by b"+ b = WB.binds $ do -- it's ok if it compiles..+ WB.on SIa `WB.run` do+ modifyIORef out (++ "a")+ return ()+ WB.on SIb `WB.run` do+ modifyIORef out (++ "b")+ return ret_b+ actRun $ WB.boundAction b (SS "") SIb+ checkOut "b"+ describe "binds'" $ do+ it "constructs stateful Binding" $ evalStateEmpty $ withStrRef $ \out checkOut -> do+ State.put $ WB.startFrom (SB 0) $ WB.binds' $ do+ WB.on SIa `WB.run` (State.modify $ \(SB v) -> SB (v + 1))+ WB.on SIb `WB.run` (State.modify $ \(SB v) -> SB (v - 1))+ WB.on SIc `WB.run` do+ (SB cur) <- State.get+ liftIO $ modifyIORef out (++ show cur)+ execAll' [SIa, SIa, SIa]+ checkOut ""+ execAll' [SIc]+ checkOut "3"+ execAll' [SIb, SIb]+ checkOut "3"+ execAll' [SIc]+ checkOut "31"+ it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do+ let b = WB.startFrom (SB 0) $ WB.binds' $ do+ WB.on SIa `WB.run` (liftIO $ modifyIORef out (++ "1"))+ WB.on SIa `WB.run` (liftIO $ modifyIORef out (++ "2"))+ WB.on SIa `WB.run` (liftIO $ modifyIORef out (++ "3"))+ actRun $ WB.boundAction b (SS "") SIa+ checkOut "3"+ describe "as" $ do+ it "sets ActionDescription" $ do+ let b = WB.binds $ do+ WB.on SIa `WB.as` "action for a" `WB.run` return ()+ WB.on SIb `WB.as` "action for b" `WB.run` return ()+ (WB.actDescription <$> WB.boundAction b (SS "") SIa) `shouldBe` Just "action for a"+ (WB.actDescription <$> WB.boundAction b (SS "") SIb) `shouldBe` Just "action for b"+ (WB.actDescription <$> WB.boundAction b (SS "") SIc) `shouldBe` Nothing+
+ test/WildBind/ExecSpec.hs view
@@ -0,0 +1,234 @@+module WildBind.ExecSpec (main, spec) where++import Control.Applicative ((<$>))+import Control.Concurrent (forkIOWithUnmask, killThread, threadDelay)+import Control.Concurrent.STM (atomically, TChan, readTChan, tryReadTChan, writeTChan, newTChanIO)+import Control.Exception (bracket, throw, fromException)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Control.Monad.Trans.State as State+import Data.Monoid ((<>))+import System.IO.Error (userError)+import Test.Hspec++import qualified WildBind.Binding as WBB+import qualified WildBind.Exec as WBE+import qualified WildBind.FrontEnd as WBF++import WildBind.ForTest (SampleInput(..), SampleState(..), SampleBackState(..))++newtype EventChan s i = EventChan { unEventChan :: TChan (WBF.FrontEvent s i) }++data GrabHistory i = GSet i | GUnset i deriving (Show, Eq, Ord)++newtype GrabChan i = GrabChan { unGrabChan :: TChan (GrabHistory i) }++frontEnd :: EventChan s i -> GrabChan i -> WBF.FrontEnd s i+frontEnd echan gchan = WBF.FrontEnd+ { WBF.frontDefaultDescription = const "",+ WBF.frontSetGrab = \i -> atomically $ writeTChan (unGrabChan gchan) (GSet i),+ WBF.frontUnsetGrab = \i -> atomically $ writeTChan (unGrabChan gchan) (GUnset i),+ WBF.frontNextEvent = atomically $ readTChan $ unEventChan echan+ }++_write :: MonadIO m => TChan a -> a -> m ()+_write tc = liftIO . atomically . writeTChan tc++outChanOn :: MonadIO m => TChan a -> i -> a -> (i, WBB.Action m ())+outChanOn out_chan input out_elem = (input, WBB.Action "" (out_chan `_write` out_elem))++outChanOnS :: TChan a -> i -> a -> bs -> (i, WBB.Action (State.StateT bs IO) ())+outChanOnS out_chan input out_elem next_state = (,) input $ WBB.Action "" $ do+ 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' exec action = do+ echan <- EventChan <$> newTChanIO+ gchan <- GrabChan <$> newTChanIO+ let spawnWildBind = forkIOWithUnmask $ \umask -> umask $ exec (frontEnd echan gchan)+ bracket spawnWildBind killThread (\_ -> action echan gchan)+ +withWildBind :: Ord i => WBB.Binding s i -> (EventChan s i -> GrabChan i -> IO ()) -> IO ()+withWildBind binding action = withWildBind' (WBE.wildBind binding) action++emitEvent :: TChan (WBF.FrontEvent s i) -> WBF.FrontEvent s i -> IO ()+emitEvent chan event = atomically $ writeTChan chan event++shouldProduce :: (Show a, Eq a) => TChan a -> a -> IO ()+shouldProduce chan expectation = (atomically $ readTChan chan) `shouldReturn` expectation++readAll :: TChan a -> IO [a]+readAll chan = atomically $ readAll' [] where+ readAll' acc = do+ mret <- tryReadTChan chan+ case mret of+ Nothing -> return (reverse acc)+ Just ret -> readAll' (ret : acc)++shouldNowMatch :: (Show a, Eq a) => TChan a -> [a] -> IO ()+shouldNowMatch chan expectation = readAll chan >>= (`shouldMatchList` expectation)++changeAndInput :: s -> i -> [WBF.FrontEvent s i]+changeAndInput s i = [WBF.FEChange s, WBF.FEInput i]++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ wildBindSpec+ optionSpec++wildBindSpec :: Spec+wildBindSpec = do+ describe "wildBind" $ do+ it "should enable input grabs" $ do+ ochan <- newTChanIO+ let b = WBB.binding [outChanOn ochan SIa 'A',+ outChanOn ochan SIb 'B']+ withWildBind b $ \(EventChan echan) (GrabChan gchan) -> do+ emitEvent echan $ WBF.FEChange $ SS ""+ emitEvent echan $ WBF.FEInput SIa+ ochan `shouldProduce` 'A'+ ghist <- readAll gchan+ ghist `shouldMatchList` [GSet SIa, GSet SIb]+ it "should enable/disable grabs when the front-end state changes" $ do+ ochan <- newTChanIO+ let b = (WBB.whenFront (\(SS s) -> s == "A") $ WBB.binding [outChanOn ochan SIa 'A'])+ <>+ (WBB.whenFront (\(SS s) -> s == "B") $ WBB.binding [outChanOn ochan SIb 'B'])+ <>+ (WBB.whenFront (\(SS s) -> s == "C") $ WBB.binding [outChanOn ochan SIc 'C'])+ withWildBind b $ \(EventChan echan) (GrabChan gchan) -> do+ mapM_ (emitEvent echan) $ changeAndInput (SS "A") SIa+ ochan `shouldProduce` 'A'+ gchan `shouldNowMatch` [GSet SIa]+ mapM_ (emitEvent echan) $ changeAndInput (SS "B") SIb+ ochan `shouldProduce` 'B'+ gchan `shouldNowMatch` [GUnset SIa, GSet SIb]+ mapM_ (emitEvent echan) $ changeAndInput (SS "C") SIc+ ochan `shouldProduce` 'C'+ gchan `shouldNowMatch` [GUnset SIb, GSet SIc]+ emitEvent echan $ WBF.FEChange (SS "")+ threadDelay 10000+ gchan `shouldNowMatch` [GUnset SIc]+ it "should enable/disable grabs when the back-end state changes" $ do+ ochan <- newTChanIO+ let b' = WBB.ifBack (== (SB 0)) (WBB.binding' [outChanOnS ochan SIa 'A' (SB 1)])+ $ WBB.whenBack (== (SB 1)) (WBB.binding' [outChanOnS ochan SIb 'B' (SB 0)])+ b = WBB.startFrom (SB 0) b'+ withWildBind b $ \(EventChan echan) (GrabChan gchan) -> do+ emitEvent echan $ WBF.FEChange (SS "")+ threadDelay 10000+ gchan `shouldNowMatch` [GSet SIa]+ emitEvent echan $ WBF.FEInput SIa+ ochan `shouldProduce` 'A'+ threadDelay 10000+ gchan `shouldNowMatch` [GUnset SIa, GSet SIb]+ emitEvent echan $ WBF.FEInput SIb+ ochan `shouldProduce` 'B'+ threadDelay 10000+ gchan `shouldNowMatch` [GUnset SIb, GSet SIa]+ it "should crush exceptions from bound actions" $ do+ ochan <- newTChanIO+ let b = WBB.binds $ do+ WBB.on SIa `WBB.run` (fail "ERROR!!")+ WBB.on SIb `WBB.run` (atomically $ writeTChan ochan 'b')+ withWildBind b $ \(EventChan echan) _ -> do+ emitEvent echan $ WBF.FEChange (SS "")+ emitEvent echan $ WBF.FEInput SIa+ emitEvent echan $ WBF.FEInput SIb+ ochan `shouldProduce` 'b'+ it "should keep the current back-state when exception is thrown from bound actions" $ do+ ochan <- newTChanIO+ let killing_b = WBB.binds' $ WBB.on SIa `WBB.run` do+ State.put (SB 0)+ liftIO $ fail "ERROR!"+ b = WBB.startFrom (SB 0) $ (killing_b <>)+ $ WBB.ifBack (== SB 0)+ ( WBB.binds' $ WBB.on SIb `WBB.run` do+ liftIO $ atomically $ writeTChan ochan 'b'+ State.put (SB 1)+ )+ ( WBB.binds' $ WBB.on SIc `WBB.run` do+ liftIO $ atomically $ writeTChan ochan 'c'+ State.put (SB 0)+ )+ withWildBind b $ \(EventChan echan) (GrabChan gchan) -> do+ emitEvent echan $ WBF.FEChange (SS "")+ emitEvent echan $ WBF.FEInput SIa+ emitEvent echan $ WBF.FEInput SIb+ ochan `shouldProduce` 'b'+ gchan `shouldNowMatch` [GSet SIa, GSet SIb, GUnset SIb, GSet SIc]+ emitEvent echan $ WBF.FEInput SIa+ emitEvent echan $ WBF.FEInput SIc+ ochan `shouldProduce` 'c'+ gchan `shouldNowMatch` [GUnset SIc, GSet SIb]+++shouldNextMatch :: (Show a, Eq a) => TChan [a] -> [a] -> IO ()+shouldNextMatch tc expected = do+ got <- atomically $ readTChan tc+ got `shouldMatchList` expected++optionSpec :: Spec+optionSpec = do+ describe "optBindingHook" $ do+ it "hooks change of binding because front-end state changes" $ do+ hook_chan <- newTChanIO+ out_chan <- newTChanIO+ let opt = WBE.defOption { WBE.optBindingHook = _write hook_chan }+ b = WBB.whenFront (== SS "hoge")+ $ WBB.binding [ (SIa, WBB.Action "a button" (out_chan `_write` 'a')),+ (SIb, WBB.Action "b button" (out_chan `_write` 'b'))+ ]+ withWildBind' (WBE.wildBind' opt b) $ \(EventChan echan) (GrabChan gchan) -> do+ emitEvent echan $ WBF.FEChange (SS "hoge")+ hook_chan `shouldNextMatch` [(SIa, "a button"), (SIb, "b button")]+ emitEvent echan $ WBF.FEInput SIa+ hook_chan `shouldNextMatch` [(SIa, "a button"), (SIb, "b button")]+ out_chan `shouldProduce` 'a'+ gchan `shouldNowMatch` [GSet SIa, GSet SIb]+ emitEvent echan $ WBF.FEChange (SS "")+ hook_chan `shouldNextMatch` []+ gchan `shouldNowMatch` [GUnset SIa, GUnset SIb]+ it "hooks change of binding because back-end state changes" $ do+ hook_chan <- newTChanIO+ out_chan <- newTChanIO+ let opt = WBE.defOption { WBE.optBindingHook = _write hook_chan }+ b = WBB.startFrom (SB 0)+ $ WBB.ifBack (== (SB 0))+ (WBB.binding' [(SIa, WBB.Action "a button" (out_chan `_write` 'a' >> State.put (SB 1)))])+ $ WBB.whenBack (== (SB 1)) ( WBB.binding' [(SIa, WBB.Action "A BUTTON" (out_chan `_write` 'A' >> State.put (SB 0))),+ (SIc, WBB.Action "c button" (out_chan `_write` 'c'))]+ )+ withWildBind' (WBE.wildBind' opt b) $ \(EventChan echan) (GrabChan gchan) -> do+ emitEvent echan $ WBF.FEChange (SS "")+ hook_chan `shouldNextMatch` [(SIa, "a button")]+ gchan `shouldNowMatch` [GSet SIa]+ emitEvent echan $ WBF.FEInput SIa+ out_chan `shouldProduce` 'a'+ hook_chan `shouldNextMatch` [(SIa, "A BUTTON"), (SIc, "c button")]+ gchan `shouldNowMatch` [GSet SIc]+ emitEvent echan $ WBF.FEInput SIc+ out_chan `shouldProduce` 'c'+ hook_chan `shouldNextMatch` [(SIa, "A BUTTON"), (SIc, "c button")]+ gchan `shouldNowMatch` []+ emitEvent echan $ WBF.FEInput SIa+ out_chan `shouldProduce` 'A'+ hook_chan `shouldNextMatch` [(SIa, "a button")]+ gchan `shouldNowMatch` [GUnset SIc]+ describe "optCatch" $ do+ it "receives front-state, input and exception" $ do+ hook_chan <- newTChanIO+ let catcher fs input err = atomically $ writeTChan hook_chan (fs, input, err)+ opt = WBE.defOption { WBE.optCatch = catcher }+ b = WBB.binds $ WBB.on SIa `WBB.run` (throw $ userError "BOOM!")+ withWildBind' (WBE.wildBind' opt b) $ \(EventChan echan) _ -> do+ emitEvent echan $ WBF.FEChange (SS "front state")+ emitEvent echan $ WBF.FEInput SIa+ (got_state, got_input, got_exception) <- atomically $ readTChan hook_chan+ got_state `shouldBe` SS "front state"+ got_input `shouldBe` SIa+ fromException got_exception `shouldBe` Just (userError "BOOM!")+
+ test/WildBind/ForTest.hs view
@@ -0,0 +1,30 @@+module WildBind.ForTest+ ( SampleInput(..),+ SampleState(..),+ SampleBackState(..)+ ) where++import Control.Applicative ((<$>))+import Test.QuickCheck (Arbitrary(arbitrary,shrink), arbitraryBoundedEnum)++data SampleInput = SIa | SIb | SIc+ deriving (Show, Eq, Ord, Enum, Bounded)++instance Arbitrary SampleInput where+ arbitrary = arbitraryBoundedEnum++data SampleState = SS { unSS :: String }+ deriving (Show, Eq, Ord)++instance Arbitrary SampleState where+ arbitrary = SS <$> arbitrary+ shrink (SS s) = SS <$> shrink s+++data SampleBackState = SB { unSB :: Int }+ deriving (Show, Eq, Ord)++instance Enum SampleBackState where+ toEnum = SB+ fromEnum = unSB+
+ wild-bind.cabal view
@@ -0,0 +1,62 @@+name: wild-bind+version: 0.1.0.0+author: Toshio Ito <debug.ito@gmail.com>+maintainer: Toshio Ito <debug.ito@gmail.com>+license: BSD3+license-file: LICENSE+synopsis: Dynamic key binding framework+description: Dynamic key binding framework. See https://github.com/debug-ito/wild-bind+category: UserInterface+cabal-version: >= 1.10+build-type: Simple+extra-source-files: README.md, ChangeLog.md+homepage: https://github.com/debug-ito/wild-bind+bug-reports: https://github.com/debug-ito/wild-bind/issues++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -fno-warn-unused-imports+ default-extensions: RankNTypes OverloadedStrings+ other-extensions: GeneralizedNewtypeDeriving+ exposed-modules: WildBind,+ WildBind.Binding,+ WildBind.FrontEnd,+ WildBind.Description,+ WildBind.Exec,+ WildBind.Input.NumPad+ -- other-modules: + build-depends: base >=4.6 && <5.0,+ text >=1.2.0 && <1.3,+ containers >=0.5.0 && <0.6,+ transformers >=0.3.0 && <0.6++-- executable wild-bind+-- default-language: Haskell2010+-- hs-source-dirs: src+-- main-is: Main.hs+-- ghc-options: -Wall -fno-warn-unused-imports+-- -- other-modules: +-- -- other-extensions: +-- build-depends: base >=4 && <5++test-suite spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ 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-modules: WildBind.ExecSpec,+ WildBind.BindingSpec+ WildBind.ForTest+ build-depends: base, wild-bind, transformers,+ hspec >=2.1.7 && <2.3,+ QuickCheck >=2.6 && <3.0,+ stm >=2.4.2 && <2.5,+ microlens >=0.2.0 && <0.5++source-repository head+ type: git+ location: https://github.com/debug-ito/wild-bind.git