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

#ifndef MIN_VERSION_profunctors
#define MIN_VERSION_profunctors(x,y,z) 0
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Machine.Moore
-- 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/Moore_machine>
----------------------------------------------------------------------------
module Data.Machine.Moore
  ( Moore(..)
  , logMoore
  , unfoldMoore
  ) where

import Control.Applicative
import Control.Comonad
import Control.Monad.Fix
import Control.Monad.Reader.Class
import Control.Monad.Zip
import Data.Copointed
import Data.Distributive
import Data.Functor.Rep as Functor
import Data.Machine.Plan
import Data.Machine.Type
import Data.Machine.Process
import Data.Semigroup
import Data.Pointed
import Data.Profunctor.Closed
import Data.Profunctor
import Data.Profunctor.Sieve
import Data.Profunctor.Rep as Profunctor
import Prelude

-- | 'Moore' machines
data Moore a b = Moore b (a -> Moore a b)

-- | Accumulate the input as a sequence.
logMoore :: Monoid m => Moore m m
logMoore :: Moore m m
logMoore = m -> Moore m m
forall t. Monoid t => t -> Moore t t
h m
forall a. Monoid a => a
mempty where
  h :: t -> Moore t t
h t
m = t -> (t -> Moore t t) -> Moore t t
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore t
m (\t
a -> t -> Moore t t
h (t
m t -> t -> t
forall a. Monoid a => a -> a -> a
`mappend` t
a))
{-# INLINE logMoore #-}

-- | Construct a Moore machine from a state valuation and transition function
unfoldMoore :: (s -> (b, a -> s)) -> s -> Moore a b
unfoldMoore :: (s -> (b, a -> s)) -> s -> Moore a b
unfoldMoore s -> (b, a -> s)
f = s -> Moore a b
go where
  go :: s -> Moore a b
go s
s = case s -> (b, a -> s)
f s
s of
    (b
b, a -> s
g) -> b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore b
b (s -> Moore a b
go (s -> Moore a b) -> (a -> s) -> a -> Moore a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> s
g)
{-# INLINE unfoldMoore #-}

instance Automaton Moore where
  auto :: Moore a b -> Process a b
auto Moore 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
$ Moore a b -> PlanT (Is a) b m Any
forall (k :: * -> * -> *) a o (m :: * -> *) b.
Category k =>
Moore a o -> PlanT (k a) o m b
go Moore a b
x where
    go :: Moore a o -> PlanT (k a) o m b
go (Moore o
b a -> Moore a o
f) = do
      o -> Plan (k a) o ()
forall o (k :: * -> *). o -> Plan k o ()
yield o
b
      PlanT (k a) o m 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Moore a o -> PlanT (k a) o m b
go (Moore a o -> PlanT (k a) o m b)
-> (a -> Moore a o) -> a -> PlanT (k a) o m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Moore a o
f
  {-# INLINE auto #-}

instance Functor (Moore a) where
  fmap :: (a -> b) -> Moore a a -> Moore a b
fmap a -> b
f (Moore a
b a -> Moore a a
g) = b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (a -> b
f a
b) ((a -> b) -> Moore a a -> Moore a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Moore a a -> Moore a b) -> (a -> Moore a a) -> a -> Moore a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Moore a a
g)
  {-# INLINE fmap #-}
  a
a <$ :: a -> Moore a b -> Moore a a
<$ Moore a b
_ = a -> Moore a a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  {-# INLINE (<$) #-}

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

instance Applicative (Moore a) where
  pure :: a -> Moore a a
pure a
a = Moore a a
r where r :: Moore a a
r = a -> (a -> Moore a a) -> Moore a a
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore a
a (Moore a a -> a -> Moore a a
forall a b. a -> b -> a
const Moore a a
r)
  {-# INLINE pure #-}
  Moore a -> b
f a -> Moore a (a -> b)
ff <*> :: Moore a (a -> b) -> Moore a a -> Moore a b
<*> Moore a
a a -> Moore a a
fa  = b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (a -> b
f a
a) (\a
i -> a -> Moore a (a -> b)
ff a
i Moore a (a -> b) -> Moore a a -> Moore a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Moore a a
fa a
i)
  Moore a a
m <* :: Moore a a -> Moore a b -> Moore a a
<* Moore a b
_ = Moore a a
m
  {-# INLINE (<*) #-}
  Moore a a
_ *> :: Moore a a -> Moore a b -> Moore a b
*> Moore a b
n = Moore a b
n
  {-# INLINE (*>) #-}

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

-- | slow diagonalization
instance Monad (Moore a) where
  return :: a -> Moore a a
return = a -> Moore a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  Moore a a
k >>= :: Moore a a -> (a -> Moore a b) -> Moore a b
>>= a -> Moore a b
f = Moore a (Moore a b) -> Moore a b
forall a b. Moore a (Moore a b) -> Moore a b
j ((a -> Moore a b) -> Moore a a -> Moore a (Moore a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Moore a b
f Moore a a
k) where
    j :: Moore a (Moore a b) -> Moore a b
j (Moore Moore a b
a a -> Moore a (Moore a b)
g) = b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (Moore a b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract Moore a b
a) (\a
x -> Moore a (Moore a b) -> Moore a b
j (Moore a (Moore a b) -> Moore a b)
-> Moore a (Moore a b) -> Moore a b
forall a b. (a -> b) -> a -> b
$ (Moore a b -> Moore a b)
-> Moore a (Moore a b) -> Moore a (Moore a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Moore b
_ a -> Moore a b
h) -> a -> Moore a b
h a
x) (a -> Moore a (Moore a b)
g a
x))
  >> :: Moore a a -> Moore a b -> Moore a b
(>>) = Moore a a -> Moore a b -> Moore a b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

instance Copointed (Moore a) where
  copoint :: Moore a a -> a
copoint (Moore a
b a -> Moore a a
_) = a
b
  {-# INLINE copoint #-}

instance Comonad (Moore a) where
  extract :: Moore a a -> a
extract (Moore a
b a -> Moore a a
_) = a
b
  {-# INLINE extract #-}
  extend :: (Moore a a -> b) -> Moore a a -> Moore a b
extend Moore a a -> b
f w :: Moore a a
w@(Moore a
_ a -> Moore a a
g) = b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (Moore a a -> b
f Moore a a
w) ((Moore a a -> b) -> Moore a a -> Moore a b
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend Moore a a -> b
f (Moore a a -> Moore a b) -> (a -> Moore a a) -> a -> Moore a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Moore a a
g)

instance ComonadApply (Moore a) where
  Moore a -> b
f a -> Moore a (a -> b)
ff <@> :: Moore a (a -> b) -> Moore a a -> Moore a b
<@> Moore a
a a -> Moore a a
fa = b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (a -> b
f a
a) (\a
i -> a -> Moore a (a -> b)
ff a
i Moore a (a -> b) -> Moore a a -> Moore a b
forall (w :: * -> *) a b.
ComonadApply w =>
w (a -> b) -> w a -> w b
<@> a -> Moore a a
fa a
i)
  Moore a a
m <@ :: Moore a a -> Moore a b -> Moore a a
<@ Moore a b
_ = Moore a a
m
  {-# INLINE (<@) #-}
  Moore a a
_ @> :: Moore a a -> Moore a b -> Moore a b
@> Moore a b
n = Moore a b
n
  {-# INLINE (@>) #-}

instance Distributive (Moore a) where
  distribute :: f (Moore a a) -> Moore a (f a)
distribute f (Moore a a)
m = f a -> (a -> Moore a (f a)) -> Moore a (f a)
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore ((Moore a a -> a) -> f (Moore a a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Moore a a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f (Moore a a)
m) (f (Moore a a) -> Moore a (f a)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute (f (Moore a a) -> Moore a (f a))
-> (a -> f (Moore a a)) -> a -> Moore a (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Moore a a -> a -> Moore a a)
-> f (Moore a a) -> a -> f (Moore a a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive g, Functor f) =>
(a -> g b) -> f a -> g (f b)
collect (\(Moore a
_ a -> Moore a a
k) -> a -> Moore a a
k) f (Moore a a)
m)

instance Functor.Representable (Moore a) where
  type Rep (Moore a) = [a]
  index :: Moore a a -> Rep (Moore a) -> a
index = Moore a a -> Rep (Moore a) -> a
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve
  tabulate :: (Rep (Moore a) -> a) -> Moore a a
tabulate = (Rep (Moore a) -> a) -> Moore a a
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate
  {-# INLINE tabulate #-}

instance Cosieve Moore [] where
  cosieve :: Moore a b -> [a] -> b
cosieve (Moore b
b a -> Moore a b
_) [] = b
b
  cosieve (Moore b
_ a -> Moore a b
k) (a
a:[a]
as) = Moore a b -> [a] -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve (a -> Moore a b
k a
a) [a]
as

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

instance Profunctor.Corepresentable Moore where
  type Corep Moore = []
  cotabulate :: (Corep Moore d -> c) -> Moore d c
cotabulate Corep Moore d -> c
f = c -> (d -> Moore d c) -> Moore d c
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (Corep Moore d -> c
f []) ((d -> Moore d c) -> Moore d c) -> (d -> Moore d c) -> Moore d c
forall a b. (a -> b) -> a -> b
$ \d
a -> (Corep Moore d -> c) -> Moore d c
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ([d] -> c
Corep Moore d -> c
f([d] -> c) -> ([d] -> [d]) -> [d] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(d
ad -> [d] -> [d]
forall a. a -> [a] -> [a]
:))

instance MonadFix (Moore a) where
  mfix :: (a -> Moore a a) -> Moore a a
mfix = (a -> Moore a a) -> Moore a a
forall (f :: * -> *) a. Representable f => (a -> f a) -> f a
mfixRep

instance MonadZip (Moore a) where
  mzipWith :: (a -> b -> c) -> Moore a a -> Moore a b -> Moore a c
mzipWith = (a -> b -> c) -> Moore a a -> Moore a b -> Moore a c
forall (f :: * -> *) a b c.
Representable f =>
(a -> b -> c) -> f a -> f b -> f c
mzipWithRep
  munzip :: Moore a (a, b) -> (Moore a a, Moore a b)
munzip Moore a (a, b)
m = (((a, b) -> a) -> Moore a (a, b) -> Moore a a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst Moore a (a, b)
m, ((a, b) -> b) -> Moore a (a, b) -> Moore a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd Moore a (a, b)
m)

instance MonadReader [a] (Moore a) where
  ask :: Moore a [a]
ask = Moore a [a]
forall (f :: * -> *). Representable f => f (Rep f)
askRep
  local :: ([a] -> [a]) -> Moore a a -> Moore a a
local = ([a] -> [a]) -> Moore a a -> Moore a a
forall (f :: * -> *) a.
Representable f =>
(Rep f -> Rep f) -> f a -> f a
localRep

instance Closed Moore where
  closed :: Moore a b -> Moore (x -> a) (x -> b)
closed Moore a b
m = (Corep Moore (x -> a) -> x -> b) -> Moore (x -> a) (x -> b)
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ((Corep Moore (x -> a) -> x -> b) -> Moore (x -> a) (x -> b))
-> (Corep Moore (x -> a) -> x -> b) -> Moore (x -> a) (x -> b)
forall a b. (a -> b) -> a -> b
$ \Corep Moore (x -> a)
fs x
x -> Moore a b -> [a] -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve Moore a b
m (((x -> a) -> a) -> [x -> a] -> [a]
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) [x -> a]
Corep Moore (x -> a)
fs)

instance Semigroup b => Semigroup (Moore a b) where
  Moore b
x a -> Moore a b
f <> :: Moore a b -> Moore a b -> Moore a b
<> Moore b
y a -> Moore a b
g = b -> (a -> Moore a b) -> Moore a b
forall a b. b -> (a -> Moore a b) -> Moore a b
Moore (b
x b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
y) (a -> Moore a b
f (a -> Moore a b) -> (a -> Moore a b) -> a -> Moore a b
forall a. Semigroup a => a -> a -> a
<> a -> Moore a b
g)

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