module WildBind.Binding
(
Action(Action,actDescription,actDo),
Binding,
Binding',
noBinding,
Binder,
binds,
binds',
on,
run,
as,
binding,
binding',
ifFront,
ifBack,
ifBoth,
whenFront,
whenBack,
whenBoth,
advice,
before,
after,
startFrom,
extend,
convFront,
convInput,
convBack,
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)
data Action m a =
Action
{ actDescription :: ActionDescription,
actDo :: m a
}
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) }
before :: (Applicative m)
=> m b
-> Action m a
-> Action m a
before hook act = act { actDo = hook *> actDo act }
after :: (Applicative m)
=> m b
-> Action m a
-> Action m a
after hook act = act { actDo = actDo act <* hook }
newtype Binding' bs fs i =
Binding'
{ unBinding' :: bs -> fs -> M.Map i (Action IO (Binding' bs fs i, bs))
}
type Binding s i = Binding' () s i
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
noBinding :: Binding' bs fs i
noBinding = Binding' $ \_ _ -> M.empty
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
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
boundActions :: Binding s i -> s -> [(i, Action IO (Binding s i))]
boundActions b state = fmap (\(i, act) -> (i, fmap fst act)) $ boundActions' b () state
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
boundInputs :: Binding s i -> s -> [i]
boundInputs b s = fmap fst $ boundActions b s
boundInputs' :: Binding' bs fs i -> bs -> fs -> [i]
boundInputs' b bs fs = fmap fst $ boundActions' b bs fs
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
binds :: Ord i => Binder i (Action IO r) a -> Binding' bs fs i
binds = binding . flip runBinder []
binds' :: Ord i => Binder i (Action (StateT bs IO) r) a -> Binding' bs fs i
binds' = binding' . flip runBinder []
on :: i -> v -> Binder i v ()
on i v = Binder $ tell $ Endo ((i,v) :)
run :: Functor m => (Action m () -> b) -> m a -> b
run cont raw_act = cont $ Action { actDescription = "", actDo = fmap (const ()) raw_act }
infixl 2 `run`
as :: (Action m a -> b) -> ActionDescription -> Action m a -> b
as cont desc act = cont $ act { actDescription = desc }
infixl 2 `as`
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)
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
ifFront :: (fs -> Bool)
-> Binding' bs fs i
-> Binding' bs fs i
-> Binding' bs fs i
ifFront p = ifBoth $ \_ fs -> p fs
ifBack :: (bs -> Bool)
-> Binding' bs fs i
-> Binding' bs fs i
-> Binding' bs fs i
ifBack p = ifBoth $ \bs _ -> p bs
ifBoth :: (bs -> fs -> Bool)
-> Binding' bs fs i
-> Binding' bs fs i
-> 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
whenFront :: (fs -> Bool)
-> Binding' bs fs i
-> Binding' bs fs i
whenFront p = whenBoth $ \_ fs -> p fs
whenBack :: (bs -> Bool)
-> Binding' bs fs i
-> Binding' bs fs i
whenBack p = whenBoth $ \bs _ -> p bs
whenBoth :: (bs -> fs -> Bool)
-> Binding' bs fs i
-> 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))
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)
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
convBack :: (bs -> bs' -> bs')
-> (bs' -> 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
startFrom :: bs
-> Binding' bs fs i
-> Binding fs i
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 fs i -> Binding' bs fs i
extend = convBack (const id) (const ())
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)