{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Machine.Mealy
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- <http://en.wikipedia.org/wiki/Mealy_machine>
----------------------------------------------------------------------------
module Data.Machine.Mealy
  ( Mealy(..)
  , unfoldMealy
  , logMealy
  ) where

import Control.Applicative
import Control.Arrow
import Control.Category
import Data.Distributive
import Data.Functor.Extend
import Data.Functor.Rep as Functor
import Data.List.NonEmpty as NonEmpty
import Data.Machine.Plan
import Data.Machine.Type
import Data.Machine.Process
import Data.Profunctor.Closed
import Data.Profunctor
import Data.Profunctor.Sieve
import Data.Profunctor.Rep as Profunctor
import Data.Pointed
import Data.Semigroup
import Data.Sequence as Seq
import Prelude hiding ((.),id)

-- $setup
-- >>> import Data.Machine

-- | 'Mealy' machines
--
-- ==== Examples
--
-- We can enumerate inputs:
--
-- >>> let countingMealy = unfoldMealy (\i x -> ((i, x), i + 1)) 0
-- >>> run (auto countingMealy <~ source "word")
-- [(0,'w'),(1,'o'),(2,'r'),(3,'d')]
--
newtype Mealy a b = Mealy { forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy :: a -> (b, Mealy a b) }

instance Functor (Mealy a) where
  fmap :: forall a b. (a -> b) -> Mealy a a -> Mealy a b
fmap a -> b
f (Mealy a -> (a, Mealy a a)
m) = (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (b, Mealy a b)) -> Mealy a b)
-> (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> b) -> a -> b
$ \a
a -> case a -> (a, Mealy a a)
m a
a of
    (a
b, Mealy a a
n) -> (a -> b
f a
b, (a -> b) -> Mealy a a -> Mealy a b
forall a b. (a -> b) -> Mealy a a -> Mealy a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Mealy a a
n)
  {-# INLINE fmap #-}
  a
b <$ :: forall a b. a -> Mealy a b -> Mealy a a
<$ Mealy a b
_ = a -> Mealy a a
forall a. a -> Mealy a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
  {-# INLINE (<$) #-}

instance Applicative (Mealy a) where
  pure :: forall a. a -> Mealy a a
pure a
b = Mealy a a
r where r :: Mealy a a
r = (a -> (a, Mealy a a)) -> Mealy a a
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a, Mealy a a) -> a -> (a, Mealy a a)
forall a b. a -> b -> a
const (a
b, Mealy a a
r))
  {-# INLINE pure #-}
  Mealy a -> (a -> b, Mealy a (a -> b))
m <*> :: forall a b. Mealy a (a -> b) -> Mealy a a -> Mealy a b
<*> Mealy a -> (a, Mealy a a)
n = (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (b, Mealy a b)) -> Mealy a b)
-> (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> b) -> a -> b
$ \a
a -> case a -> (a -> b, Mealy a (a -> b))
m a
a of
    (a -> b
f, Mealy a (a -> b)
m') -> case a -> (a, Mealy a a)
n a
a of
       (a
b, Mealy a a
n') -> (a -> b
f a
b, Mealy a (a -> b)
m' Mealy a (a -> b) -> Mealy a a -> Mealy a b
forall a b. Mealy a (a -> b) -> Mealy a a -> Mealy a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy a a
n')
  Mealy a a
m <* :: forall a b. Mealy a a -> Mealy a b -> Mealy a a
<* Mealy a b
_ = Mealy a a
m
  {-# INLINE (<*) #-}
  Mealy a a
_ *> :: forall a b. Mealy a a -> Mealy a b -> Mealy a b
*> Mealy a b
n = Mealy a b
n
  {-# INLINE (*>) #-}

instance Pointed (Mealy a) where
  point :: forall a. a -> Mealy a a
point a
b = Mealy a a
r where r :: Mealy a a
r = (a -> (a, Mealy a a)) -> Mealy a a
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a, Mealy a a) -> a -> (a, Mealy a a)
forall a b. a -> b -> a
const (a
b, Mealy a a
r))
  {-# INLINE point #-}

instance Extend (Mealy a) where
  duplicated :: forall a. Mealy a a -> Mealy a (Mealy a a)
duplicated (Mealy a -> (a, Mealy a a)
m) = (a -> (Mealy a a, Mealy a (Mealy a a))) -> Mealy a (Mealy a a)
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (Mealy a a, Mealy a (Mealy a a))) -> Mealy a (Mealy a a))
-> (a -> (Mealy a a, Mealy a (Mealy a a))) -> Mealy a (Mealy a a)
forall a b. (a -> b) -> a -> b
$ \a
a -> case a -> (a, Mealy a a)
m a
a of
    (a
_, Mealy a a
b) -> (Mealy a a
b, Mealy a a -> Mealy a (Mealy a a)
forall a. Mealy a a -> Mealy a (Mealy a a)
forall (w :: * -> *) a. Extend w => w a -> w (w a)
duplicated Mealy a a
b)

-- | A 'Mealy' machine modeled with explicit state.
unfoldMealy :: (s -> a -> (b, s)) -> s -> Mealy a b
unfoldMealy :: forall s a b. (s -> a -> (b, s)) -> s -> Mealy a b
unfoldMealy s -> a -> (b, s)
f = s -> Mealy a b
go where
  go :: s -> Mealy a b
go s
s = (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (b, Mealy a b)) -> Mealy a b)
-> (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> b) -> a -> b
$ \a
a -> case s -> a -> (b, s)
f s
s a
a of
    (b
b, s
t) -> (b
b, s -> Mealy a b
go s
t)
{-# INLINE unfoldMealy #-}

instance Profunctor Mealy where
  rmap :: forall b c a. (b -> c) -> Mealy a b -> Mealy a c
rmap = (b -> c) -> Mealy a b -> Mealy a c
forall a b. (a -> b) -> Mealy a a -> Mealy a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  {-# INLINE rmap #-}
  lmap :: forall a b c. (a -> b) -> Mealy b c -> Mealy a c
lmap a -> b
f = Mealy b c -> Mealy a c
go where
    go :: Mealy b c -> Mealy a c
go (Mealy b -> (c, Mealy b c)
m) = (a -> (c, Mealy a c)) -> Mealy a c
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (c, Mealy a c)) -> Mealy a c)
-> (a -> (c, Mealy a c)) -> Mealy a c
forall a b. (a -> b) -> a -> b
$ \a
a -> case b -> (c, Mealy b c)
m (a -> b
f a
a) of
      (c
b, Mealy b c
n) -> (c
b, Mealy b c -> Mealy a c
go Mealy b c
n)
  {-# INLINE lmap #-}
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> Mealy b c -> Mealy a d
dimap a -> b
f c -> d
g = Mealy b c -> Mealy a d
go where
    go :: Mealy b c -> Mealy a d
go (Mealy b -> (c, Mealy b c)
m) = (a -> (d, Mealy a d)) -> Mealy a d
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (d, Mealy a d)) -> Mealy a d)
-> (a -> (d, Mealy a d)) -> Mealy a d
forall a b. (a -> b) -> a -> b
$ \a
a -> case b -> (c, Mealy b c)
m (a -> b
f a
a) of
      (c
b, Mealy b c
n) -> (c -> d
g c
b, Mealy b c -> Mealy a d
go Mealy b c
n)
  {-# INLINE dimap #-}

instance Automaton Mealy where
  auto :: forall a b. Mealy a b -> Process a b
auto Mealy a b
x = PlanT (Is a) b m Any -> MachineT m (Is a) b
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT (Is a) b m Any -> MachineT m (Is a) b)
-> PlanT (Is a) b m Any -> MachineT m (Is a) b
forall a b. (a -> b) -> a -> b
$ Mealy a b -> PlanT (Is a) b m Any
forall {k :: * -> * -> *} {a} {o} {m :: * -> *} {b}.
Category k =>
Mealy a o -> PlanT (k a) o m b
go Mealy a b
x where
    go :: Mealy a o -> PlanT (k a) o m b
