{-# OPTIONS_GHC -Wall -fno-warn-warnings-deprecations #-}
{-# LANGUAGE DoRec                           #-}


-- | The data definition of a "TardisT"
-- as well as its primitive operations,
-- and straightforward combinators based on the primitives.
-- 
-- See Control.Monad.Tardis for the general explanation
-- of what a Tardis is and how to use it.
module Control.Monad.Trans.Tardis (
    -- * The Tardis monad transformer
    TardisT (TardisT, runTardisT)
  , evalTardisT
  , execTardisT

    -- * The Tardis monad
  , Tardis
  , runTardis
  , evalTardis
  , execTardis

    -- * Primitive Tardis operations
  , tardis

  , getPast
  , getFuture
  , sendPast
  , sendFuture

    -- * Composite Tardis operations
  , modifyForwards
  , modifyBackwards

  , getsPast
  , getsFuture

    -- * Other
  , mapTardisT
  , noState
  ) where

import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Morph


-- Definition
-------------------------------------------------

-- | A TardisT is parameterized by two state streams:
-- a 'backwards-traveling' state and a 'forwards-traveling' state.
-- This library consistently puts the backwards-traveling state first
-- whenever the two are seen together.
newtype TardisT bw fw m a = TardisT
  { TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT :: (bw, fw) -> m (a, (bw, fw))
    -- ^ A TardisT is merely an effectful state transformation
  }

-- | Using a Tardis with no monad underneath
-- will prove to be most common use case.
-- Practical uses of a TardisT require that the
-- underlying monad be an instance of MonadFix,
-- but note that the IO instance of MonadFix
-- is almost certainly unsuitable for use with
-- Tardis code.
type Tardis bw fw = TardisT bw fw Identity

-- | A Tardis is merely a pure state transformation.
runTardis :: Tardis bw fw a -> (bw, fw) -> (a, (bw, fw))
runTardis :: Tardis bw fw a -> (bw, fw) -> (a, (bw, fw))
runTardis Tardis bw fw a
m = Identity (a, (bw, fw)) -> (a, (bw, fw))
forall a. Identity a -> a
runIdentity (Identity (a, (bw, fw)) -> (a, (bw, fw)))
-> ((bw, fw) -> Identity (a, (bw, fw)))
-> (bw, fw)
-> (a, (bw, fw))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tardis bw fw a -> (bw, fw) -> Identity (a, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT Tardis bw fw a
m


-- Helpers
-------------------------------------------------

-- | Run a Tardis, and discard the final state,
-- observing only the resultant value.
evalTardisT :: Monad m => TardisT bw fw m a -> (bw, fw) -> m a
evalTardisT :: TardisT bw fw m a -> (bw, fw) -> m a
evalTardisT TardisT bw fw m a
t (bw, fw)
s = (a, (bw, fw)) -> a
forall a b. (a, b) -> a
fst ((a, (bw, fw)) -> a) -> m (a, (bw, fw)) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT TardisT bw fw m a
t (bw, fw)
s

-- | Run a Tardis, and discard the resultant value,
-- observing only the final state (of both streams).
-- Note that the 'final' state of the backwards-traveling state
-- is the state it reaches by traveling from the 'bottom'
-- of your code to the 'top'.
execTardisT :: Monad m => TardisT bw fw m a -> (bw, fw) -> m (bw, fw)
execTardisT :: TardisT bw fw m a -> (bw, fw) -> m (bw, fw)
execTardisT TardisT bw fw m a
t (bw, fw)
s = (a, (bw, fw)) -> (bw, fw)
forall a b. (a, b) -> b
snd ((a, (bw, fw)) -> (bw, fw)) -> m (a, (bw, fw)) -> m (bw, fw)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT TardisT bw fw m a
t (bw, fw)
s


-- | Run a Tardis, and discard the final state,
-- observing only the resultant value.
evalTardis :: Tardis bw fw a -> (bw, fw) -> a
evalTardis :: Tardis bw fw a -> (bw, fw) -> a
evalTardis Tardis bw fw a
t = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> ((bw, fw) -> Identity a) -> (bw, fw) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tardis bw fw a -> (bw, fw) -> Identity a
forall (m :: * -> *) bw fw a.
Monad m =>
TardisT bw fw m a -> (bw, fw) -> m a
evalTardisT Tardis bw fw a
t

-- | Run a Tardis, and discard the resultant value,
-- observing only the final state (of both streams).
execTardis :: Tardis bw fw a -> (bw, fw) -> (bw, fw)
execTardis :: Tardis bw fw a -> (bw, fw) -> (bw, fw)
execTardis Tardis bw fw a
t = Identity (bw, fw) -> (bw, fw)
forall a. Identity a -> a
runIdentity (Identity (bw, fw) -> (bw, fw))
-> ((bw, fw) -> Identity (bw, fw)) -> (bw, fw) -> (bw, fw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tardis bw fw a -> (bw, fw) -> Identity (bw, fw)
forall (m :: * -> *) bw fw a.
Monad m =>
TardisT bw fw m a -> (bw, fw) -> m (bw, fw)
execTardisT Tardis bw fw a
t


-- | A function that operates on the internal representation of a Tardis
-- can also be used on a Tardis.
mapTardisT :: (m (a, (bw, fw)) -> n (b, (bw, fw)))
           -> TardisT bw fw m a -> TardisT bw fw n b
mapTardisT :: (m (a, (bw, fw)) -> n (b, (bw, fw)))
-> TardisT bw fw m a -> TardisT bw fw n b
mapTardisT m (a, (bw, fw)) -> n (b, (bw, fw))
f TardisT bw fw m a
m = ((bw, fw) -> n (b, (bw, fw))) -> TardisT bw fw n b
forall bw fw (m :: * -> *) a.
((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
TardisT (((bw, fw) -> n (b, (bw, fw))) -> TardisT bw fw n b)
-> ((bw, fw) -> n (b, (bw, fw))) -> TardisT bw fw n b
forall a b. (a -> b) -> a -> b
$ m (a, (bw, fw)) -> n (b, (bw, fw))
f (m (a, (bw, fw)) -> n (b, (bw, fw)))
-> ((bw, fw) -> m (a, (bw, fw))) -> (bw, fw) -> n (b, (bw, fw))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT TardisT bw fw m a
m

-- | Some Tardises never observe the 'initial' state
-- of either state stream, so it is convenient
-- to simply hand dummy values to such Tardises.
-- 
-- > noState = (undefined, undefined)
noState :: (a, b)
noState :: (a, b)
noState = (a
forall a. HasCallStack => a
undefined, b
forall a. HasCallStack => a
undefined)


-- Instances
-------------------------------------------------

instance MonadFix m => Monad (TardisT bw fw m) where
  return :: a -> TardisT bw fw m a
return a
x = ((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
forall (m :: * -> *) bw fw a.
Monad m =>
((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis (((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a)
-> ((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
forall a b. (a -> b) -> a -> b
$ \(bw, fw)
s -> (a
x, (bw, fw)
s)
  TardisT bw fw m a
m >>= :: TardisT bw fw m a -> (a -> TardisT bw fw m b) -> TardisT bw fw m b
>>= a -> TardisT bw fw m b
f  = ((bw, fw) -> m (b, (bw, fw))) -> TardisT bw fw m b
forall bw fw (m :: * -> *) a.
((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
TardisT (((bw, fw) -> m (b, (bw, fw))) -> TardisT bw fw m b)
-> ((bw, fw) -> m (b, (bw, fw))) -> TardisT bw fw m b
forall a b. (a -> b) -> a -> b
$ \ ~(bw
bw, fw
fw) -> do
    rec (a
x,  ~(bw
bw'', fw
fw' )) <- TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT TardisT bw fw m a
m (bw
bw', fw
fw)
        (b
x', ~(bw
bw' , fw
fw'')) <- TardisT bw fw m b -> (bw, fw) -> m (b, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT (a -> TardisT bw fw m b
f a
x) (bw
bw, fw
fw')
    (b, (bw, fw)) -> m (b, (bw, fw))
forall (m :: * -> *) a. Monad m => a -> m a
return (b
x', (bw
bw'', fw
fw''))

instance MonadFix m => Functor (TardisT bw fw m) where
  fmap :: (a -> b) -> TardisT bw fw m a -> TardisT bw fw m b
fmap = (a -> b) -> TardisT bw fw m a -> TardisT bw fw m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance MonadFix m => Applicative (TardisT bw fw m) where
  pure :: a -> TardisT bw fw m a
pure = a -> TardisT bw fw m a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: TardisT bw fw m (a -> b) -> TardisT bw fw m a -> TardisT bw fw m b
(<*>) = TardisT bw fw m (a -> b) -> TardisT bw fw m a -> TardisT bw fw m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap


instance MonadTrans (TardisT bw fw) where
  lift :: m a -> TardisT bw fw m a
lift m a
m = ((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
forall bw fw (m :: * -> *) a.
((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
TardisT (((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a)
-> ((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
forall a b. (a -> b) -> a -> b
$ \(bw, fw)
s -> do
    a
x <- m a
m
    (a, (bw, fw)) -> m (a, (bw, fw))
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, (bw, fw)
s)

instance MonadFix m => MonadFix (TardisT bw fw m) where
  mfix :: (a -> TardisT bw fw m a) -> TardisT bw fw m a
mfix a -> TardisT bw fw m a
f = ((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
forall bw fw (m :: * -> *) a.
((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
TardisT (((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a)
-> ((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
forall a b. (a -> b) -> a -> b
$ \(bw, fw)
s -> do
    rec (a
x, (bw, fw)
s') <- TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
forall bw fw (m :: * -> *) a.
TardisT bw fw m a -> (bw, fw) -> m (a, (bw, fw))
runTardisT (a -> TardisT bw fw m a
f a
x) (bw, fw)
s
    (a, (bw, fw)) -> m (a, (bw, fw))
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, (bw, fw)
s')

instance MFunctor (TardisT bw fw) where
  hoist :: (forall a. m a -> n a) -> TardisT bw fw m b -> TardisT bw fw n b
hoist forall a. m a -> n a
f = (m (b, (bw, fw)) -> n (b, (bw, fw)))
-> TardisT bw fw m b -> TardisT bw fw n b
forall (m :: * -> *) a bw fw (n :: * -> *) b.
(m (a, (bw, fw)) -> n (b, (bw, fw)))
-> TardisT bw fw m a -> TardisT bw fw n b
mapTardisT m (b, (bw, fw)) -> n (b, (bw, fw))
forall a. m a -> n a
f

-- Basics
-------------------------------------------------

-- | From a stateful computation, construct a Tardis.
-- This is the pure parallel to the constructor "TardisT",
-- and is polymorphic in the transformed monad.
tardis :: Monad m => ((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis :: ((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis (bw, fw) -> (a, (bw, fw))
f = ((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
forall bw fw (m :: * -> *) a.
((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
TardisT (((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a)
-> ((bw, fw) -> m (a, (bw, fw))) -> TardisT bw fw m a
forall a b. (a -> b) -> a -> b
$ \(bw, fw)
s -> (a, (bw, fw)) -> m (a, (bw, fw))
forall (m :: * -> *) a. Monad m => a -> m a
return ((bw, fw) -> (a, (bw, fw))
f (bw, fw)
s)

-- | Retrieve the current value of the 'forwards-traveling' state,
-- which therefore came forwards from the past.
-- You can think of forwards-traveling state as traveling
-- 'downwards' through your code.
getPast :: Monad m => TardisT bw fw m fw
getPast :: TardisT bw fw m fw
getPast = ((bw, fw) -> (fw, (bw, fw))) -> TardisT bw fw m fw
forall (m :: * -> *) bw fw a.
Monad m =>
((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis (((bw, fw) -> (fw, (bw, fw))) -> TardisT bw fw m fw)
-> ((bw, fw) -> (fw, (bw, fw))) -> TardisT bw fw m fw
forall a b. (a -> b) -> a -> b
$ \ ~(bw
bw, fw
fw)  -> (fw
fw, (bw
bw, fw
fw))

-- | Retrieve the current value of the 'backwards-traveling' state,
-- which therefore came backwards from the future.
-- You can think of backwards-traveling state as traveling
-- 'upwards' through your code.
getFuture :: Monad m => TardisT bw fw m bw
getFuture :: TardisT bw fw m bw
getFuture = ((bw, fw) -> (bw, (bw, fw))) -> TardisT bw fw m bw
forall (m :: * -> *) bw fw a.
Monad m =>
((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis (((bw, fw) -> (bw, (bw, fw))) -> TardisT bw fw m bw)
-> ((bw, fw) -> (bw, (bw, fw))) -> TardisT bw fw m bw
forall a b. (a -> b) -> a -> b
$ \ ~(bw
bw, fw
fw)  -> (bw
bw, (bw
bw, fw
fw))

-- | Set the current value of the 'backwards-traveling' state,
-- which will therefore be sent backwards to the past.
-- This value can be retrieved by calls to "getFuture"
-- located 'above' the current location,
-- unless it is overwritten by an intervening "sendPast".
sendPast :: Monad m => bw -> TardisT bw fw m ()
sendPast :: bw -> TardisT bw fw m ()
sendPast bw
bw' = ((bw, fw) -> ((), (bw, fw))) -> TardisT bw fw m ()
forall (m :: * -> *) bw fw a.
Monad m =>
((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis (((bw, fw) -> ((), (bw, fw))) -> TardisT bw fw m ())
-> ((bw, fw) -> ((), (bw, fw))) -> TardisT bw fw m ()
forall a b. (a -> b) -> a -> b
$ \ ~(bw
_bw, fw
fw) -> ((), (bw
bw', fw
fw))

-- | Set the current value of the 'forwards-traveling' state,
-- which will therefore be sent forwards to the future.
-- This value can be retrieved by calls to "getPast"
-- located 'below' the current location,
-- unless it is overwritten by an intervening "sendFuture".
sendFuture :: Monad m => fw -> TardisT bw fw m ()
sendFuture :: fw -> TardisT bw fw m ()
sendFuture fw
fw' = ((bw, fw) -> ((), (bw, fw))) -> TardisT bw fw m ()
forall (m :: * -> *) bw fw a.
Monad m =>
((bw, fw) -> (a, (bw, fw))) -> TardisT bw fw m a
tardis (((bw, fw) -> ((), (bw, fw))) -> TardisT bw fw m ())
-> ((bw, fw) -> ((), (bw, fw))) -> TardisT bw fw m ()
forall a b. (a -> b) -> a -> b
$ \ ~(bw
bw, fw
_fw) -> ((), (bw
bw, fw
fw'))


-- | Modify the forwards-traveling state
-- as it passes through from past to future.
modifyForwards :: MonadFix m => (fw -> fw) -> TardisT bw fw m ()
modifyForwards :: (fw -> fw) -> TardisT bw fw m ()
modifyForwards fw -> fw
f = TardisT bw fw m fw
forall (m :: * -> *) bw fw. Monad m => TardisT bw fw m fw
getPast TardisT bw fw m fw
-> (fw -> TardisT bw fw m ()) -> TardisT bw fw m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= fw -> TardisT bw fw m ()
forall (m :: * -> *) fw bw. Monad m => fw -> TardisT bw fw m ()
sendFuture (fw -> TardisT bw fw m ())
-> (fw -> fw) -> fw -> TardisT bw fw m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. fw -> fw
f

-- | Modify the backwards-traveling state
-- as it passes through from future to past.
modifyBackwards :: MonadFix m => (bw -> bw) -> TardisT bw fw m ()
modifyBackwards :: (bw -> bw) -> TardisT bw fw m ()
modifyBackwards bw -> bw
f = do
  rec
    bw -> TardisT bw fw m ()
forall (m :: * -> *) bw fw. Monad m => bw -> TardisT bw fw m ()
sendPast (bw -> bw
f bw
x)
    bw
x <- TardisT bw fw m bw
forall (m :: * -> *) bw fw. Monad m => TardisT bw fw m bw
getFuture
  () -> TardisT bw fw m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Retrieve a specific view of the forwards-traveling state.
getsPast :: MonadFix m => (fw -> a) -> TardisT bw fw m a
getsPast :: (fw -> a) -> TardisT bw fw m a
getsPast fw -> a
f = (fw -> a) -> TardisT bw fw m fw -> TardisT bw fw m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap fw -> a
f TardisT bw fw m fw
forall (m :: * -> *) bw fw. Monad m => TardisT bw fw m fw
getPast


-- | Retrieve a specific view of the backwards-traveling state.
getsFuture :: MonadFix m => (bw -> a) -> TardisT bw fw m a
getsFuture :: (bw -> a) -> TardisT bw fw m a
getsFuture bw -> a
f = (bw -> a) -> TardisT bw fw m bw -> TardisT bw fw m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap bw -> a
f TardisT bw fw m bw
forall (m :: * -> *) bw fw. Monad m => TardisT bw fw m bw
getFuture