{-# 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 Maybe e
l 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 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 a -> b
f 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
I ev w (a -> b)
a <*> :: I ev w (a -> b) -> I ev w a -> I ev w 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 String
_ = 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 Int
1
(<||), (||>) :: (MonadInteract f w e) => f a -> f a -> f a
f a
a <|| :: f a -> f a -> f a
<|| 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 f a
a 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 a
x) = \a -> P ev w
fut -> a -> P ev w
fut a
x
mkProcess I ev w a
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 (I ev w a
m `Binds` a -> I ev w a
f) = \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 -> 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 Maybe ev
l 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) = \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 Int
p) = \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 I ev w a
a I ev w a
b) = \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 Int
0 P ev w
_ = [[]]
accepted Int
d (Get (Just ev
low) (Just ev
high) 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
- Int
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 -> 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 Int
_ (Get Maybe ev
Nothing Maybe ev
Nothing ev -> P ev w
_) = [[Text
"<any>"]]
accepted Int
_ (Get Maybe ev
Nothing (Just ev
e) ev -> P ev w
_) = [[Text
".." Text -> Text -> Text
`T.append` ev -> Text
forall a. Show a => a -> Text
showT ev
e]]
accepted Int
_ (Get (Just ev
e) Maybe ev
Nothing ev -> P ev w
_) = [[ev -> Text
forall a. Show a => a -> Text
showT ev
e Text -> Text -> Text
`T.append` Text
".."]]
accepted Int
_ P ev w
Fail = []
accepted Int
_ (Write w
_ P ev w
_) = [[]]
accepted Int
d (Prior Int
_ 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 Int
d (Best P ev w
p 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 Int
_ P ev w
End = []
accepted Int
_ (Chain P ev mid
_ P mid w
_) = String -> [[Text]]
forall a. HasCallStack => String -> a
error String
"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 P event w
_ [] = []
runWrite P event w
p (event
c:[event]
cs) = let ([w]
ws, 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 event w
p 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 P ev w
c P ev w
d) 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 P ev w
c) 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 Int
p P ev w
c) 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 Maybe ev
l Maybe ev
h ev -> P ev w
f) 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 P ev w
Fail ev
_ = P ev w
forall event w. P event w
Fail
pushEvent P ev w
End ev
_ = P ev w
forall event w. P event w
End
pushEvent (Chain P ev mid
p P mid w
q) 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 P event w
c) InteractState event w
_ = 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 InteractState event w
_ (Running w
w 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 InteractState event w
Dead InteractState event w
p = InteractState event w
p
mappend InteractState event w
p InteractState event w
Dead = InteractState event w
p
mappend InteractState event w
Waiting InteractState event w
_ = InteractState event w
forall event w. InteractState event w
Waiting
mappend InteractState event w
_ InteractState event w
Waiting = InteractState event w
forall event w. InteractState event w
Waiting
mappend (Ambiguous [(Int, w, P event w)]
a) (Ambiguous [(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 Int
p (Best P event w
c 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 Int
p (Write 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
p,w
w,P event w
c)]
findWrites Int
p (Prior Int
dp 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 Int
_ P event w
Fail = InteractState event w
forall event w. InteractState event w
Dead
findWrites Int
_ P event w
End = InteractState event w
forall event w. InteractState event w
Dead
findWrites Int
_ (Get{}) = InteractState event w
forall event w. InteractState event w
Waiting
findWrites Int
p (Chain P event mid
a 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
InteractState event mid
Dead -> InteractState event w
forall event w. InteractState event w
Dead
Ambiguous [(Int, mid, P event mid)]
_ -> InteractState event w
forall event w. InteractState event w
Dead
Running mid
w 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))
InteractState event mid
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 [(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') | (Int
p',w
w',P mid w
c') <- [(Int, w, P mid w)]
choices]
Running w
w' 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')
InteractState mid w
Dead -> InteractState event w
forall event w. InteractState event w
Dead
InteractState mid w
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 P event w
a = case Int -> P event w -> InteractState event w
forall event w. Int -> P event w -> InteractState event w
findWrites Int
0 P event w
a of
Ambiguous [(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
[(Int
_,w
w,P event w
c):[(Int, w, P event w)]
_] -> 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)]]
_ -> [(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
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 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 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)
InteractState event w
_ -> ([], P event w
a)
instance (Show w, Show ev) => Show (P ev w) where
show :: P ev w -> String
show (Get Maybe ev
Nothing Maybe ev
Nothing ev -> P ev w
_) = String
"?"
show (Get (Just ev
l) (Just ev
h) 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 Maybe ev
l Maybe ev
h ev -> P ev w
_) = String -> (ev -> String) -> Maybe ev -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ev -> String
forall a. Show a => a -> String
show Maybe ev
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> (ev -> String) -> Maybe ev -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ev -> String
forall a. Show a => a -> String
show Maybe ev
h
show (Prior Int
p P ev w
c) = String
":" 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 P ev w
c) = String
"!" 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
"->" 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) = String
"."
show (P ev w
Fail) = String
"*"
show (Best P ev w
p P ev w
q) = String
"{" 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
"|" 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]
++ String
"}"
show (Chain P ev mid
a 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
">>>" 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 [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 e
l 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 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 String
"No choice succeeds"
choice [m a
p] = m a
p
choice (m a
p:[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 a
x 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 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
$ \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