go (Mealy a -> (o, Mealy a o)
f) = PlanT (k a) o m a
Plan (k a) o a
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (k a) o m a -> (a -> PlanT (k a) o m b) -> PlanT (k a) o m b
forall a b.
PlanT (k a) o m a -> (a -> PlanT (k a) o m b) -> PlanT (k a) o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> case a -> (o, Mealy a o)
f a
a of
      (o
b, Mealy a o
m) -> do
         o -> Plan (k a) o ()
forall o (k :: * -> *). o -> Plan k o ()
yield o
b
         Mealy a o -> PlanT (k a) o m b
go Mealy a o
m
  {-# INLINE auto #-}

instance Category Mealy where
  id :: forall a. Mealy a a
id = (a -> (a, Mealy a a)) -> Mealy a a
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy (\a
a -> (a
a, Mealy a a
forall a. Mealy a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id))
  Mealy b -> (c, Mealy b c)
bc . :: forall b c a. Mealy b c -> Mealy a b -> Mealy a c
. Mealy a -> (b, Mealy a b)
ab = (a -> (c, Mealy a c)) -> Mealy a c
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (c, Mealy a c)) -> Mealy a c)
-> (a -> (c, Mealy a c)) -> Mealy a c
forall a b. (a -> b) -> a -> b
$ \ a
a -> case a -> (b, Mealy a b)
ab a
a of
    (b
b, Mealy a b
nab) -> case b -> (c, Mealy b c)
bc b
b of
      (c
c, Mealy b c
nbc) -> (c
c, Mealy b c
nbc Mealy b c -> Mealy a b -> Mealy a c
forall b c a. Mealy b c -> Mealy a b -> Mealy a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Mealy a b
nab)

