module Yi.Interact
(
I, P (Chain,End),
InteractState (..),
MonadInteract (..),
deprioritize,
important,
(<||),
(||>),
option,
oneOf,
processOneEvent,
computeState,
event,
events,
choice,
mkAutomaton, idAutomaton,
runWrite,
anyEvent,
eventBetween,
accepted
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Lens
import Control.Monad.State hiding ( get, mapM )
import Data.Function (on)
import Data.List (groupBy)
import Data.Monoid
import qualified Data.Text as T
class (Eq w, Monad m, Alternative m, Applicative m, MonadPlus m) => MonadInteract m w e | m -> w e where
write :: w -> m ()
eventBounds :: Ord e => Maybe e -> Maybe e -> m e
adjustPriority :: Int -> m ()
instance MonadInteract m w e => MonadInteract (StateT s m) w e where
write = lift . write
eventBounds l h = lift (eventBounds l h)
adjustPriority p = lift (adjustPriority p)
data I ev w a where
Returns :: a -> I ev w a
Binds :: I ev w a -> (a -> I ev w b) -> I ev w b
Gets :: Ord ev => Maybe ev -> Maybe ev -> I ev w ev
Fails :: I ev w a
Writes :: w -> I ev w ()
Priority :: Int -> I ev w ()
Plus :: I ev w a -> I ev w a -> I ev w a
instance Functor (I event w) where
fmap f i = pure f <*> i
instance Applicative (I ev w) where
pure = return
a <*> b = do f <- a; x <- b; return (f x)
instance Alternative (I ev w) where
empty = Fails
(<|>) = Plus
instance Monad (I event w) where
return = Returns
fail _ = Fails
(>>=) = Binds
instance Eq w => MonadPlus (I event w) where
mzero = Fails
mplus = Plus
instance Eq w => MonadInteract (I event w) w event where
write = Writes
eventBounds = Gets
adjustPriority = Priority
infixl 3 <||
deprioritize :: (MonadInteract f w e) => f ()
deprioritize = adjustPriority 1
(<||), (||>) :: (MonadInteract f w e) => f a -> f a -> f a
a <|| b = a <|> (deprioritize >> b)
(||>) = flip (<||)
important :: MonadInteract f w e => f a -> f a -> f a
important a b = a <|| b
mkProcess :: Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess (Returns x) = \fut -> fut x
mkProcess Fails = const Fail
mkProcess (m `Binds` f) = \fut -> mkProcess m (\a -> mkProcess (f a) fut)
mkProcess (Gets l h) = Get l h
mkProcess (Writes w) = \fut -> Write w (fut ())
mkProcess (Priority p) = \fut -> Prior p (fut ())
mkProcess (Plus a b) = \fut -> Best (mkProcess a fut) (mkProcess b fut)
data P event w
= Ord event => Get (Maybe event) (Maybe event) (event -> P event w)
| Fail
| Write w (P event w)
| Prior Int (P event w)
| Best (P event w) (P event w)
| End
| forall mid. (Show mid, Eq mid) => Chain (P event mid) (P mid w)
accepted :: (Show ev) => Int -> P ev w -> [[T.Text]]
accepted 0 _ = [[]]
accepted d (Get (Just low) (Just high) k) = do
t <- accepted (d 1) (k low)
let h = if low == high
then showT low
else showT low `T.append` ".." `T.append` showT high
return (h : t)
accepted _ (Get Nothing Nothing _) = [["<any>"]]
accepted _ (Get Nothing (Just e) _) = [[".." `T.append` showT e]]
accepted _ (Get (Just e) Nothing _) = [[showT e `T.append` ".."]]
accepted _ Fail = []
accepted _ (Write _ _) = [[]]
accepted d (Prior _ p) = accepted d p
accepted d (Best p q) = accepted d p ++ accepted d q
accepted _ End = []
accepted _ (Chain _ _) = error "accepted: chain not supported"
showT :: Show a => a -> T.Text
showT = T.pack . show
runWrite :: Eq w => P event w -> [event] -> [w]
runWrite _ [] = []
runWrite p (c:cs) = let (ws, p') = processOneEvent p c in ws ++ runWrite p' cs
processOneEvent :: Eq w => P event w -> event -> ([w], P event w)
processOneEvent p e = pullWrites $ pushEvent p e
pushEvent :: P ev w -> ev -> P ev w
pushEvent (Best c d) e = Best (pushEvent c e) (pushEvent d e)
pushEvent (Write w c) e = Write w (pushEvent c e)
pushEvent (Prior p c) e = Prior p (pushEvent c e)
pushEvent (Get l h f) e = if test (e >=) l && test (e <=) h then f e else Fail
where test = maybe True
pushEvent Fail _ = Fail
pushEvent End _ = End
pushEvent (Chain p q) e = Chain (pushEvent p e) q
data InteractState event w = Ambiguous [(Int,w,P event w)] | Waiting | Dead | Running w (P event w)
instance Monoid (InteractState event w) where
mappend (Running w c) _ = Running w c
mappend _ (Running w c) = Running w c
mappend Dead p = p
mappend p Dead = p
mappend Waiting _ = Waiting
mappend _ Waiting = Waiting
mappend (Ambiguous a) (Ambiguous b) = Ambiguous (a ++ b)
mempty = Ambiguous []
findWrites :: Int -> P event w -> InteractState event w
findWrites p (Best c d) = findWrites p c `mappend` findWrites p d
findWrites p (Write w c) = Ambiguous [(p,w,c)]
findWrites p (Prior dp c) = findWrites (p+dp) c
findWrites _ Fail = Dead
findWrites _ End = Dead
findWrites _ (Get{}) = Waiting
findWrites p (Chain a b) = case computeState a of
Dead -> Dead
Ambiguous _ -> Dead
Running w c -> findWrites p (Chain c (pushEvent b w))
Waiting -> case findWrites p b of
Ambiguous choices -> Ambiguous [(p',w',Chain a c') | (p',w',c') <- choices]
Running w' c' -> Running w' (Chain a c')
Dead -> Dead
Waiting -> Waiting
computeState :: Eq w => P event w -> InteractState event w
computeState a = case findWrites 0 a of
Ambiguous actions ->
let prior = minimum $ map (view _1) actions
bests = groupBy ((==) `on` view _2) $
filter ((prior ==) . view _1) actions
in case bests of
[(_,w,c):_] -> Running w c
_ -> Ambiguous $ map head bests
s -> s
pullWrites :: Eq w => P event w -> ([w], P event w)
pullWrites a = case computeState a of
Running w c -> first (w:) (pullWrites c)
_ -> ([], a)
instance (Show w, Show ev) => Show (P ev w) where
show (Get Nothing Nothing _) = "?"
show (Get (Just l) (Just h) _p) | l == h = show l
show (Get l h _) = maybe "" show l ++ ".." ++ maybe "" show h
show (Prior p c) = ":" ++ show p ++ show c
show (Write w c) = "!" ++ show w ++ "->" ++ show c
show (End) = "."
show (Fail) = "*"
show (Best p q) = "{" ++ show p ++ "|" ++ show q ++ "}"
show (Chain a b) = show a ++ ">>>" ++ show b
oneOf :: (Ord event, MonadInteract m w event) => [event] -> m event
oneOf s = choice $ map event s
anyEvent :: (Ord event, MonadInteract m w event) => m event
anyEvent = eventBounds Nothing Nothing
eventBetween :: (Ord e, MonadInteract m w e) => e -> e -> m e
eventBetween l h = eventBounds (Just l) (Just h)
event :: (Ord event, MonadInteract m w event) => event -> m event
event e = eventBetween e e
events :: (Ord event, MonadInteract m w event) => [event] -> m [event]
events = mapM event
choice :: (MonadInteract m w e) => [m a] -> m a
choice [] = fail "No choice succeeds"
choice [p] = p
choice (p:ps) = p `mplus` choice ps
option :: (MonadInteract m w e) => a -> m a -> m a
option x p = p `mplus` return x
mkAutomaton :: Eq w => I ev w a -> P ev w
mkAutomaton i = mkProcess i (const End)
idAutomaton :: (Ord a, Eq a) => P a a
idAutomaton = Get Nothing Nothing $ \e -> Write e idAutomaton