{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, OverloadedStrings #-}
module WildBind.Binding
(
Action(Action,actDescription,actDo),
Binding,
Binding',
noBinding,
Binder,
binds,
binds',
bindsF,
bindsF',
on,
run,
as,
binding,
binding',
bindingF,
bindingF',
ifFront,
ifBack,
ifBoth,
whenFront,
whenBack,
whenBoth,
startFrom,
extend,
convFront,
convInput,
convBack,
advice,
revise,
revise',
before,
after,
justBefore,
justAfter,
boundAction,
boundAction',
boundActions,
boundActions',
boundInputs,
boundInputs'
) where
import Control.Applicative (Applicative, (<*), (*>))
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))
import Data.Semigroup (Semigroup(..))
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 }
justBefore :: (Applicative m) => m b -> Action m a -> Maybe (Action m a)
justBefore m a = Just $ before m a
justAfter :: (Applicative m) => m b -> Action m a -> Maybe (Action m a)
justAfter m a = Just $ after m a
type SRIM bs fs = StateT bs (ReaderT fs IO)
newtype Binding' bs fs i =
Binding'
{ 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)
type Binding s i = Binding' () s i
instance Ord i => Semigroup (Binding' bs fs i) where
abind <> bbind = Binding' $ \bs fs ->
let amap = mapActResult (<> bbind) $ unBinding' abind bs fs
bmap = mapActResult (abind <>) $ unBinding' bbind bs fs
in M.unionWith (\_ b -> b) amap bmap
instance Ord i => Monoid (Binding' bs fs i) where
mempty = noBinding
mappend = (<>)
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 = (fmap . mapActDo) (runSRIM bs fs) $ 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 = map convertAction $ M.toList $ unBinding' b bs fs
where
convertAction (i, act) = (i, mapActDo (runSRIM bs fs) act)
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 []
bindsF :: Ord i => Binder i (Action (ReaderT fs IO) r) a -> Binding' bs fs i
bindsF = bindingF . flip runBinder []
binds' :: Ord i => Binder i (Action (StateT bs IO) r) a -> Binding' bs fs i
binds' = binding' . flip runBinder []
bindsF' :: Ord i => Binder i (Action (StateT bs (ReaderT fs IO)) r) a -> Binding' bs fs i
bindsF' = bindingF' . 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)
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
binding :: Ord i => [(i, Action IO r)] -> Binding' bs fs i
binding = statelessBinding . fmap liftActionR . M.fromList
bindingF :: Ord i => [(i, Action (ReaderT fs IO) r)] -> Binding' bs fs i
bindingF = statelessBinding . M.fromList
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 mapActResult (\nextb -> ifBoth p nextb elseb) $ unBinding' thenb bs fs
else mapActResult (\nextb -> ifBoth p thenb nextb) $ 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
convFront :: (fs -> fs') -> Binding' bs fs' i -> Binding' bs fs i
convFront cmapper orig_bind = Binding' $ \bs fs ->
mapActResult (convFront cmapper) $ fmap (withActionR cmapper) $ 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 ->
mapActResult (convInput mapper) $ 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 ->
(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')
startFrom :: bs
-> Binding' bs fs i
-> Binding fs i
startFrom init_state b' = Binding' $ \() 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'
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 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' = statefulBinding . fmap addR . M.fromList where
addR = mapActDo $ mapStateT lift
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 :: (forall a . bs -> fs -> i -> Action IO a -> Maybe (Action 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 (runSRIM bs fs) orig_act
convertResult = fmap reviseThis . mapActDo redoSRIM
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