{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Machine.MealyT
-- License     :  BSD-style (see the file LICENSE)
--
-- <http://en.wikipedia.org/wiki/Mealy_machine>
-- <https://github.com/ivanperez-keera/dunai/blob/develop/src/Data/MonadicStreamFunction/Core.hs#L35>
-- <https://hackage.haskell.org/package/auto-0.4.3.0/docs/Control-Auto.html>
-- <https://hackage.haskell.org/package/varying-0.6.0.0/docs/Control-Varying-Core.html>
----------------------------------------------------------------------------
module Data.Machine.MealyT
  ( MealyT(..)
  , arrPure
  , arrM
  , upgrade
  , scanMealyT
  , scanMealyTM
  ) where

import Data.Machine
import Control.Arrow
import Control.Applicative
import Control.Monad.Trans
import Data.Pointed
import Control.Monad.Identity
import Data.Profunctor
import Data.Semigroup
import qualified Control.Category as C
import Prelude

-- | 'Mealy' machine, with applicative effects
newtype MealyT m a b = MealyT { MealyT m a b -> a -> m (b, MealyT m a b)
runMealyT :: a -> m (b, MealyT m a b) }

instance Functor m => Functor (MealyT m a) where
  {-# INLINE fmap #-}
  fmap :: (a -> b) -> MealyT m a a -> MealyT m a b
fmap a -> b
f (MealyT a -> m (a, MealyT m a a)
m) = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
a ->
    ((a, MealyT m a a) -> (b, MealyT m a b))
-> m (a, MealyT m a a) -> m (b, MealyT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
x,MealyT m a a
y) -> (a -> b
f a
x, (a -> b) -> MealyT m a a -> MealyT m a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f MealyT m a a
y)) (a -> m (a, MealyT m a a)
m a
a)

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

instance Applicative m => Applicative (MealyT m a) where
  {-# INLINE pure #-}
  pure :: a -> MealyT m a a
pure a
b = MealyT m a a
forall b. MealyT m b a
r where r :: MealyT m b a
r = (b -> m (a, MealyT m b a)) -> MealyT m b a
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT (m (a, MealyT m b a) -> b -> m (a, MealyT m b a)
forall a b. a -> b -> a
const ((a, MealyT m b a) -> m (a, MealyT m b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
b, MealyT m b a
r))) -- Stolen from Pointed
  MealyT a -> m (a -> b, MealyT m a (a -> b))
m <*> :: MealyT m a (a -> b) -> MealyT m a a -> MealyT m a b
<*> MealyT a -> m (a, MealyT m a a)
n = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> (\(a -> b
mb, MealyT m a (a -> b)
mm) (a
nb, MealyT m a a
nm) -> (a -> b
mb a
nb, MealyT m a (a -> b)
mm MealyT m a (a -> b) -> MealyT m a a -> MealyT m a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MealyT m a a
nm)) ((a -> b, MealyT m a (a -> b))
 -> (a, MealyT m a a) -> (b, MealyT m a b))
-> m (a -> b, MealyT m a (a -> b))
-> m ((a, MealyT m a a) -> (b, MealyT m a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m (a -> b, MealyT m a (a -> b))
m a
a m ((a, MealyT m a a) -> (b, MealyT m a b))
-> m (a, MealyT m a a) -> m (b, MealyT m a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m (a, MealyT m a a)
n a
a

instance Functor m => Profunctor (MealyT m) where
  rmap :: (b -> c) -> MealyT m a b -> MealyT m a c
rmap = (b -> c) -> MealyT m a b -> MealyT m a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  {-# INLINE rmap #-}
  lmap :: (a -> b) -> MealyT m b c -> MealyT m a c
lmap a -> b
f = MealyT m b c -> MealyT m a c
forall (m :: * -> *) b. Functor m => MealyT m b b -> MealyT m a b
go where
    go :: MealyT m b b -> MealyT m a b
go (MealyT b -> m (b, MealyT m b b)
m) = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> ((b, MealyT m b b) -> (b, MealyT m a b))
-> m (b, MealyT m b b) -> m (b, MealyT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(b
b,MealyT m b b
n) -> (b
b, MealyT m b b -> MealyT m a b
go MealyT m b b
n)) (b -> m (b, MealyT m b b)
m (a -> b
f a
a))
  {-# INLINE lmap #-}
#if MIN_VERSION_profunctors(3,1,1)
  dimap :: (a -> b) -> (c -> d) -> MealyT m b c -> MealyT m a d
dimap a -> b
f c -> d
g = MealyT m b c -> MealyT m a d
forall (m :: * -> *). Functor m => MealyT m b c -> MealyT m a d
go where
    go :: MealyT m b c -> MealyT m a d
go (MealyT b -> m (c, MealyT m b c)
m) = (a -> m (d, MealyT m a d)) -> MealyT m a d
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (d, MealyT m a d)) -> MealyT m a d)
-> (a -> m (d, MealyT m a d)) -> MealyT m a d
forall a b. (a -> b) -> a -> b
$ \a
a -> ((c, MealyT m b c) -> (d, MealyT m a d))
-> m (c, MealyT m b c) -> m (d, MealyT m a d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(c
b,MealyT m b c
n) -> (c -> d
g c
b, MealyT m b c -> MealyT m a d
go MealyT m b c
n)) (b -> m (c, MealyT m b c)
m (a -> b
f a
a))
  {-# INLINE dimap #-}
#endif

instance Monad m => C.Category (MealyT m) where
  {-# INLINE id #-}
  id :: MealyT m a a
id = (a -> m (a, MealyT m a a)) -> MealyT m a a
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (a, MealyT m a a)) -> MealyT m a a)
-> (a -> m (a, MealyT m a a)) -> MealyT m a a
forall a b. (a -> b) -> a -> b
$ \a
a -> (a, MealyT m a a) -> m (a, MealyT m a a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, MealyT m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id)
  MealyT b -> m (c, MealyT m b c)
bc . :: MealyT m b c -> MealyT m a b -> MealyT m a c
. MealyT a -> m (b, MealyT m a b)
ab = (a -> m (c, MealyT m a c)) -> MealyT m a c
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (c, MealyT m a c)) -> MealyT m a c)
-> (a -> m (c, MealyT m a c)) -> MealyT m a c
forall a b. (a -> b) -> a -> b
$ \a
a ->
    do (b
b, MealyT m a b
nab) <- a -> m (b, MealyT m a b)
ab a
a
       (c
c, MealyT m b c
nbc) <- b -> m (c, MealyT m b c)
bc b
b
       (c, MealyT m a c) -> m (c, MealyT m a c)
forall (m :: * -> *) a. Monad m => a -> m a
return (c
c, MealyT m b c
nbc MealyT m b c -> MealyT m a b -> MealyT m a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
C.. MealyT m a b
nab)

instance Monad m => Arrow (MealyT m) where
  {-# INLINE arr #-}
  arr :: (b -> c) -> MealyT m b c
arr b -> c
f = MealyT m b c
r where r :: MealyT m b c
r = (b -> m (c, MealyT m b c)) -> MealyT m b c
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT (\b
a -> (c, MealyT m b c) -> m (c, MealyT m b c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> c
f b
a, MealyT m b c
r))
  first :: MealyT m b c -> MealyT m (b, d) (c, d)
first (MealyT b -> m (c, MealyT m b c)
m) = ((b, d) -> m ((c, d), MealyT m (b, d) (c, d)))
-> MealyT m (b, d) (c, d)
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT (((b, d) -> m ((c, d), MealyT m (b, d) (c, d)))
 -> MealyT m (b, d) (c, d))
-> ((b, d) -> m ((c, d), MealyT m (b, d) (c, d)))
-> MealyT m (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \(b
a,d
c) ->
    do (c
b, MealyT m b c
n) <- b -> m (c, MealyT m b c)
m b
a
       ((c, d), MealyT m (b, d) (c, d))
-> m ((c, d), MealyT m (b, d) (c, d))
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
b, d
c), MealyT m b c -> MealyT m (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first MealyT m b c
n)

arrPure :: (a -> b) -> MealyT Identity a b
arrPure :: (a -> b) -> MealyT Identity a b
arrPure = (a -> b) -> MealyT Identity a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr

arrM :: Functor m => (a -> m b) -> MealyT m a b
arrM :: (a -> m b) -> MealyT m a b
arrM a -> m b
f = MealyT m a b
r where r :: MealyT m a b
r = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> (b -> (b, MealyT m a b)) -> m b -> m (b, MealyT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,MealyT m a b
r) (a -> m b
f a
a)

upgrade :: Applicative m => Mealy a b -> MealyT m a b
upgrade :: Mealy a b -> MealyT m a b
upgrade (Mealy a -> (b, Mealy a b)
f) = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
a -> let (b
r, Mealy a b
g) = a -> (b, Mealy a b)
f a
a in (b, MealyT m a b) -> m (b, MealyT m a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
r, Mealy a b -> MealyT m a b
forall (m :: * -> *) a b.
Applicative m =>
Mealy a b -> MealyT m a b
upgrade Mealy a b
g)

scanMealyT :: Applicative m => (a -> b -> a) -> a -> MealyT m b a
scanMealyT :: (a -> b -> a) -> a -> MealyT m b a
scanMealyT a -> b -> a
f a
a = (b -> m (a, MealyT m b a)) -> MealyT m b a
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT (\b
b -> (a, MealyT m b a) -> m (a, MealyT m b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, (a -> b -> a) -> a -> MealyT m b a
forall (m :: * -> *) a b.
Applicative m =>
(a -> b -> a) -> a -> MealyT m b a
scanMealyT a -> b -> a
f (a -> b -> a
f a
a b
b)))

scanMealyTM :: Functor m => (a -> b -> m a) -> a -> MealyT m b a
scanMealyTM :: (a -> b -> m a) -> a -> MealyT m b a
scanMealyTM a -> b -> m a
f a
a = (b -> m (a, MealyT m b a)) -> MealyT m b a
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((b -> m (a, MealyT m b a)) -> MealyT m b a)
-> (b -> m (a, MealyT m b a)) -> MealyT m b a
forall a b. (a -> b) -> a -> b
$ \b
b -> (\a
x -> (a
a, (a -> b -> m a) -> a -> MealyT m b a
forall (m :: * -> *) a b.
Functor m =>
(a -> b -> m a) -> a -> MealyT m b a
scanMealyTM a -> b -> m a
f a
x)) (a -> (a, MealyT m b a)) -> m a -> m (a, MealyT m b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> b -> m a
f a
a b
b

autoMealyTImpl :: Monad m => MealyT m a b -> ProcessT m a b
autoMealyTImpl :: MealyT m a b -> ProcessT m a b
autoMealyTImpl = PlanT (Is a) b m Any -> ProcessT m 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 -> ProcessT m a b)
-> (MealyT m a b -> PlanT (Is a) b m Any)
-> MealyT m a b
-> ProcessT m a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MealyT m a b -> PlanT (Is a) b m Any
forall (k :: * -> * -> *) (m :: * -> *) a o b.
(Category k, Monad m) =>
MealyT m a o -> PlanT (k a) o m b
go
  where
  go :: MealyT m a o -> PlanT (k a) o m b
go (MealyT a -> m (o, MealyT m a o)
f) = do
    a
a      <- PlanT (k a) o m a
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await
    (o
b, MealyT m a o
m) <- m (o, MealyT m a o) -> PlanT (k a) o m (o, MealyT m a o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (o, MealyT m a o) -> PlanT (k a) o m (o, MealyT m a o))
-> m (o, MealyT m a o) -> PlanT (k a) o m (o, MealyT m a o)
forall a b. (a -> b) -> a -> b
$ a -> m (o, MealyT m a o)
f a
a
    o -> Plan (k a) o ()
forall o (k :: * -> *). o -> Plan k o ()
yield o
b
    MealyT m a o -> PlanT (k a) o m b
go MealyT m a o
m

instance AutomatonM MealyT where
  autoT :: MealyT m a b -> ProcessT m a b
autoT = MealyT m a b -> ProcessT m a b
forall (m :: * -> *) a b. Monad m => MealyT m a b -> ProcessT m a b
autoMealyTImpl

instance (Semigroup b, Applicative m) => Semigroup (MealyT m a b) where
  MealyT m a b
f <> :: MealyT m a b -> MealyT m a b -> MealyT m a b
<> MealyT m a b
g = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
x ->
    (\(b
fx, MealyT m a b
f') (b
gx, MealyT m a b
g') -> (b
fx b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
gx, MealyT m a b
f' MealyT m a b -> MealyT m a b -> MealyT m a b
forall a. Semigroup a => a -> a -> a
<> MealyT m a b
g')) ((b, MealyT m a b) -> (b, MealyT m a b) -> (b, MealyT m a b))
-> m (b, MealyT m a b)
-> m ((b, MealyT m a b) -> (b, MealyT m a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MealyT m a b -> a -> m (b, MealyT m a b)
forall (m :: * -> *) a b. MealyT m a b -> a -> m (b, MealyT m a b)
runMealyT MealyT m a b
f a
x m ((b, MealyT m a b) -> (b, MealyT m a b))
-> m (b, MealyT m a b) -> m (b, MealyT m a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MealyT m a b -> a -> m (b, MealyT m a b)
forall (m :: * -> *) a b. MealyT m a b -> a -> m (b, MealyT m a b)
runMealyT MealyT m a b
g a
x

instance (Semigroup b, Monoid b, Applicative m) => Monoid (MealyT m a b) where
  mempty :: MealyT m a b
mempty = (a -> m (b, MealyT m a b)) -> MealyT m a b
forall (m :: * -> *) a b.
(a -> m (b, MealyT m a b)) -> MealyT m a b
MealyT ((a -> m (b, MealyT m a b)) -> MealyT m a b)
-> (a -> m (b, MealyT m a b)) -> MealyT m a b
forall a b. (a -> b) -> a -> b
$ \a
_ -> (b, MealyT m a b) -> m (b, MealyT m a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b, MealyT m a b)
forall a. Monoid a => a
mempty
  mappend :: MealyT m a b -> MealyT m a b -> MealyT m a b
mappend = MealyT m a b -> MealyT m a b -> MealyT m a b
forall a. Semigroup a => a -> a -> a
(<>)