Moore.hs

{-# LANGUAGE GADTs, InstanceSigs, MultiParamTypeClasses, TypeApplications, TypeFamilies, TupleSections #-}

module Moore where

import Control.Comonad
import Control.Monad.Zip
import Control.Monad.Reader
import Data.Copointed
import Data.Distributive
import Data.Machine.Plan
import Data.Machine.Process
import Data.Machine.Type
import Data.Pointed
import Data.Profunctor
import Data.Profunctor.Sieve
import Data.Profunctor.Strong
import Data.Profunctor.Rep as Profunctor
import Data.Functor.Rep as Functor

-- | 'Moore' machines.
-- A Moore machine is a finite-state machine described by three parameters:
-- an initial state, a transition function that updates the state based on
-- input, and an output function that maps from a state to an output type.
-- In contrast with 'Mealy' machines, the output of a Moore machine depends
-- only on the current state, rather than the product of input and state.
-- We use a GADT so as to hide the internal state from consumers.
data Moore a b where
  Moore :: s -> (s -> a -> s) -> (s -> b) -> Moore a b

-- | Accumulate the input as a sequence.
logMoore :: Monoid m => Moore m m
logMoore = Moore mempty mappend id
{-# INLINE logMoore #-}

-- | An alternate method of defining Moore machines provided
-- for backwards compatibility. The 'Moore' constructor is
-- somewhat more ergonomic.
unfoldMoore :: (s -> (b, a -> s)) -> s -> Moore a b
unfoldMoore go start = Moore start (snd . go) (fst . go)

instance Automaton Moore where
  auto (Moore start step done) = construct (go start) where
    go st = do
      yield (done st)
      next <- await
      go (step st next)
  {-# INLINE auto #-}

instance Functor (Moore a) where
  fmap f (Moore start step done) = Moore start step (f . done)
  {-# INLINE fmap #-}
  a <$ _ = pure a
  {-# INLINE (<$) #-}

instance Profunctor Moore where
  rmap = fmap
  {-# INLINE rmap #-}
  lmap f (Moore start step done) = Moore start (\s -> step s . f) done
  {-# INLINE lmap #-}
  dimap f g (Moore start step done) = Moore start (\s -> step s . f) (g . done)
  {-# INLINE dimap #-}

instance Applicative (Moore a) where
  pure b = Moore () (\_ _ -> ()) (const b)
  {-# INLINE pure #-}

  Moore sf tf df <*> Moore s t d = Moore start step done where
    start = (sf, s)
    step (n, x) a = (tf n a, t x a)
    done (f, x) = df f (d x)

  m <* _ = m
  {-# INLINE (<*) #-}

  _ *> m = m
  {-# INLINE (*>) #-}

instance Pointed (Moore a) where
  point = pure
  {-# INLINE point #-}

-- | slow diagonalization
instance Monad (Moore a) where
  return = pure
  {-# INLINE return #-}
  (Moore start step done) >>= f = Moore start step (extract . f . done)
  (>>) = (*>)

instance Copointed (Moore a) where
  copoint = extract
  {-# INLINE copoint #-}

instance Comonad (Moore a) where
  extract (Moore start _ done) = done start
  {-# INLINE extract #-}
  duplicate (Moore start step done) = Moore start step (pure . done)

instance ComonadApply (Moore a) where
  (<@>) = (<*>)
  m <@ _ = m
  {-# INLINE (<@) #-}
  _ @> m = m
  {-# INLINE (@>) #-}

instance Distributive (Moore a) where
  distribute = pure . fmap extract

instance Functor.Representable (Moore a) where
  type Rep (Moore a) = [a]
  index = cosieve
  tabulate = cotabulate
  {-# INLINE tabulate #-}

-- | Enables extracting a the last answer from a 'Moore' without
-- compiling it to a 'Machine'.
--
-- @
--  cosieve (ask :: Moore Int [Int]) [1::Int, 2, 3]
--  >>> [3, 2, 1]
-- @
--
instance Cosieve Moore [] where
  cosieve :: Moore a b -> [a] -> b
  cosieve (Moore start _ done) [] = done start
  cosieve (Moore start step0 done0) (a:as) =
    cosieve (Moore (start, a) step done) as where
    step (st, x) y = (step0 st x, y)
    done (st, x)   = done0 (step0 st x)

instance Costrong Moore where
  unfirst = unfirstCorep
  unsecond = unsecondCorep

instance Profunctor.Corepresentable Moore where
  type Corep Moore = []
  cotabulate :: ([d] -> c) -> Moore d c
  cotabulate = Moore [] (flip (:))

instance MonadZip (Moore a) where
  mzipWith = mzipWithRep
  munzip m = (fmap fst m, fmap snd m)

-- | Provides access to the history of all hitherto-encountered input
-- values, most-recently-used first.
--
-- @
--  run (source [1,2,3] ~> auto (ask :: Moore Int [Int]))
--  >>> [[], [1], [2,1], [3,2,1]]
-- @
instance MonadReader [a] (Moore a) where
  ask = askRep
  local = localRep

instance Closed Moore where
  closed (Moore start step done)
    = Moore (const start) (\f t x -> step (f x) (t x)) (\f x -> done (f x))