{-# LANGUAGE RankNTypes, LambdaCase, GeneralizedNewtypeDeriving, DeriveFunctor, BangPatterns #-}
module Control.Monad.Tangle (TangleT(..), hitch, evalTangleT) where

import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Functor.Identity

newtype TangleT t m a = TangleT
  { TangleT t m a -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
runTangleT :: t (TangleT t m) -> t Maybe -> m (t Maybe, a) }
  deriving a -> TangleT t m b -> TangleT t m a
(a -> b) -> TangleT t m a -> TangleT t m b
(forall a b. (a -> b) -> TangleT t m a -> TangleT t m b)
-> (forall a b. a -> TangleT t m b -> TangleT t m a)
-> Functor (TangleT t m)
forall a b. a -> TangleT t m b -> TangleT t m a
forall a b. (a -> b) -> TangleT t m a -> TangleT t m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (t :: (* -> *) -> *) (m :: * -> *) a b.
Functor m =>
a -> TangleT t m b -> TangleT t m a
forall (t :: (* -> *) -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> TangleT t m a -> TangleT t m b
<$ :: a -> TangleT t m b -> TangleT t m a
$c<$ :: forall (t :: (* -> *) -> *) (m :: * -> *) a b.
Functor m =>
a -> TangleT t m b -> TangleT t m a
fmap :: (a -> b) -> TangleT t m a -> TangleT t m b
$cfmap :: forall (t :: (* -> *) -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> TangleT t m a -> TangleT t m b
Functor

instance Monad m => Applicative (TangleT t m) where
  pure :: a -> TangleT t m a
pure a :: a
a = (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall (t :: (* -> *) -> *) (m :: * -> *) a.
(t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
TangleT ((t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a)
-> (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall a b. (a -> b) -> a -> b
$ \_ mem :: t Maybe
mem -> (t Maybe, a) -> m (t Maybe, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t Maybe
mem, a
a)
  TangleT m :: t (TangleT t m) -> t Maybe -> m (t Maybe, a -> b)
m <*> :: TangleT t m (a -> b) -> TangleT t m a -> TangleT t m b
<*> TangleT n :: t (TangleT t m) -> t Maybe -> m (t Maybe, a)
n = (t (TangleT t m) -> t Maybe -> m (t Maybe, b)) -> TangleT t m b
forall (t :: (* -> *) -> *) (m :: * -> *) a.
(t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
TangleT ((t (TangleT t m) -> t Maybe -> m (t Maybe, b)) -> TangleT t m b)
-> (t (TangleT t m) -> t Maybe -> m (t Maybe, b)) -> TangleT t m b
forall a b. (a -> b) -> a -> b
$ \ts :: t (TangleT t m)
ts mem :: t Maybe
mem -> t (TangleT t m) -> t Maybe -> m (t Maybe, a -> b)
m t (TangleT t m)
ts t Maybe
mem
    m (t Maybe, a -> b)
-> ((t Maybe, a -> b) -> m (t Maybe, b)) -> m (t Maybe, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(mem' :: t Maybe
mem', f :: a -> b
f) -> (\(mem'' :: t Maybe
mem'', a :: a
a) -> (t Maybe
mem'', a -> b
f a
a)) ((t Maybe, a) -> (t Maybe, b)) -> m (t Maybe, a) -> m (t Maybe, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
n t (TangleT t m)
ts t Maybe
mem'
instance Monad m => Monad (TangleT t m) where
  TangleT m :: t (TangleT t m) -> t Maybe -> m (t Maybe, a)
m >>= :: TangleT t m a -> (a -> TangleT t m b) -> TangleT t m b
>>= k :: a -> TangleT t m b
k = (t (TangleT t m) -> t Maybe -> m (t Maybe, b)) -> TangleT t m b
forall (t :: (* -> *) -> *) (m :: * -> *) a.
(t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
TangleT ((t (TangleT t m) -> t Maybe -> m (t Maybe, b)) -> TangleT t m b)
-> (t (TangleT t m) -> t Maybe -> m (t Maybe, b)) -> TangleT t m b
forall a b. (a -> b) -> a -> b
$ \ts :: t (TangleT t m)
ts mem :: t Maybe
mem -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
m t (TangleT t m)
ts t Maybe
mem m (t Maybe, a)
-> ((t Maybe, a) -> m (t Maybe, b)) -> m (t Maybe, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(mem' :: t Maybe
mem', a :: a
a) -> TangleT t m b -> t (TangleT t m) -> t Maybe -> m (t Maybe, b)
forall (t :: (* -> *) -> *) (m :: * -> *) a.
TangleT t m a -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
runTangleT (a -> TangleT t m b
k a
a) t (TangleT t m)
ts t Maybe
mem'

instance (Monad m, Semigroup a) => Semigroup (TangleT t m a) where
  <> :: TangleT t m a -> TangleT t m a -> TangleT t m a
(<>) = (a -> a -> a) -> TangleT t m a -> TangleT t m a -> TangleT t m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Monad m, Monoid a) => Monoid (TangleT t m a) where
    mempty :: TangleT t m a
mempty = a -> TangleT t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

instance MonadTrans (TangleT t) where
  lift :: m a -> TangleT t m a
lift m :: m a
m = (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall (t :: (* -> *) -> *) (m :: * -> *) a.
(t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
TangleT ((t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a)
-> (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall a b. (a -> b) -> a -> b
$ \_ mem :: t Maybe
mem -> (a -> (t Maybe, a)) -> m a -> m (t Maybe, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) t Maybe
mem) m a
m 

instance MonadIO m => MonadIO (TangleT t m) where
  liftIO :: IO a -> TangleT t m a
liftIO m :: IO a
m = (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall (t :: (* -> *) -> *) (m :: * -> *) a.
(t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
TangleT ((t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a)
-> (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall a b. (a -> b) -> a -> b
$ \_ mem :: t Maybe
mem -> (a -> (t Maybe, a)) -> m a -> m (t Maybe, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) t Maybe
mem) (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m)

hitch :: Monad m
  => (forall h f. Functor f => (h a -> f (h a)) -> t h -> f (t h))
  -> TangleT t m a
hitch :: (forall (h :: * -> *) (f :: * -> *).
 Functor f =>
 (h a -> f (h a)) -> t h -> f (t h))
-> TangleT t m a
hitch l :: forall (h :: * -> *) (f :: * -> *).
Functor f =>
(h a -> f (h a)) -> t h -> f (t h)
l = (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall (t :: (* -> *) -> *) (m :: * -> *) a.
(t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
TangleT ((t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a)
-> (t (TangleT t m) -> t Maybe -> m (t Maybe, a)) -> TangleT t m a
forall a b. (a -> b) -> a -> b
$ \ts :: t (TangleT t m)
ts mem :: t Maybe
mem -> Const (m (t Maybe, a)) (t Maybe) -> m (t Maybe, a)
forall a k (b :: k). Const a b -> a
getConst (Const (m (t Maybe, a)) (t Maybe) -> m (t Maybe, a))
-> Const (m (t Maybe, a)) (t Maybe) -> m (t Maybe, a)
forall a b. (a -> b) -> a -> b
$ ((Maybe a -> Const (m (t Maybe, a)) (Maybe a))
 -> t Maybe -> Const (m (t Maybe, a)) (t Maybe))
-> t Maybe
-> (Maybe a -> Const (m (t Maybe, a)) (Maybe a))
-> Const (m (t Maybe, a)) (t Maybe)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe a -> Const (m (t Maybe, a)) (Maybe a))
-> t Maybe -> Const (m (t Maybe, a)) (t Maybe)
forall (h :: * -> *) (f :: * -> *).
Functor f =>
(h a -> f (h a)) -> t h -> f (t h)
l t Maybe
mem ((Maybe a -> Const (m (t Maybe, a)) (Maybe a))
 -> Const (m (t Maybe, a)) (t Maybe))
-> (Maybe a -> Const (m (t Maybe, a)) (Maybe a))
-> Const (m (t Maybe, a)) (t Maybe)
forall a b. (a -> b) -> a -> b
$ \case
  Just a :: a
a -> m (t Maybe, a) -> Const (m (t Maybe, a)) (Maybe a)
forall k a (b :: k). a -> Const a b
Const (m (t Maybe, a) -> Const (m (t Maybe, a)) (Maybe a))
-> m (t Maybe, a) -> Const (m (t Maybe, a)) (Maybe a)
forall a b. (a -> b) -> a -> b
$ (t Maybe, a) -> m (t Maybe, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t Maybe
mem, a
a)
  Nothing -> m (t Maybe, a) -> Const (m (t Maybe, a)) (Maybe a)
forall k a (b :: k). a -> Const a b
Const
    (m (t Maybe, a) -> Const (m (t Maybe, a)) (Maybe a))
-> m (t Maybe, a) -> Const (m (t Maybe, a)) (Maybe a)
forall a b. (a -> b) -> a -> b
$ ((t Maybe, a) -> (t Maybe, a)) -> m (t Maybe, a) -> m (t Maybe, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(mem' :: t Maybe
mem', a :: a
a) -> let !(Identity mem'' :: t Maybe
mem'') = (Maybe a -> Identity (Maybe a)) -> t Maybe -> Identity (t Maybe)
forall (h :: * -> *) (f :: * -> *).
Functor f =>
(h a -> f (h a)) -> t h -> f (t h)
l (Identity (Maybe a) -> Maybe a -> Identity (Maybe a)
forall a b. a -> b -> a
const (Identity (Maybe a) -> Maybe a -> Identity (Maybe a))
-> Identity (Maybe a) -> Maybe a -> Identity (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> Identity (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Identity (Maybe a)) -> Maybe a -> Identity (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a) t Maybe
mem' in (t Maybe
mem'', a
a))
    (m (t Maybe, a) -> m (t Maybe, a))
-> m (t Maybe, a) -> m (t Maybe, a)
forall a b. (a -> b) -> a -> b
$ TangleT t m a -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
forall (t :: (* -> *) -> *) (m :: * -> *) a.
TangleT t m a -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
runTangleT (Const (TangleT t m a) (t (TangleT t m)) -> TangleT t m a
forall a k (b :: k). Const a b -> a
getConst (Const (TangleT t m a) (t (TangleT t m)) -> TangleT t m a)
-> Const (TangleT t m a) (t (TangleT t m)) -> TangleT t m a
forall a b. (a -> b) -> a -> b
$ (TangleT t m a -> Const (TangleT t m a) (TangleT t m a))
-> t (TangleT t m) -> Const (TangleT t m a) (t (TangleT t m))
forall (h :: * -> *) (f :: * -> *).
Functor f =>
(h a -> f (h a)) -> t h -> f (t h)
l TangleT t m a -> Const (TangleT t m a) (TangleT t m a)
forall k a (b :: k). a -> Const a b
Const t (TangleT t m)
ts) t (TangleT t m)
ts t Maybe
mem
{-# INLINE hitch #-}

evalTangleT :: Functor m => TangleT t m a -> t (TangleT t m) -> t Maybe -> m a
evalTangleT :: TangleT t m a -> t (TangleT t m) -> t Maybe -> m a
evalTangleT m :: TangleT t m a
m t :: t (TangleT t m)
t s :: t Maybe
s = (t Maybe, a) -> a
forall a b. (a, b) -> b
snd ((t Maybe, a) -> a) -> m (t Maybe, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TangleT t m a -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
forall (t :: (* -> *) -> *) (m :: * -> *) a.
TangleT t m a -> t (TangleT t m) -> t Maybe -> m (t Maybe, a)
runTangleT TangleT t m a
m t (TangleT t m)
t t Maybe
s
{-# INLINE evalTangleT #-}