module Control.Monad.Trans.Fresh.Delta where
import Control.Applicative
import Control.Arrow (first, second)
import Control.Comonad.Cofree
import Control.Monad.Trans.Class
import Data.Bits
import Data.Fresh
import Data.Triplet
newtype FreshT v m a = FreshT
{ runFreshT :: Cofree Triplet v -> m (a, Cofree Triplet v) }
seedDelta
:: v
-> (v -> v)
-> (v -> (v, v))
-> Cofree Triplet v
seedDelta seed sukk splt = go seed
where
go tt = tt `seq` (tt :< Triplet (go ll) (go mm) (go rr))
where
mm = sukk tt
(ll, rr) = splt tt
integerPairDelta :: (Integer, Integer) -> Cofree Triplet (Integer, Integer)
integerPairDelta n = seedDelta n sukk splt
where
sukk = second succ
splt (m, _) = let m' = m `shiftL` 1
in ((m', 0), (m' .|. 1, 0))
instance Functor m => Functor (FreshT v m) where
fmap f (FreshT xx) = FreshT $ \s -> fmap (first f) (xx s)
instance Applicative m => Applicative (FreshT v m) where
pure x = FreshT $ \s -> pure (x, s)
FreshT ff <*> FreshT xx = FreshT $ \(_ :< Triplet l _ r)
-> (\(f, sf) (x, _) -> (f x, sf)) <$> ff l <*> xx r
instance Monad m => Monad (FreshT v m) where
return x = FreshT $ \s -> return (x, s)
FreshT aa >>= f = FreshT $ \(_ :< Triplet l _ r) -> do
(a, _) <- aa l
let FreshT ff = f a
ff r
instance MonadTrans (FreshT v) where
lift m = FreshT $ \s -> do
r <- m
return (r, s)
instance Applicative m => Fresh v (FreshT v m) where
fresh = FreshT $ \(s :< Triplet _ s' _) -> pure (s, s')