{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK show-extensions #-}
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 (Alternative ((<|>), empty))
import Control.Arrow (first)
import Lens.Micro.Platform (_1, _2, view)
import qualified Control.Monad.Fail as Fail
import Control.Monad.State (MonadPlus (..), MonadTrans (lift), StateT)
import Data.Function (on)
import Data.List (groupBy)
import qualified Data.Text as T (Text, append, pack)
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 :: w -> StateT s m ()
write = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ()) -> (w -> m ()) -> w -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall (m :: * -> *) w e. MonadInteract m w e => w -> m ()
write
eventBounds :: Maybe e -> Maybe e -> StateT s m e
eventBounds l :: Maybe e
l h :: Maybe e
h = m e -> StateT s m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe e -> Maybe e -> m e
forall (m :: * -> *) w e.
(MonadInteract m w e, Ord e) =>
Maybe e -> Maybe e -> m e
eventBounds Maybe e
l Maybe e
h)
adjustPriority :: Int -> StateT s m ()
adjustPriority p :: Int
p = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> m ()
forall (m :: * -> *) w e. MonadInteract m w e => Int -> m ()
adjustPriority Int
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 :: (a -> b) -> I event w a -> I event w b
fmap f :: a -> b
f i :: I event w a
i = (a -> b) -> I event w (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f I event w (a -> b) -> I event w a -> I event w b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> I event w a
i
instance Applicative (I ev w) where
pure :: a -> I ev w a
pure = a -> I ev w a
forall (m :: * -> *) a. Monad m => a -> m a
return
a :: I ev w (a -> b)
a <*> :: I ev w (a -> b) -> I ev w a -> I ev w b
<*> b :: I ev w a
b = do a -> b
f <- I ev w (a -> b)
a; a
x <- I ev w a
b; b -> I ev w b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
x)
instance Alternative (I ev w) where
empty :: I ev w a
empty = I ev w a
forall ev w a. I ev w a
Fails
<|> :: I ev w a -> I ev w a -> I ev w a
(<|>) = I ev w a -> I ev w a -> I ev w a
forall ev w a. I ev w a -> I ev w a -> I ev w a
Plus
instance Monad (I event w) where
return :: a -> I event w a
return = a -> I event w a
forall a ev w. a -> I ev w a
Returns
>>= :: I event w a -> (a -> I event w b) -> I event w b
(>>=) = I event w a -> (a -> I event w b) -> I event w b
forall event w a b.
I event w a -> (a -> I event w b) -> I event w b
Binds
#if (!MIN_VERSION_base(4,13,0))
fail _ = Fails
#endif
instance Fail.MonadFail (I event w) where
fail :: String -> I event w a
fail _ = I event w a
forall ev w a. I ev w a
Fails
instance Eq w => MonadPlus (I event w) where
mzero :: I event w a
mzero = I event w a
forall ev w a. I ev w a
Fails
mplus :: I event w a -> I event w a -> I event w a
mplus = I event w a -> I event w a -> I event w a
forall ev w a. I ev w a -> I ev w a -> I ev w a
Plus
instance Eq w => MonadInteract (I event w) w event where
write :: w -> I event w ()
write = w -> I event w ()
forall w ev. w -> I ev w ()
Writes
eventBounds :: Maybe event -> Maybe event -> I event w event
eventBounds = Maybe event -> Maybe event -> I event w event
forall ev w. Ord ev => Maybe ev -> Maybe ev -> I ev w ev
Gets
adjustPriority :: Int -> I event w ()
adjustPriority = Int -> I event w ()
forall ev w. Int -> I ev w ()
Priority
infixl 3 <||
deprioritize :: (MonadInteract f w e) => f ()
deprioritize :: f ()
deprioritize = Int -> f ()
forall (m :: * -> *) w e. MonadInteract m w e => Int -> m ()
adjustPriority 1
(<||), (||>) :: (MonadInteract f w e) => f a -> f a -> f a
a :: f a
a <|| :: f a -> f a -> f a
<|| b :: f a
b = f a
a f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (f ()
forall (f :: * -> *) w e. MonadInteract f w e => f ()
deprioritize f () -> f a -> f a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> f a
b)
||> :: f a -> f a -> f a
(||>) = (f a -> f a -> f a) -> f a -> f a -> f a
forall a b c. (a -> b -> c) -> b -> a -> c
flip f a -> f a -> f a
forall (f :: * -> *) w e a.
MonadInteract f w e =>
f a -> f a -> f a
(<||)
important :: MonadInteract f w e => f a -> f a -> f a
important :: f a -> f a -> f a
important a :: f a
a b :: f a
b = f a
a f a -> f a -> f a
forall (f :: * -> *) w e a.
MonadInteract f w e =>
f a -> f a -> f a
<|| f a
b
mkProcess :: Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess :: I ev w a -> (a -> P ev w) -> P ev w
mkProcess (Returns x :: a
x) = \fut :: a -> P ev w
fut -> a -> P ev w
fut a
x
mkProcess Fails = P ev w -> (a -> P ev w) -> P ev w
forall a b. a -> b -> a
const P ev w
forall event w. P event w
Fail
mkProcess (m :: I ev w a
m `Binds` f :: a -> I ev w a
f) = \fut :: a -> P ev w
fut -> I ev w a -> (a -> P ev w) -> P ev w
forall w ev a. Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess I ev w a
m (\a :: a
a -> I ev w a -> (a -> P ev w) -> P ev w
forall w ev a. Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess (a -> I ev w a
f a
a) a -> P ev w
fut)
mkProcess (Gets l :: Maybe ev
l h :: Maybe ev
h) = Maybe ev -> Maybe ev -> (ev -> P ev w) -> P ev w
forall event w.
Ord event =>
Maybe event -> Maybe event -> (event -> P event w) -> P event w
Get Maybe ev
l Maybe ev
h
mkProcess (Writes w :: w
w) = \fut :: a -> P ev w
fut -> w -> P ev w -> P ev w
forall event w. w -> P event w -> P event w
Write w
w (a -> P ev w
fut ())
mkProcess (Priority p :: Int
p) = \fut :: a -> P ev w
fut -> Int -> P ev w -> P ev w
forall event w. Int -> P event w -> P event w
Prior Int
p (a -> P ev w
fut ())
mkProcess (Plus a :: I ev w a
a b :: I ev w a
b) = \fut :: a -> P ev w
fut -> P ev w -> P ev w -> P ev w
forall event w. P event w -> P event w -> P event w
Best (I ev w a -> (a -> P ev w) -> P ev w
forall w ev a. Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess I ev w a
a a -> P ev w
fut) (I ev w a -> (a -> P ev w) -> P ev w
forall w ev a. Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess I ev w a
b a -> P ev w
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 :: Int -> P ev w -> [[Text]]
accepted 0 _ = [[]]
accepted d :: Int
d (Get (Just low :: ev
low) (Just high :: ev
high) k :: ev -> P ev w
k) = do
[Text]
t <- Int -> P ev w -> [[Text]]
forall ev w. Show ev => Int -> P ev w -> [[Text]]
accepted (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (ev -> P ev w
k ev
low)
let h :: Text
h = if ev
low ev -> ev -> Bool
forall a. Eq a => a -> a -> Bool
== ev
high
then ev -> Text
forall a. Show a => a -> Text
showT ev
low
else ev -> Text
forall a. Show a => a -> Text
showT ev
low Text -> Text -> Text
`T.append` ".." Text -> Text -> Text
`T.append` ev -> Text
forall a. Show a => a -> Text
showT ev
high
[Text] -> [[Text]]
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
h Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
t)
accepted _ (Get Nothing Nothing _) = [["<any>"]]
accepted _ (Get Nothing (Just e :: ev
e) _) = [[".." Text -> Text -> Text
`T.append` ev -> Text
forall a. Show a => a -> Text
showT ev
e]]
accepted _ (Get (Just e :: ev
e) Nothing _) = [[ev -> Text
forall a. Show a => a -> Text
showT ev
e Text -> Text -> Text
`T.append` ".."]]
accepted _ Fail = []
accepted _ (Write _ _) = [[]]
accepted d :: Int
d (Prior _ p :: P ev w
p) = Int -> P ev w -> [[Text]]
forall ev w. Show ev => Int -> P ev w -> [[Text]]
accepted Int
d P ev w
p
accepted d :: Int
d (Best p :: P ev w
p q :: P ev w
q) = Int -> P ev w -> [[Text]]
forall ev w. Show ev => Int -> P ev w -> [[Text]]
accepted Int
d P ev w
p [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++ Int -> P ev w -> [[Text]]
forall ev w. Show ev => Int -> P ev w -> [[Text]]
accepted Int
d P ev w
q
accepted _ End = []
accepted _ (Chain _ _) = String -> [[Text]]
forall a. HasCallStack => String -> a
error "accepted: chain not supported"
showT :: Show a => a -> T.Text
showT :: a -> Text
showT = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
runWrite :: Eq w => P event w -> [event] -> [w]
runWrite :: P event w -> [event] -> [w]
runWrite _ [] = []
runWrite p :: P event w
p (c :: event
c:cs :: [event]
cs) = let (ws :: [w]
ws, p' :: P event w
p') = P event w -> event -> ([w], P event w)
forall w event. Eq w => P event w -> event -> ([w], P event w)
processOneEvent P event w
p event
c in [w]
ws [w] -> [w] -> [w]
forall a. [a] -> [a] -> [a]
++ P event w -> [event] -> [w]
forall w event. Eq w => P event w -> [event] -> [w]
runWrite P event w
p' [event]
cs
processOneEvent :: Eq w => P event w -> event -> ([w], P event w)
processOneEvent :: P event w -> event -> ([w], P event w)
processOneEvent p :: P event w
p e :: event
e = P event w -> ([w], P event w)
forall w event. Eq w => P event w -> ([w], P event w)
pullWrites (P event w -> ([w], P event w)) -> P event w -> ([w], P event w)
forall a b. (a -> b) -> a -> b
$ P event w -> event -> P event w
forall ev w. P ev w -> ev -> P ev w
pushEvent P event w
p event
e
pushEvent :: P ev w -> ev -> P ev w
pushEvent :: P ev w -> ev -> P ev w
pushEvent (Best c :: P ev w
c d :: P ev w
d) e :: ev
e = P ev w -> P ev w -> P ev w
forall event w. P event w -> P event w -> P event w
Best (P ev w -> ev -> P ev w
forall ev w. P ev w -> ev -> P ev w
pushEvent P ev w
c ev
e) (P ev w -> ev -> P ev w
forall ev w. P ev w -> ev -> P ev w
pushEvent P ev w
d ev
e)
pushEvent (Write w :: w
w c :: P ev w
c) e :: ev
e = w -> P ev w -> P ev w
forall event w. w -> P event w -> P event w
Write w
w (P ev w -> ev -> P ev w
forall ev w. P ev w -> ev -> P ev w
pushEvent P ev w
c ev
e)
pushEvent (Prior p :: Int
p c :: P ev w
c) e :: ev
e = Int -> P ev w -> P ev w
forall event w. Int -> P event w -> P event w
Prior Int
p (P ev w -> ev -> P ev w
forall ev w. P ev w -> ev -> P ev w
pushEvent P ev w
c ev
e)
pushEvent (Get l :: Maybe ev
l h :: Maybe ev
h f :: ev -> P ev w
f) e :: ev
e = if (ev -> Bool) -> Maybe ev -> Bool
forall a. (a -> Bool) -> Maybe a -> Bool
test (ev
e ev -> ev -> Bool
forall a. Ord a => a -> a -> Bool
>=) Maybe ev
l Bool -> Bool -> Bool
&& (ev -> Bool) -> Maybe ev -> Bool
forall a. (a -> Bool) -> Maybe a -> Bool
test (ev
e ev -> ev -> Bool
forall a. Ord a => a -> a -> Bool
<=) Maybe ev
h then ev -> P ev w
f ev
e else P ev w
forall event w. P event w
Fail
where test :: (a -> Bool) -> Maybe a -> Bool
test = Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True
pushEvent Fail _ = P ev w
forall event w. P event w
Fail
pushEvent End _ = P ev w
forall event w. P event w
End
pushEvent (Chain p :: P ev mid
p q :: P mid w
q) e :: ev
e = P ev mid -> P mid w -> P ev w
forall event w mid.
(Show mid, Eq mid) =>
P event mid -> P mid w -> P event w
Chain (P ev mid -> ev -> P ev mid
forall ev w. P ev w -> ev -> P ev w
pushEvent P ev mid
p ev
e) P mid w
q
data InteractState event w = Ambiguous [(Int,w,P event w)] | Waiting | Dead | Running w (P event w)
#if __GLASGOW_HASKELL__ >= 804
instance Semigroup (InteractState event w) where
<> :: InteractState event w
-> InteractState event w -> InteractState event w
(<>) = InteractState event w
-> InteractState event w -> InteractState event w
forall a. Monoid a => a -> a -> a
mappend
#endif
instance Monoid (InteractState event w) where
mappend :: InteractState event w
-> InteractState event w -> InteractState event w
mappend (Running w :: w
w c :: P event w
c) _ = w -> P event w -> InteractState event w
forall event w. w -> P event w -> InteractState event w
Running w
w P event w
c
mappend _ (Running w :: w
w c :: P event w
c) = w -> P event w -> InteractState event w
forall event w. w -> P event w -> InteractState event w
Running w
w P event w
c
mappend Dead p :: InteractState event w
p = InteractState event w
p
mappend p :: InteractState event w
p Dead = InteractState event w
p
mappend Waiting _ = InteractState event w
forall event w. InteractState event w
Waiting
mappend _ Waiting = InteractState event w
forall event w. InteractState event w
Waiting
mappend (Ambiguous a :: [(Int, w, P event w)]
a) (Ambiguous b :: [(Int, w, P event w)]
b) = [(Int, w, P event w)] -> InteractState event w
forall event w. [(Int, w, P event w)] -> InteractState event w
Ambiguous ([(Int, w, P event w)]
a [(Int, w, P event w)]
-> [(Int, w, P event w)] -> [(Int, w, P event w)]
forall a. [a] -> [a] -> [a]
++ [(Int, w, P event w)]
b)
mempty :: InteractState event w
mempty = [(Int, w, P event w)] -> InteractState event w
forall event w. [(Int, w, P event w)] -> InteractState event w
Ambiguous []
findWrites :: Int -> P event w -> InteractState event w
findWrites :: Int -> P event w -> InteractState event w
findWrites p :: Int
p (Best c :: P event w
c d :: P event w
d) = Int -> P event w -> InteractState event w
forall event w. Int -> P event w -> InteractState event w
findWrites Int
p P event w
c InteractState event w
-> InteractState event w -> InteractState event w
forall a. Monoid a => a -> a -> a
`mappend` Int -> P event w -> InteractState event w
forall event w. Int -> P event w -> InteractState event w
findWrites Int
p P event w
d
findWrites p :: Int
p (Write w :: w
w c :: P event w
c) = [(Int, w, P event w)] -> InteractState event w
forall event w. [(Int, w, P event w)] -> InteractState event w
Ambiguous [(Int
p,w
w,P event w
c)]
findWrites p :: Int
p (Prior dp :: Int
dp c :: P event w
c) = Int -> P event w -> InteractState event w
forall event w. Int -> P event w -> InteractState event w
findWrites (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dp) P event w
c
findWrites _ Fail = InteractState event w
forall event w. InteractState event w
Dead
findWrites _ End = InteractState event w
forall event w. InteractState event w
Dead
findWrites _ (Get{}) = InteractState event w
forall event w. InteractState event w
Waiting
findWrites p :: Int
p (Chain a :: P event mid
a b :: P mid w
b) = case P event mid -> InteractState event mid
forall w event. Eq w => P event w -> InteractState event w
computeState P event mid
a of
Dead -> InteractState event w
forall event w. InteractState event w
Dead
Ambiguous _ -> InteractState event w
forall event w. InteractState event w
Dead
Running w :: mid
w c :: P event mid
c -> Int -> P event w -> InteractState event w
forall event w. Int -> P event w -> InteractState event w
findWrites Int
p (P event mid -> P mid w -> P event w
forall event w mid.
(Show mid, Eq mid) =>
P event mid -> P mid w -> P event w
Chain P event mid
c (P mid w -> mid -> P mid w
forall ev w. P ev w -> ev -> P ev w
pushEvent P mid w
b mid
w))
Waiting -> case Int -> P mid w -> InteractState mid w
forall event w. Int -> P event w -> InteractState event w
findWrites Int
p P mid w
b of
Ambiguous choices :: [(Int, w, P mid w)]
choices -> [(Int, w, P event w)] -> InteractState event w
forall event w. [(Int, w, P event w)] -> InteractState event w
Ambiguous [(Int
p',w
w',P event mid -> P mid w -> P event w
forall event w mid.
(Show mid, Eq mid) =>
P event mid -> P mid w -> P event w
Chain P event mid
a P mid w
c') | (p' :: Int
p',w' :: w
w',c' :: P mid w
c') <- [(Int, w, P mid w)]
choices]
Running w' :: w
w' c' :: P mid w
c' -> w -> P event w -> InteractState event w
forall event w. w -> P event w -> InteractState event w
Running w
w' (P event mid -> P mid w -> P event w
forall event w mid.
(Show mid, Eq mid) =>
P event mid -> P mid w -> P event w
Chain P event mid
a P mid w
c')
Dead -> InteractState event w
forall event w. InteractState event w
Dead
Waiting -> InteractState event w
forall event w. InteractState event w
Waiting
computeState :: Eq w => P event w -> InteractState event w
computeState :: P event w -> InteractState event w
computeState a :: P event w
a = case Int -> P event w -> InteractState event w
forall event w. Int -> P event w -> InteractState event w
findWrites 0 P event w
a of
Ambiguous actions :: [(Int, w, P event w)]
actions ->
let prior :: Int
prior = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, w, P event w) -> Int) -> [(Int, w, P event w)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Int (Int, w, P event w) Int -> (Int, w, P event w) -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int (Int, w, P event w) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1) [(Int, w, P event w)]
actions
bests :: [[(Int, w, P event w)]]
bests = ((Int, w, P event w) -> (Int, w, P event w) -> Bool)
-> [(Int, w, P event w)] -> [[(Int, w, P event w)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (w -> w -> Bool
forall a. Eq a => a -> a -> Bool
(==) (w -> w -> Bool)
-> ((Int, w, P event w) -> w)
-> (Int, w, P event w)
-> (Int, w, P event w)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting w (Int, w, P event w) w -> (Int, w, P event w) -> w
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting w (Int, w, P event w) w
forall s t a b. Field2 s t a b => Lens s t a b
_2) ([(Int, w, P event w)] -> [[(Int, w, P event w)]])
-> [(Int, w, P event w)] -> [[(Int, w, P event w)]]
forall a b. (a -> b) -> a -> b
$
((Int, w, P event w) -> Bool)
-> [(Int, w, P event w)] -> [(Int, w, P event w)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
prior Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool)
-> ((Int, w, P event w) -> Int) -> (Int, w, P event w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Int (Int, w, P event w) Int -> (Int, w, P event w) -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int (Int, w, P event w) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1) [(Int, w, P event w)]
actions
in case [[(Int, w, P event w)]]
bests of
[(_,w :: w
w,c :: P event w
c):_] -> w -> P event w -> InteractState event w
forall event w. w -> P event w -> InteractState event w
Running w
w P event w
c
_ -> [(Int, w, P event w)] -> InteractState event w
forall event w. [(Int, w, P event w)] -> InteractState event w
Ambiguous ([(Int, w, P event w)] -> InteractState event w)
-> [(Int, w, P event w)] -> InteractState event w
forall a b. (a -> b) -> a -> b
$ ([(Int, w, P event w)] -> (Int, w, P event w))
-> [[(Int, w, P event w)]] -> [(Int, w, P event w)]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, w, P event w)] -> (Int, w, P event w)
forall a. [a] -> a
head [[(Int, w, P event w)]]
bests
s :: InteractState event w
s -> InteractState event w
s
pullWrites :: Eq w => P event w -> ([w], P event w)
pullWrites :: P event w -> ([w], P event w)
pullWrites a :: P event w
a = case P event w -> InteractState event w
forall w event. Eq w => P event w -> InteractState event w
computeState P event w
a of
Running w :: w
w c :: P event w
c -> ([w] -> [w]) -> ([w], P event w) -> ([w], P event w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (w
ww -> [w] -> [w]
forall a. a -> [a] -> [a]
:) (P event w -> ([w], P event w)
forall w event. Eq w => P event w -> ([w], P event w)
pullWrites P event w
c)
_ -> ([], P event w
a)
instance (Show w, Show ev) => Show (P ev w) where
show :: P ev w -> String
show (Get Nothing Nothing _) = "?"
show (Get (Just l :: ev
l) (Just h :: ev
h) _p :: ev -> P ev w
_p) | ev
l ev -> ev -> Bool
forall a. Eq a => a -> a -> Bool
== ev
h = ev -> String
forall a. Show a => a -> String
show ev
l
show (Get l :: Maybe ev
l h :: Maybe ev
h _) = String -> (ev -> String) -> Maybe ev -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ev -> String
forall a. Show a => a -> String
show Maybe ev
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ ".." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> (ev -> String) -> Maybe ev -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ev -> String
forall a. Show a => a -> String
show Maybe ev
h
show (Prior p :: Int
p c :: P ev w
c) = ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ P ev w -> String
forall a. Show a => a -> String
show P ev w
c
show (Write w :: w
w c :: P ev w
c) = "!" String -> ShowS
forall a. [a] -> [a] -> [a]
++ w -> String
forall a. Show a => a -> String
show w
w String -> ShowS
forall a. [a] -> [a] -> [a]
++ "->" String -> ShowS
forall a. [a] -> [a] -> [a]
++ P ev w -> String
forall a. Show a => a -> String
show P ev w
c
show (P ev w
End) = "."
show (P ev w
Fail) = "*"
show (Best p :: P ev w
p q :: P ev w
q) = "{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ P ev w -> String
forall a. Show a => a -> String
show P ev w
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ "|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ P ev w -> String
forall a. Show a => a -> String
show P ev w
q String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}"
show (Chain a :: P ev mid
a b :: P mid w
b) = P ev mid -> String
forall a. Show a => a -> String
show P ev mid
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ">>>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ P mid w -> String
forall a. Show a => a -> String
show P mid w
b
oneOf :: (Ord event, MonadInteract m w event, Fail.MonadFail m) => [event] -> m event
oneOf :: [event] -> m event
oneOf s :: [event]
s = [m event] -> m event
forall (m :: * -> *) w e a.
(MonadInteract m w e, MonadFail m) =>
[m a] -> m a
choice ([m event] -> m event) -> [m event] -> m event
forall a b. (a -> b) -> a -> b
$ (event -> m event) -> [event] -> [m event]
forall a b. (a -> b) -> [a] -> [b]
map event -> m event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
event -> m event
event [event]
s
anyEvent :: (Ord event, MonadInteract m w event) => m event
anyEvent :: m event
anyEvent = Maybe event -> Maybe event -> m event
forall (m :: * -> *) w e.
(MonadInteract m w e, Ord e) =>
Maybe e -> Maybe e -> m e
eventBounds Maybe event
forall a. Maybe a
Nothing Maybe event
forall a. Maybe a
Nothing
eventBetween :: (Ord e, MonadInteract m w e) => e -> e -> m e
eventBetween :: e -> e -> m e
eventBetween l :: e
l h :: e
h = Maybe e -> Maybe e -> m e
forall (m :: * -> *) w e.
(MonadInteract m w e, Ord e) =>
Maybe e -> Maybe e -> m e
eventBounds (e -> Maybe e
forall a. a -> Maybe a
Just e
l) (e -> Maybe e
forall a. a -> Maybe a
Just e
h)
event :: (Ord event, MonadInteract m w event) => event -> m event
event :: event -> m event
event e :: event
e = event -> event -> m event
forall e (m :: * -> *) w.
(Ord e, MonadInteract m w e) =>
e -> e -> m e
eventBetween event
e event
e
events :: (Ord event, MonadInteract m w event) => [event] -> m [event]
events :: [event] -> m [event]
events = (event -> m event) -> [event] -> m [event]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM event -> m event
forall event (m :: * -> *) w.
(Ord event, MonadInteract m w event) =>
event -> m event
event
choice :: (MonadInteract m w e, Fail.MonadFail m) => [m a] -> m a
choice :: [m a] -> m a
choice [] = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "No choice succeeds"
choice [p :: m a
p] = m a
p
choice (p :: m a
p:ps :: [m a]
ps) = m a
p m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [m a] -> m a
forall (m :: * -> *) w e a.
(MonadInteract m w e, MonadFail m) =>
[m a] -> m a
choice [m a]
ps
option :: (MonadInteract m w e) => a -> m a -> m a
option :: a -> m a -> m a
option x :: a
x p :: m a
p = m a
p m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
mkAutomaton :: Eq w => I ev w a -> P ev w
mkAutomaton :: I ev w a -> P ev w
mkAutomaton i :: I ev w a
i = I ev w a -> (a -> P ev w) -> P ev w
forall w ev a. Eq w => I ev w a -> (a -> P ev w) -> P ev w
mkProcess I ev w a
i (P ev w -> a -> P ev w
forall a b. a -> b -> a
const P ev w
forall event w. P event w
End)
idAutomaton :: (Ord a, Eq a) => P a a
idAutomaton :: P a a
idAutomaton = Maybe a -> Maybe a -> (a -> P a a) -> P a a
forall event w.
Ord event =>
Maybe event -> Maybe event -> (event -> P event w) -> P event w
Get Maybe a
forall a. Maybe a
Nothing Maybe a
forall a. Maybe a
Nothing ((a -> P a a) -> P a a) -> (a -> P a a) -> P a a
forall a b. (a -> b) -> a -> b
$ \e :: a
e -> a -> P a a -> P a a
forall event w. w -> P event w -> P event w
Write a
e P a a
forall a. (Ord a, Eq a) => P a a
idAutomaton