{-# LANGUAGE CPP        #-}
{-# LANGUAGE Rank2Types #-}
-- We disable the following warning because this module purposefully defines
-- orphan instances. This is a design decision in Dunai, so that we give
-- implementors further flexibility while giving most users the features they
-- expect.
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Copyright  : (c) Ivan Perez and Manuel Baerenz, 2016
-- License    : BSD3
-- Maintainer : ivan.perez@keera.co.uk
--
-- Monadic Stream Functions are synchronized stream functions with side
-- effects.
--
-- 'MSF's are defined by a function
-- @unMSF :: MSF m a b -> a -> m (b, MSF m a b)@
-- that executes one step of a simulation, and produces an output in a monadic
-- context, and a continuation to be used for future steps.
--
-- 'MSF's are a generalisation of the implementation mechanism used by Yampa,
-- Wormholes and other FRP and reactive implementations.
--
-- When combined with different monads, they produce interesting effects. For
-- example, when combined with the 'Maybe' monad, they become transformations
-- that may stop producing outputs (and continuations). The 'Either' monad
-- gives rise to 'MSF's that end with a result (akin to Tasks in Yampa, and
-- Monadic FRP).
--
-- Flattening, that is, going from some structure @MSF (t m) a b@ to @MSF m a b@
-- for a specific transformer @t@ often gives rise to known FRP constructs.
-- For instance, flattening with 'EitherT' gives rise to switching, and
-- flattening with 'ListT' gives rise to parallelism with broadcasting.
--
-- 'MSF's can be used to implement many FRP variants, including Arrowized FRP,
-- Classic FRP, and plain reactive programming. Arrowized and applicative
-- syntax are both supported.
--
-- For a very detailed introduction to 'MSF's, see:
-- <http://dl.acm.org/citation.cfm?id=2976010>
-- (mirror: <http://www.cs.nott.ac.uk/~psxip1/#FRPRefactored>).
module Data.MonadicStreamFunction.Core
  ( -- * Types
    MSF
    -- * Lifting and Monadic transformations
    -- ** Lifting point-wise computations
  , constM
  , arrM
  , liftBaseM
    -- ** Trans-monadic MSF combinators
    -- *** MonadBase
  , liftBaseS
  , (^>>>)
  , (>>>^)
    -- *** MonadTrans
  , liftTransS
    -- *** Generic Monadic Transformations
  , morphS
  , morphGS
    -- * Depending on the past
  , feedback
    -- * Simulation
  , reactimate
  , embed
  , module X
  )
  where

-- External imports
import           Control.Arrow             (Arrow (..), (>>>))
import qualified Control.Arrow             as X
import           Control.Category          as C (id, (.))
import           Control.Monad.Base        (MonadBase, liftBase)
import           Control.Monad.Trans.Class (MonadTrans, lift)
import           Prelude                   hiding (id, sum, (.))

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative(..))
#endif

-- Internal imports
import Data.MonadicStreamFunction.InternalCore (MSF, embed, feedback, morphGS,
                                                reactimate)

-- * Definitions

-- | 'Arrow' instance for 'MSF's.
instance Monad m => Arrow (MSF m) where
  arr :: (b -> c) -> MSF m b c
arr b -> c
f = (b -> m c) -> MSF m b c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM (c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> m c) -> (b -> c) -> b -> m c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> c
f)

  first :: MSF m b c -> MSF m (b, d) (c, d)
first =
    -- This implementation is equivalent to:
    -- first sf = MSF $ \(a, c) -> do
    --   (b, sf') <- unMSF sf a
    --   b `seq` return ((b, c), first sf')
    (forall c. (b -> m (c, c)) -> (b, d) -> m ((c, d), c))
-> MSF m b c -> MSF m (b, d) (c, d)
forall (m2 :: * -> *) a1 (m1 :: * -> *) b1 a2 b2.
Monad m2 =>
(forall c. (a1 -> m1 (b1, c)) -> a2 -> m2 (b2, c))
-> MSF m1 a1 b1 -> MSF m2 a2 b2
morphGS ((forall c. (b -> m (c, c)) -> (b, d) -> m ((c, d), c))
 -> MSF m b c -> MSF m (b, d) (c, d))
-> (forall c. (b -> m (c, c)) -> (b, d) -> m ((c, d), c))
-> MSF m b c
-> MSF m (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \b -> m (c, c)
f (a, c) -> do
      (c
b, c
msf') <- b -> m (c, c)
f b
a
      ((c, d), c) -> m ((c, d), c)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
b, d
c), c
msf')

-- * Functor and applicative instances

-- | 'Functor' instance for 'MSF's.
instance Monad m => Functor (MSF m a) where
  fmap :: (a -> b) -> MSF m a a -> MSF m a b
fmap a -> b
f MSF m a a
msf = MSF m a a
msf MSF m a a -> MSF m a b -> MSF m a b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a -> b) -> MSF m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f

-- | 'Applicative' instance for 'MSF's.
instance (Functor m, Monad m) => Applicative (MSF m a) where
  -- It is possible to define this instance with only Applicative m
  pure :: a -> MSF m a a
pure = (a -> a) -> MSF m a a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> a) -> MSF m a a) -> (a -> a -> a) -> a -> MSF m a a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> a -> a
forall a b. a -> b -> a
const

  MSF m a (a -> b)
fs <*> :: MSF m a (a -> b) -> MSF m a a -> MSF m a b
<*> MSF m a a
bs = (MSF m a (a -> b)
fs MSF m a (a -> b) -> MSF m a a -> MSF m a (a -> b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& MSF m a a
bs) MSF m a (a -> b, a) -> MSF m (a -> b, a) b -> MSF m a b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((a -> b, a) -> b) -> MSF m (a -> b, a) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($))

-- ** Lifting point-wise computations

-- | Lifts a monadic computation into a Stream.
constM :: Monad m => m b -> MSF m a b
constM :: m b -> MSF m a b
constM = (a -> m b) -> MSF m a b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM ((a -> m b) -> MSF m a b) -> (m b -> a -> m b) -> m b -> MSF m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m b -> a -> m b
forall a b. a -> b -> a
const

-- | Apply a monadic transformation to every element of the input stream.
--
-- Generalisation of 'arr' from 'Arrow' to monadic functions.
arrM :: Monad m => (a -> m b) -> MSF m a b
arrM :: (a -> m b) -> MSF m a b
arrM a -> m b
f =
  -- This implementation is equivalent to:
  -- arrM f = go
  --   where
  --     go = MSF $ \a -> do
  --            b <- f a
  --            return (b, go)
  (forall c. (a -> m (a, c)) -> a -> m (b, c))
-> MSF m a a -> MSF m a b
forall (m2 :: * -> *) a1 (m1 :: * -> *) b1 a2 b2.
Monad m2 =>
(forall c. (a1 -> m1 (b1, c)) -> a2 -> m2 (b2, c))
-> MSF m1 a1 b1 -> MSF m2 a2 b2
morphGS (\a -> m (a, c)
i a
a -> a -> m (a, c)
i a
a m (a, c) -> ((a, c) -> m (b, c)) -> m (b, c)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
_, c
c) -> a -> m b
f a
a m b -> (b -> m (b, c)) -> m (b, c)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
b -> (b, c) -> m (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)) MSF m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id

