{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP                        #-}
{-# OPTIONS_HADDOCK show-extensions #-}

{-|
Module      :  Yi.Interact
License     :  GPL-2
Maintainer  :  yi-devel@googlegroups.com
Stability   :  experimental
Portability :  portable

This is a library of interactive processes combinators, usable to
define extensible keymaps.

(Inspired by the Parsec library, written by Koen Claessen)

The processes are:

* composable: in parallel using '<|>', in sequence using monadic bind.

* extensible: it is always possible to override a behaviour by combination of
  'adjustPriority' and '<|>'. (See also '<||' for a convenient combination of the two.)

* monadic: sequencing is done via monadic bind. (leveraging the whole
  battery of monadic tools that Haskell provides)

The processes can parse input, and write output that depends on it.

The semantics are quite obvious; only disjunction
deserve a bit more explanation:

in @p = (a '<|>' b)@, what happens if @a@ and @b@ recognize the same
input (prefix), but produce conflicting output?

* if the output is the same (as by the Eq class), then the processes (prefixes) are "merged"
* if a Write is more prioritized than the other, the one with low priority will be discarded
* otherwise, the output will be delayed until one of the branches can be discarded.
* if there is no way to disambiguate, then no output will be generated anymore.
  This situation can be detected by using 'possibleActions' however.
-}

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)

------------------------------------------------
-- Classes

-- | Abstraction of monadic interactive processes
class (Eq w, Monad m, Alternative m, Applicative m, MonadPlus m) => MonadInteract m w e | m -> w e where
    write :: w -> m ()
    -- ^ Outputs a result.
    eventBounds :: Ord e => Maybe e -> Maybe e -> m e
    -- ^ Consumes and returns the next character.
    --   Fails if there is no input left, or outside the given bounds.
    adjustPriority :: Int -> m ()


-------------------------------------------------
-- State transformation

-- Needs -fallow-undecidable-instances
-- TODO: abstract over MonadTransformer
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)

---------------------------------------------------------------------------
-- | Interactive process description

-- TODO: Replace 'Doc:' by ^ when haddock supports GADTs
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
    -- Doc: Accept any character between given bounds. Bound is ignored if 'Nothing'.
    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
(<||)

-- | Just like '(<||)' but in prefix form. It 'deprioritize's the
-- second argument.
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

-- | Convert a process description to an "executable" process.
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)


----------------------------------------------------------------------
-- Process type

-- | Operational representation of a process
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) -- low numbers indicate high priority
    | 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
_) = [[]] -- this should show what action we get...
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"

-- Utility function
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

-- ---------------------------------------------------------------------------
-- Operations over P

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

-- | Push an event in the automaton
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

-- | Abstraction of the automaton state.
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
    -- not used at the moment:
    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
    -- don't die if that can be avoided
    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
    -- If a branch is not determined, wait for it.
    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
    -- ambiguity remains
    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 []


-- | find all the writes that are accessible.
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 -- If ambiguity, don't try to do anything clever for now; die.
    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)) -- pull as much as possible from the left automaton
    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') -- when it has nothing more, pull from the right.
        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 (p 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

-- ---------------------------------------------------------------------------
-- Derived operations
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
-- ^ Parses and returns the specified character.
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]
-- ^ Parses and returns the specified list of events (lazily).
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
-- ^ Combines all parsers in the specified list.
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 x p@ will either parse @p@ or return @x@ without consuming
--   any input.
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)

-- An automaton that produces its input
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
-- It would be much nicer to write:
--    mkAutomaton (forever 0 (anyEvent >>= write))
-- however this creates a memory leak. Unfortunately I don't understand why.
-- To witness:
--    dist/build/yi/yi +RTS -hyI -hd
-- Then type some characters. (Binds grows linearly)