{-# LANGUAGE RankNTypes, LambdaCase, DeriveFunctor, BangPatterns #-}
module Control.Monad.Tangle
  (TangleFT(..), hitchF
  , evalTangleFT
  , liftTangles
  , blank
  , hitch
  , gather
  , TangleF
  , evalTangleF
  , TangleT
  , evalTangleT
  , Tangle
  , evalTangle
  ) where

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

-- | 'TangleFT' is a higher-kinded heterogeneous memoisation monad transformer.
-- @t@ represents the shape of the underlying data structure, and @f@ is the wrapper type of each field.
-- This monad represents computations that depend on the contents of @t f@.
newtype TangleFT t f m a = TangleFT
  { TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
runTangleFT :: t (Compose (TangleFT t f m) f)
    -> t (Compose Maybe f)
    -> m (t (Compose Maybe f), a) }
  deriving a -> TangleFT t f m b -> TangleFT t f m a
(a -> b) -> TangleFT t f m a -> TangleFT t f m b
(forall a b. (a -> b) -> TangleFT t f m a -> TangleFT t f m b)
-> (forall a b. a -> TangleFT t f m b -> TangleFT t f m a)
-> Functor (TangleFT t f m)
forall a b. a -> TangleFT t f m b -> TangleFT t f m a
forall a b. (a -> b) -> TangleFT t f m a -> TangleFT t f 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 :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> TangleFT t f m b -> TangleFT t f m a
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> TangleFT t f m a -> TangleFT t f m b
<$ :: a -> TangleFT t f m b -> TangleFT t f m a
$c<$ :: forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a b.
Functor m =>
a -> TangleFT t f m b -> TangleFT t f m a
fmap :: (a -> b) -> TangleFT t f m a -> TangleFT t f m b
$cfmap :: forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> TangleFT t f m a -> TangleFT t f m b
Functor

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

instance (Monad m, Semigroup a) => Semigroup (TangleFT t f m a) where
  <> :: TangleFT t f m a -> TangleFT t f m a -> TangleFT t f m a
(<>) = (a -> a -> a)
-> TangleFT t f m a -> TangleFT t f m a -> TangleFT t f 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 (TangleFT t f m a) where
  mempty :: TangleFT t f m a
mempty = a -> TangleFT t f m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

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

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

-- | Collect all results in the tangle.
gather :: (TraversableB t, Monad m) => TangleFT t f m (t f)
gather :: TangleFT t f m (t f)
gather = (t (Compose (TangleFT t f m) f)
 -> t (Compose Maybe f) -> m (t (Compose Maybe f), t f))
-> TangleFT t f m (t f)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
(t (Compose (TangleFT t f m) f)
 -> t (Compose Maybe f) -> m (t (Compose Maybe f), a))
-> TangleFT t f m a
TangleFT ((t (Compose (TangleFT t f m) f)
  -> t (Compose Maybe f) -> m (t (Compose Maybe f), t f))
 -> TangleFT t f m (t f))
-> (t (Compose (TangleFT t f m) f)
    -> t (Compose Maybe f) -> m (t (Compose Maybe f), t f))
-> TangleFT t f m (t f)
forall a b. (a -> b) -> a -> b
$ \t (Compose (TangleFT t f m) f)
env t (Compose Maybe f)
prev -> TangleFT t f m (t f)
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), t f)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
runTangleFT ((forall a. Compose (TangleFT t f m) f a -> TangleFT t f m (f a))
-> t (Compose (TangleFT t f m) f) -> TangleFT t f m (t f)
forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall a. Compose (TangleFT t f m) f a -> TangleFT t f m (f a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose t (Compose (TangleFT t f m) f)
env) t (Compose (TangleFT t f m) f)
env t (Compose Maybe f)
prev

-- | Obtain a value from the tangle. The result gets memoised.
hitchF :: Monad m
  => (forall h g. Functor g => (h a -> g (h a)) -> t h -> g (t h)) -- ^ van Laarhoven lens
  -> TangleFT t f m (f a)
hitchF :: (forall (h :: * -> *) (g :: * -> *).
 Functor g =>
 (h a -> g (h a)) -> t h -> g (t h))
-> TangleFT t f m (f a)
hitchF forall (h :: * -> *) (g :: * -> *).
Functor g =>
(h a -> g (h a)) -> t h -> g (t h)
l = (t (Compose (TangleFT t f m) f)
 -> t (Compose Maybe f) -> m (t (Compose Maybe f), f a))
-> TangleFT t f m (f a)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
(t (Compose (TangleFT t f m) f)
 -> t (Compose Maybe f) -> m (t (Compose Maybe f), a))
-> TangleFT t f m a
TangleFT ((t (Compose (TangleFT t f m) f)
  -> t (Compose Maybe f) -> m (t (Compose Maybe f), f a))
 -> TangleFT t f m (f a))
-> (t (Compose (TangleFT t f m) f)
    -> t (Compose Maybe f) -> m (t (Compose Maybe f), f a))
-> TangleFT t f m (f a)
forall a b. (a -> b) -> a -> b
$ \t (Compose (TangleFT t f m) f)
ts t (Compose Maybe f)
mem -> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f))
-> m (t (Compose Maybe f), f a)
forall a k (b :: k). Const a b -> a
getConst (Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f))
 -> m (t (Compose Maybe f), f a))
-> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f))
-> m (t (Compose Maybe f), f a)
forall a b. (a -> b) -> a -> b
$ ((Compose Maybe f a
  -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
 -> t (Compose Maybe f)
 -> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f)))
-> t (Compose Maybe f)
-> (Compose Maybe f a
    -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
-> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Compose Maybe f a
 -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
-> t (Compose Maybe f)
-> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f))
forall (h :: * -> *) (g :: * -> *).
Functor g =>
(h a -> g (h a)) -> t h -> g (t h)
l t (Compose Maybe f)
mem ((Compose Maybe f a
  -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
 -> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f)))
-> (Compose Maybe f a
    -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
-> Const (m (t (Compose Maybe f), f a)) (t (Compose Maybe f))
forall a b. (a -> b) -> a -> b
$ \case
  Compose (Just f a
a) -> m (t (Compose Maybe f), f a)
-> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a)
forall k a (b :: k). a -> Const a b
Const (m (t (Compose Maybe f), f a)
 -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
-> m (t (Compose Maybe f), f a)
-> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a)
forall a b. (a -> b) -> a -> b
$ (t (Compose Maybe f), f a) -> m (t (Compose Maybe f), f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t (Compose Maybe f)
mem, f a
a)
  Compose Maybe (f a)
Nothing -> m (t (Compose Maybe f), f a)
-> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a)
forall k a (b :: k). a -> Const a b
Const
    (m (t (Compose Maybe f), f a)
 -> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a))
-> m (t (Compose Maybe f), f a)
-> Const (m (t (Compose Maybe f), f a)) (Compose Maybe f a)
forall a b. (a -> b) -> a -> b
$ ((t (Compose Maybe f), f a) -> (t (Compose Maybe f), f a))
-> m (t (Compose Maybe f), f a) -> m (t (Compose Maybe f), f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(t (Compose Maybe f)
mem', f a
a) -> let !(Identity t (Compose Maybe f)
mem'') = (Compose Maybe f a -> Identity (Compose Maybe f a))
-> t (Compose Maybe f) -> Identity (t (Compose Maybe f))
forall (h :: * -> *) (g :: * -> *).
Functor g =>
(h a -> g (h a)) -> t h -> g (t h)
l (Identity (Compose Maybe f a)
-> Compose Maybe f a -> Identity (Compose Maybe f a)
forall a b. a -> b -> a
const (Identity (Compose Maybe f a)
 -> Compose Maybe f a -> Identity (Compose Maybe f a))
-> Identity (Compose Maybe f a)
-> Compose Maybe f a
-> Identity (Compose Maybe f a)
forall a b. (a -> b) -> a -> b
$ Compose Maybe f a -> Identity (Compose Maybe f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Compose Maybe f a -> Identity (Compose Maybe f a))
-> Compose Maybe f a -> Identity (Compose Maybe f a)
forall a b. (a -> b) -> a -> b
$ Maybe (f a) -> Compose Maybe f a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Maybe (f a) -> Compose Maybe f a)
-> Maybe (f a) -> Compose Maybe f a
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (f a)
forall a. a -> Maybe a
Just f a
a) t (Compose Maybe f)
mem' in (t (Compose Maybe f)
mem'', f a
a))
    (m (t (Compose Maybe f), f a) -> m (t (Compose Maybe f), f a))
