{-# 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 #-}