instance Arrow Mealy where
  arr :: forall b c. (b -> c) -> Mealy b c
arr b -> c
f = Mealy b c
r where r :: Mealy b c
r = (b -> (c, Mealy b c)) -> Mealy b c
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy (\b
a -> (b -> c
f b
a, Mealy b c
r))
  {-# INLINE arr #-}
  first :: forall b c d. Mealy b c -> Mealy (b, d) (c, d)
first (Mealy b -> (c, Mealy b c)
m) = ((b, d) -> ((c, d), Mealy (b, d) (c, d))) -> Mealy (b, d) (c, d)
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy (((b, d) -> ((c, d), Mealy (b, d) (c, d))) -> Mealy (b, d) (c, d))
-> ((b, d) -> ((c, d), Mealy (b, d) (c, d))) -> Mealy (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \(b
a,d
c) -> case b -> (c, Mealy b c)
m b
a of
    (c
b, Mealy b c
n) -> ((c
b, d
c), Mealy b c -> Mealy (b, d) (c, d)
forall b c d. Mealy b c -> Mealy (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Mealy b c
n)

instance ArrowChoice Mealy where
  left :: forall b c d. Mealy b c -> Mealy (Either b d) (Either c d)
left Mealy b c
m = (Either b d -> (Either c d, Mealy (Either b d) (Either c d)))
-> Mealy (Either b d) (Either c d)
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((Either b d -> (Either c d, Mealy (Either b d) (Either c d)))
 -> Mealy (Either b d) (Either c d))
-> (Either b d -> (Either c d, Mealy (Either b d) (Either c d)))
-> Mealy (Either b d) (Either c d)
forall a b. (a -> b) -> a -> b
$ \Either b d
a -> case Either b d
a of
    Left b
l  -> case Mealy b c -> b -> (c, Mealy b c)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy b c
m b
l of
      (c
b, Mealy b c
m') -> (c -> Either c d
forall a b. a -> Either a b
Left c
b, Mealy b c -> Mealy (Either b d) (Either c d)
forall b c d. Mealy b c -> Mealy (Either b d) (Either c d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left Mealy b c
m')
    Right d
r -> (d -> Either c d
forall a b. b -> Either a b
Right d
r, Mealy b c -> Mealy (Either b d) (Either c d)
forall b c d. Mealy b c -> Mealy (Either b d) (Either c d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left Mealy b c
m)
  right :: forall b c d. Mealy b c -> Mealy (Either d b) (Either d c)
right Mealy b c
m = (Either d b -> (Either d c, Mealy (Either d b) (Either d c)))
-> Mealy (Either d b) (Either d c)
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((Either d b -> (Either d c, Mealy (Either d b) (Either d c)))
 -> Mealy (Either d b) (Either d c))
-> (Either d b -> (Either d c, Mealy (Either d b) (Either d c)))
-> Mealy (Either d b) (Either d c)
forall a b. (a -> b) -> a -> b
$ \Either d b
a -> case Either d b
a of
    Left d
l -> (d -> Either d c
forall a b. a -> Either a b
Left d
l, Mealy b c -> Mealy (Either d b) (Either d c)
forall b c d. Mealy b c -> Mealy (Either d b) (Either d c)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right Mealy b c
m)
    Right b
r -> case Mealy b c -> b -> (c, Mealy b c)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy b c
m b
r of
      (c
b, Mealy b c
m') -> (c -> Either d c
forall a b. b -> Either a b
Right c
b, Mealy b c -> Mealy (Either d b) (Either d c)
forall b c d. Mealy b c -> Mealy (Either d b) (Either d c)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right Mealy b c
m')
  Mealy b c
m +++ :: forall b c b' c'.
Mealy b c -> Mealy b' c' -> Mealy (Either b b') (Either c c')
+++ Mealy b' c'
n = (Either b b' -> (Either c c', Mealy (Either b b') (Either c c')))
-> Mealy (Either b b') (Either c c')
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((Either b b' -> (Either c c', Mealy (Either b b') (Either c c')))
 -> Mealy (Either b b') (Either c c'))
-> (Either b b'
    -> (Either c c', Mealy (Either b b') (Either c c')))
-> Mealy (Either b b') (Either c c')
forall a b. (a -> b) -> a -> b
$ \Either b b'
a -> case Either b b'
a of
    Left b
b -> case Mealy b c -> b -> (c, Mealy b c)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy b c
m b
b of
      (c
c, Mealy b c
m') -> (c -> Either c c'
forall a b. a -> Either a b
Left c
c, Mealy b c
m' Mealy b c -> Mealy b' c' -> Mealy (Either b b') (Either c c')
forall b c b' c'.
Mealy b c -> Mealy b' c' -> Mealy (Either b b') (Either c c')
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ Mealy b' c'
n)
    Right b'
b -> case Mealy b' c' -> b' -> (c', Mealy b' c')
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy b' c'
n b'
b of
      (c'
c, Mealy b' c'
n') -> (c' -> Either c c'
forall a b. b -> Either a b
Right c'
c, Mealy b c
m Mealy b c -> Mealy b' c' -> Mealy (Either b b') (Either c c')
forall b c b' c'.
Mealy b c -> Mealy b' c' -> Mealy (Either b b') (Either c c')
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ Mealy b' c'
n')
  Mealy b d
m ||| :: forall b d c. Mealy b d -> Mealy c d -> Mealy (Either b c) d
||| Mealy c d
n = (Either b c -> (d, Mealy (Either b c) d)) -> Mealy (Either b c) d
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((Either b c -> (d, Mealy (Either b c) d)) -> Mealy (Either b c) d)
-> (Either b c -> (d, Mealy (Either b c) d))
-> Mealy (Either b c) d
forall a b. (a -> b) -> a -> b
$ \Either b c
a -> case Either b c
a of
    Left b
b -> case Mealy b d -> b -> (d, Mealy b d)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy b d
m b
b of
      (d
d, Mealy b d
m') -> (d
d, Mealy b d
m' Mealy b d -> Mealy c d -> Mealy (Either b c) d
forall b d c. Mealy b d -> Mealy c d -> Mealy (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| Mealy c d
n)
    Right c
b -> case Mealy c d -> c -> (d, Mealy c d)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy c d
n c
b of
      (d
d, Mealy c d
n') -> (d
d, Mealy b d
m Mealy b d -> Mealy c d -> Mealy (Either b c) d
forall b d c. Mealy b d -> Mealy c d -> Mealy (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| Mealy c d
n')

instance Strong Mealy where
  first' :: forall b c d. Mealy b c -> Mealy (b, d) (c, d)
first' = Mealy a b -> Mealy (a, c) (b, c)
forall b c d. Mealy b c -> Mealy (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first

instance Choice Mealy where
  left' :: forall b c d. Mealy b c -> Mealy (Either b d) (Either c d)
left' = Mealy a b -> Mealy (Either a c) (Either b c)
forall b c d. Mealy b c -> Mealy (Either b d) (Either c d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left
  right' :: forall b c d. Mealy b c -> Mealy (Either d b) (Either d c)
right' = Mealy a b -> Mealy (Either c a) (Either c b)
forall b c d. Mealy b c -> Mealy (Either d b) (Either d c)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right

-- | Fast forward a mealy machine forward
driveMealy :: Mealy a b -> Seq a -> a -> (b, Mealy a b)
driveMealy :: forall a b. Mealy a b -> Seq a -> a -> (b, Mealy a b)
driveMealy Mealy a b
m Seq a
xs a
z = case Seq a -> ViewL a
forall a. Seq a -> ViewL a
viewl Seq a
xs of
  a
y :< Seq a
ys -> case Mealy a b -> a -> (b, Mealy a b)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy a b
m a
y of
    (b
_, Mealy a b
n) -> Mealy a b -> Seq a -> a -> (b, Mealy a b)
forall a b. Mealy a b -> Seq a -> a -> (b, Mealy a b)
driveMealy Mealy a b
n Seq a
ys a
z
  ViewL a
EmptyL  -> Mealy a b -> a -> (b, Mealy a b)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy a b
m a
z

-- | Accumulate history.
logMealy :: Semigroup a => Mealy a a
logMealy :: forall a. Semigroup a => Mealy a a
logMealy = (a -> (a, Mealy a a)) -> Mealy a a
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (a, Mealy a a)) -> Mealy a a)
-> (a -> (a, Mealy a a)) -> Mealy a a
forall a b. (a -> b) -> a -> b
$ \a
a -> (a
a, a -> Mealy a a
forall {t}. Semigroup t => t -> Mealy t t
h a
a) where
  h :: t -> Mealy t t
h t
a = (t -> (t, Mealy t t)) -> Mealy t t
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((t -> (t, Mealy t t)) -> Mealy t t)
-> (t -> (t, Mealy t t)) -> Mealy t t
forall a b. (a -> b) -> a -> b
$ \t
b -> let c :: t
c = t
a t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
b in (t
c, t -> Mealy t t
h t
c)
{-# INLINE logMealy #-}

instance ArrowApply Mealy where
  app :: forall b c. Mealy (Mealy b c, b) c
app = Seq b -> Mealy (Mealy b c, b) c
forall {a} {b}. Seq a -> Mealy (Mealy a b, a) b
go Seq b
forall a. Seq a
Seq.empty where
    go :: Seq a -> Mealy (Mealy a b, a) b
go Seq a
xs = ((Mealy a b, a) -> (b, Mealy (Mealy a b, a) b))
-> Mealy (Mealy a b, a) b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy (((Mealy a b, a) -> (b, Mealy (Mealy a b, a) b))
 -> Mealy (Mealy a b, a) b)
-> ((Mealy a b, a) -> (b, Mealy (Mealy a b, a) b))
-> Mealy (Mealy a b, a) b
forall a b. (a -> b) -> a -> b
$ \(Mealy a b
m,a
x) -> case Mealy a b -> Seq a -> a -> (b, Mealy a b)
forall a b. Mealy a b -> Seq a -> a -> (b, Mealy a b)
driveMealy Mealy a b
m Seq a
xs a
x of
      (b
c, Mealy a b
_) -> (b
c, Seq a -> Mealy (Mealy a b, a) b
go (Seq a
xs Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
|> a
x))
  {-# INLINE app #-}

instance Distributive (Mealy a) where
  distribute :: forall (f :: * -> *) a. Functor f => f (Mealy a a) -> Mealy a (f a)
distribute f (Mealy a a)
fm = (a -> (f a, Mealy a (f a))) -> Mealy a (f a)
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (f a, Mealy a (f a))) -> Mealy a (f a))
-> (a -> (f a, Mealy a (f a))) -> Mealy a (f a)
forall a b. (a -> b) -> a -> b
$ \a
a -> let fp :: f (a, Mealy a a)
fp = (Mealy a a -> (a, Mealy a a)) -> f (Mealy a a) -> f (a, Mealy a a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Mealy a a -> a -> (a, Mealy a a)
forall a b. Mealy a b -> a -> (b, Mealy a b)
`runMealy` a
a) f (Mealy a a)
fm in
     (((a, Mealy a a) -> a) -> f (a, Mealy a a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Mealy a a) -> a
forall a b. (a, b) -> a
fst f (a, Mealy a a)
fp, ((a, Mealy a a) -> Mealy a a) -> f (a, Mealy a a) -> Mealy a (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive g, Functor f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b.
Functor f =>
(a -> Mealy a b) -> f a -> Mealy a (f b)
collect (a, Mealy a a) -> Mealy a a
forall a b. (a, b) -> b
snd f (a, Mealy a a)
fp)
  collect :: forall (f :: * -> *) a b.
Functor f =>
(a -> Mealy a b) -> f a -> Mealy a (f b)
collect a -> Mealy a b
k f a
fa = (a -> (f b, Mealy a (f b))) -> Mealy a (f b)
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (f b, Mealy a (f b))) -> Mealy a (f b))
-> (a -> (f b, Mealy a (f b))) -> Mealy a (f b)
forall a b. (a -> b) -> a -> b
$ \a
a -> let fp :: f (b, Mealy a b)
fp = (a -> (b, Mealy a b)) -> f a -> f (b, Mealy a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> Mealy a b -> a -> (b, Mealy a b)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy (a -> Mealy a b
k a
x) a
a) f a
fa in
     (((b, Mealy a b) -> b) -> f (b, Mealy a b) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, Mealy a b) -> b
forall a b. (a, b) -> a
fst f (b, Mealy a b)
fp, ((b, Mealy a b) -> Mealy a b) -> f (b, Mealy a b) -> Mealy a (f b)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive g, Functor f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b.
Functor f =>
(a -> Mealy a b) -> f a -> Mealy a (f b)
collect (b, Mealy a b) -> Mealy a b
forall a b. (a, b) -> b
snd f (b, Mealy a b)
fp)

instance Functor.Representable (Mealy a) where
  type Rep (Mealy a) = NonEmpty a
  index :: forall a. Mealy a a -> Rep (Mealy a) -> a
index = Mealy a a -> NonEmpty a -> a
Mealy a a -> Rep (Mealy a) -> a
forall a b. Mealy a b -> NonEmpty a -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve
  tabulate :: forall a. (Rep (Mealy a) -> a) -> Mealy a a
tabulate = (Rep (Mealy a) -> a) -> Mealy a a
(Corep Mealy a -> a) -> Mealy a a
forall d c. (Corep Mealy d -> c) -> Mealy d c
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate

instance Cosieve Mealy NonEmpty where
  cosieve :: forall a b. Mealy a b -> NonEmpty a -> b
cosieve Mealy a b
m0 (a
a0 :| [a]
as0) = Mealy a b -> a -> [a] -> b
forall {t} {b}. Mealy t b -> t -> [t] -> b
go Mealy a b
m0 a
a0 [a]
as0 where
    go :: Mealy t b -> t -> [t] -> b
go (Mealy t -> (b, Mealy t b)
m) t
a [t]
as = case t -> (b, Mealy t b)
m t
a of
      (b
b, Mealy t b
m') -> case [t]
as of
        [] -> b
b
        t
a':[t]
as' -> Mealy t b -> t -> [t] -> b
go Mealy t b
m' t
a' [t]
as'

instance Costrong Mealy where
  unfirst :: forall a d b. Mealy (a, d) (b, d) -> Mealy a b
unfirst = Mealy (a, d) (b, d) -> Mealy a b
forall (p :: * -> * -> *) a d b.
Corepresentable p =>
p (a, d) (b, d) -> p a b
unfirstCorep
  unsecond :: forall d a b. Mealy (d, a) (d, b) -> Mealy a b
unsecond = Mealy (d, a) (d, b) -> Mealy a b
forall (p :: * -> * -> *) d a b.
Corepresentable p =>
p (d, a) (d, b) -> p a b
unsecondCorep

instance Profunctor.Corepresentable Mealy where
  type Corep Mealy = NonEmpty
  cotabulate :: forall d c. (Corep Mealy d -> c) -> Mealy d c
cotabulate Corep Mealy d -> c
f0 = (d -> (c, Mealy d c)) -> Mealy d c
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((d -> (c, Mealy d c)) -> Mealy d c)
-> (d -> (c, Mealy d c)) -> Mealy d c
forall a b. (a -> b) -> a -> b
$ \d
a -> [d] -> (NonEmpty d -> c) -> (c, Mealy d c)
forall {a} {b}. [a] -> (NonEmpty a -> b) -> (b, Mealy a b)
go [d
a] NonEmpty d -> c
Corep Mealy d -> c
f0 where
     go :: [a] -> (NonEmpty a -> b) -> (b, Mealy a b)
go [a]
as NonEmpty a -> b
f = (NonEmpty a -> b
f ([a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList ([a] -> [a]
forall a. [a] -> [a]
Prelude.reverse [a]
as)), (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (b, Mealy a b)) -> Mealy a b)
-> (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> b) -> a -> b
$ \a
b -> [a] -> (NonEmpty a -> b) -> (b, Mealy a b)
go (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as) NonEmpty a -> b
f)

instance Closed Mealy where
  closed :: forall a b x. Mealy a b -> Mealy (x -> a) (x -> b)
closed Mealy a b
m = (Corep Mealy (x -> a) -> x -> b) -> Mealy (x -> a) (x -> b)
forall d c. (Corep Mealy d -> c) -> Mealy d c
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ((Corep Mealy (x -> a) -> x -> b) -> Mealy (x -> a) (x -> b))
-> (Corep Mealy (x -> a) -> x -> b) -> Mealy (x -> a) (x -> b)
forall a b. (a -> b) -> a -> b
$ \Corep Mealy (x -> a)
fs x
x -> Mealy a b -> NonEmpty a -> b
forall a b. Mealy a b -> NonEmpty a -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve Mealy a b
m (((x -> a) -> a) -> NonEmpty (x -> a) -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((x -> a) -> x -> a
forall a b. (a -> b) -> a -> b
$ x
x) NonEmpty (x -> a)
Corep Mealy (x -> a)
fs)

instance Semigroup b => Semigroup (Mealy a b) where
  Mealy a b
f <> :: Mealy a b -> Mealy a b -> Mealy a b
<> Mealy a b
g = (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy ((a -> (b, Mealy a b)) -> Mealy a b)
-> (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> b) -> a -> b
$ \a
x -> Mealy a b -> a -> (b, Mealy a b)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy a b
f a
x (b, Mealy a b) -> (b, Mealy a b) -> (b, Mealy a b)
forall a. Semigroup a => a -> a -> a
<> Mealy a b -> a -> (b, Mealy a b)
forall a b. Mealy a b -> a -> (b, Mealy a b)
runMealy Mealy a b
g a
x

instance Monoid b => Monoid (Mealy a b) where
  mempty :: Mealy a b
mempty = (a -> (b, Mealy a b)) -> Mealy a b
forall a b. (a -> (b, Mealy a b)) -> Mealy a b
Mealy a -> (b, Mealy a b)
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  mappend f g = Mealy $ \x -> runMealy f x `mappend` runMealy g x
#endif