-> m (t (Compose Maybe f), f a) -> m (t (Compose Maybe f), f a)
forall a b. (a -> b) -> a -> b
$ TangleFT t f m (f a)
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), f a)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
runTangleFT (Compose (TangleFT t f m) f a -> TangleFT t f m (f a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (TangleFT t f m) f a -> TangleFT t f m (f a))
-> Compose (TangleFT t f m) f a -> TangleFT t f m (f a)
forall a b. (a -> b) -> a -> b
$ Const
  (Compose (TangleFT t f m) f a) (t (Compose (TangleFT t f m) f))
-> Compose (TangleFT t f m) f a
forall a k (b :: k). Const a b -> a
getConst (Const
   (Compose (TangleFT t f m) f a) (t (Compose (TangleFT t f m) f))
 -> Compose (TangleFT t f m) f a)
-> Const
     (Compose (TangleFT t f m) f a) (t (Compose (TangleFT t f m) f))
-> Compose (TangleFT t f m) f a
forall a b. (a -> b) -> a -> b
$ (Compose (TangleFT t f m) f a
 -> Const
      (Compose (TangleFT t f m) f a) (Compose (TangleFT t f m) f a))
-> t (Compose (TangleFT t f m) f)
-> Const
     (Compose (TangleFT t f m) f a) (t (Compose (TangleFT t f m) f))
forall (h :: * -> *) (g :: * -> *).
Functor g =>
(h a -> g (h a)) -> t h -> g (t h)
l Compose (TangleFT t f m) f a
-> Const
     (Compose (TangleFT t f m) f a) (Compose (TangleFT t f m) f a)
forall k a (b :: k). a -> Const a b
Const t (Compose (TangleFT t f m) f)
ts) t (Compose (TangleFT t f m) f)
ts t (Compose Maybe f)
mem
{-# INLINE hitchF #-}

evalTangleFT :: (ApplicativeB t, Functor m) => TangleFT t f m a -> t (Compose (TangleFT t f m) f) -> m a
evalTangleFT :: TangleFT t f m a -> t (Compose (TangleFT t f m) f) -> m a
evalTangleFT TangleFT t f m a
m t (Compose (TangleFT t f m) f)
t = (t (Compose Maybe f), a) -> a
forall a b. (a, b) -> b
snd ((t (Compose Maybe f), a) -> a)
-> m (t (Compose Maybe f), a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
runTangleFT TangleFT t f m a
m t (Compose (TangleFT t f m) f)
t t (Compose Maybe f)
forall (b :: (* -> *) -> *) (f :: * -> *).
ApplicativeB b =>
b (Compose Maybe f)
blank
{-# INLINE evalTangleFT #-}

-- | Lift a collection of 'TangleT's so that it fits the argument of 'runTangleFT'.
liftTangles :: (FunctorB b, Functor m) => b (TangleT b m) -> b (Compose (TangleT b m) Identity)
liftTangles :: b (TangleT b m) -> b (Compose (TangleT b m) Identity)
liftTangles = (forall a. TangleT b m a -> Compose (TangleT b m) Identity a)
-> b (TangleT b m) -> b (Compose (TangleT b m) Identity)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (TangleT b m (Identity a) -> Compose (TangleT b m) Identity a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (TangleT b m (Identity a) -> Compose (TangleT b m) Identity a)
-> (TangleT b m a -> TangleT b m (Identity a))
-> TangleT b m a
-> Compose (TangleT b m) Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> TangleT b m a -> TangleT b m (Identity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Identity a
forall a. a -> Identity a
Identity)
{-# INLINE liftTangles #-}

-- | A product where all the elements are 'Compose' 'Nothing'
blank :: ApplicativeB b => b (Compose Maybe f)
blank :: b (Compose Maybe f)
blank = (forall a. Compose Maybe f a) -> b (Compose Maybe f)
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> b f
bpure ((forall a. Compose Maybe f a) -> b (Compose Maybe f))
-> (forall a. Compose Maybe f a) -> b (Compose Maybe f)
forall a b. (a -> b) -> a -> b
$ Maybe (f a) -> Compose Maybe f a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (f a)
forall a. Maybe a
Nothing

-- | Bare version of 'TangleFT'
type TangleT t = TangleFT t Identity

-- | Non-transformer version of 'TangleFT'
type TangleF t f = TangleFT t f Identity

-- | Bare non-transformer tangle
type Tangle t = TangleFT t Identity Identity

-- | Bare variant of 'hitchF'
hitch :: Monad m
  => (forall h g. Functor g => (h a -> g (h a)) -> t h -> g (t h)) -- ^ van Laarhoven lens
  -> TangleT t m a
hitch :: (forall (h :: * -> *) (g :: * -> *).
 Functor g =>
 (h a -> g (h a)) -> t h -> g (t h))
-> TangleT t m a
hitch forall (h :: * -> *) (g :: * -> *).
Functor g =>
(h a -> g (h a)) -> t h -> g (t h)
l = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> TangleFT t Identity m (Identity a) -> TangleT t m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (h :: * -> *) (g :: * -> *).
 Functor g =>
 (h a -> g (h a)) -> t h -> g (t h))
-> TangleFT t Identity m (Identity a)
forall (m :: * -> *) a (t :: (* -> *) -> *) (f :: * -> *).
Monad m =>
(forall (h :: * -> *) (g :: * -> *).
 Functor g =>
 (h a -> g (h a)) -> t h -> g (t h))
-> TangleFT t f m (f a)
hitchF forall (h :: * -> *) (g :: * -> *).
Functor g =>
(h a -> g (h a)) -> t h -> g (t h)
l
{-# INLINE hitch #-}

evalTangleF :: ApplicativeB t => TangleF t f a -> t (Compose (TangleF t f) f) -> a
evalTangleF :: TangleF t f a -> t (Compose (TangleF t f) f) -> a
evalTangleF TangleF t f a
m t (Compose (TangleF t f) f)
t = (t (Compose Maybe f), a) -> a
forall a b. (a, b) -> b
snd ((t (Compose Maybe f), a) -> a) -> (t (Compose Maybe f), a) -> a
forall a b. (a -> b) -> a -> b
$ Identity (t (Compose Maybe f), a) -> (t (Compose Maybe f), a)
forall a. Identity a -> a
runIdentity (Identity (t (Compose Maybe f), a) -> (t (Compose Maybe f), a))
-> Identity (t (Compose Maybe f), a) -> (t (Compose Maybe f), a)
forall a b. (a -> b) -> a -> b
$ TangleF t f a
-> t (Compose (TangleF t f) f)
-> t (Compose Maybe f)
-> Identity (t (Compose Maybe f), a)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
runTangleFT TangleF t f a
m t (Compose (TangleF t f) f)
t t (Compose Maybe f)
forall (b :: (* -> *) -> *) (f :: * -> *).
ApplicativeB b =>
b (Compose Maybe f)
blank
{-# INLINE evalTangleF #-}

evalTangleT :: (Functor m, ApplicativeB t) => TangleT t m a -> t (TangleT t m) -> m a
evalTangleT :: TangleT t m a -> t (TangleT t m) -> m a
evalTangleT TangleT t m a
m t (TangleT t m)
t = ((t (Compose Maybe Identity), a) -> a)
-> m (t (Compose Maybe Identity), a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t (Compose Maybe Identity), a) -> a
forall a b. (a, b) -> b
snd (m (t (Compose Maybe Identity), a) -> m a)
-> m (t (Compose Maybe Identity), a) -> m a
forall a b. (a -> b) -> a -> b
$ TangleT t m a
-> t (Compose (TangleT t m) Identity)
-> t (Compose Maybe Identity)
-> m (t (Compose Maybe Identity), a)
forall (t :: (* -> *) -> *) (f :: * -> *) (m :: * -> *) a.
TangleFT t f m a
-> t (Compose (TangleFT t f m) f)
-> t (Compose Maybe f)
-> m (t (Compose Maybe f), a)
runTangleFT TangleT t m a
m (t (TangleT t m) -> t (Compose (TangleT t m) Identity)
forall (b :: (* -> *) -> *) (m :: * -> *).
(FunctorB b, Functor m) =>
b (TangleT b m) -> b (Compose (TangleT b m) Identity)
liftTangles t (TangleT t m)
t) t (Compose Maybe Identity)
forall (b :: (* -> *) -> *) (f :: * -> *).
ApplicativeB b =>
b (Compose Maybe f)
blank
{-# INLINE evalTangleT #-}

evalTangle :: (ApplicativeB t) => Tangle t a -> t (Tangle t) -> a
evalTangle :: Tangle t a -> t (Tangle t) -> a
evalTangle Tangle t a
m t (Tangle t)
t = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> Identity a -> a
forall a b. (a -> b) -> a -> b
$ Tangle t a -> t (Tangle t) -> Identity a
forall (m :: * -> *) (t :: (* -> *) -> *) a.
(Functor m, ApplicativeB t) =>
TangleT t m a -> t (TangleT t m) -> m a
evalTangleT Tangle t a
m t (Tangle t)
t
{-# INLINE evalTangle #-}