-- | Monadic lifting from one monad into another
liftBaseM :: (Monad m2, MonadBase m1 m2) => (a -> m1 b) -> MSF m2 a b
liftBaseM :: (a -> m1 b) -> MSF m2 a b
liftBaseM = (a -> m2 b) -> MSF m2 a b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM ((a -> m2 b) -> MSF m2 a b)
-> ((a -> m1 b) -> a -> m2 b) -> (a -> m1 b) -> MSF m2 a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (m1 b -> m2 b
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (m1 b -> m2 b) -> (a -> m1 b) -> a -> m2 b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.)

-- ** MSF combinators that apply monad transformations

-- | Lift innermost monadic actions in monad stack (generalisation of
-- 'liftIO').
liftBaseS :: (Monad m2, MonadBase m1 m2) => MSF m1 a b -> MSF m2 a b
liftBaseS :: MSF m1 a b -> MSF m2 a b
liftBaseS = (forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS forall c. m1 c -> m2 c
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

-- *** MonadBase

-- | Lift the first 'MSF' into the monad of the second.
(^>>>) :: MonadBase m1 m2 => MSF m1 a b -> MSF m2 b c -> MSF m2 a c
MSF m1 a b
sf1 ^>>> :: MSF m1 a b -> MSF m2 b c -> MSF m2 a c
^>>> MSF m2 b c
sf2 = MSF m1 a b -> MSF m2 a b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, MonadBase m1 m2) =>
MSF m1 a b -> MSF m2 a b
liftBaseS MSF m1 a b
sf1 MSF m2 a b -> MSF m2 b c -> MSF m2 a c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m2 b c
sf2
{-# INLINE (^>>>) #-}

-- | Lift the second 'MSF' into the monad of the first.
(>>>^) :: MonadBase m1 m2 => MSF m2 a b -> MSF m1 b c -> MSF m2 a c
MSF m2 a b
sf1 >>>^ :: MSF m2 a b -> MSF m1 b c -> MSF m2 a c
>>>^ MSF m1 b c
sf2 = MSF m2 a b
sf1 MSF m2 a b -> MSF m2 b c -> MSF m2 a c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m1 b c -> MSF m2 b c
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, MonadBase m1 m2) =>
MSF m1 a b -> MSF m2 a b
liftBaseS MSF m1 b c
sf2
{-# INLINE (>>>^) #-}

-- *** MonadTrans

-- | Lift inner monadic actions in monad stacks.
liftTransS :: (MonadTrans t, Monad m, Monad (t m))
           => MSF m a b
           -> MSF (t m) a b
liftTransS :: MSF m a b -> MSF (t m) a b
liftTransS = (forall c. m c -> t m c) -> MSF m a b -> MSF (t m) a b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS forall c. m c -> t m c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- *** Generic monadic transformation

-- | Apply trans-monadic actions (in an arbitrary way).
--
-- This is just a convenience function when you have a function to move across
-- monads, because the signature of 'morphGS' is a bit complex.
morphS :: (Monad m2, Monad m1)
       => (forall c . m1 c -> m2 c)
       -> MSF m1 a b
       -> MSF m2 a b
morphS :: (forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS forall c. m1 c -> m2 c
morph = (forall c. (a -> m1 (b, c)) -> a -> m2 (b, c))
-> MSF m1 a b -> MSF m2 a b
forall (m2 :: * -> *) a1 (m1 :: * -> *) b1 a2 b2.
Monad m2 =>
(forall c. (a1 -> m1 (b1, c)) -> a2 -> m2 (b2, c))
-> MSF m1 a1 b1 -> MSF m2 a2 b2
morphGS forall c. (a -> m1 (b, c)) -> a -> m2 (b, c)
forall a c. (a -> m1 c) -> a -> m2 c
morph'
  where
    -- The following makes the a's and the b's the same, and it just says:
    -- whatever function m1F you give me to apply to every sample, I use morph
    -- on the result to go from m1 to m2.
    --
    -- Remember that:
    -- morphGS :: Monad m2
    --         => (forall c . (a1 -> m1 (b1, c)) -> (a2 -> m2 (b2, c)))
    --           -- ^ The natural transformation. @mi@, @ai@ and @bi@ for
    --           --   @i = 1, 2@ can be chosen freely, but @c@ must be
    --           --   universally quantified
    --         -> MSF m1 a1 b1
    --         -> MSF m2 a2 b2
    --
    --  morph' :: (forall c . (a -> m1 (b, c)) -> (a -> m2 (b, c)))
    morph' :: (a -> m1 c) -> a -> m2 c
morph' a -> m1 c
m1F = m1 c -> m2 c
forall c. m1 c -> m2 c
morph (m1 c -> m2 c) -> (a -> m1 c) -> a -> m2 c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m1 c
m1F