{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
-- |
-- Unlike 'Data.Fold.L' and 'Data.Fold.R' this 'Comonad'
-- is based on a @(->) r@ 'Comonad' for a 'Monoid' @r@ rather than
-- than on the @'Store' r@ 'Comonad'.
module Data.Fold.M
  ( M(..)
  ) where

import Control.Applicative
import Control.Comonad
import Control.Lens
import Control.Monad.Fix
import Control.Monad.Reader.Class
import Control.Monad.Zip
import Data.Distributive
import Data.Fold.Class
import Data.Fold.Internal
import Data.Foldable
import Data.Functor.Bind
import Data.Functor.Extend
import Data.Functor.Rep as Functor
import Data.Profunctor.Closed
import Data.Profunctor
import Data.Profunctor.Rep as Profunctor
import Data.Profunctor.Sieve
import Data.Profunctor.Unsafe
import Data.Proxy
import Data.Reflection
import Unsafe.Coerce
import Prelude

-- | A 'foldMap' caught in amber. a.k.a. a monoidal reducer
data M a b = forall m. M (m -> b) (a -> m) (m -> m -> m) m

instance Scan M where
  run1 :: a -> M a b -> b
run1 a
a (M m -> b
k a -> m
h m -> m -> m
_ m
_) = m -> b
k (a -> m
h a
a)
  prefix1 :: a -> M a b -> M a b
prefix1 a
a (M m -> b
k a -> m
h m -> m -> m
m m
z) = case a -> m
h a
a of
     m
x -> (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
y -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m m
z
  postfix1 :: M a b -> a -> M a b
postfix1 (M m -> b
k a -> m
h m -> m -> m
m m
z) a
a = case a -> m
h a
a of
     m
y -> (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
x -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m m
z
  interspersing :: a -> M a b -> M a b
interspersing a
a (M m -> b
k a -> m
h m -> m -> m
m m
z) = (Maybe' m -> b)
-> (a -> Maybe' m)
-> (Maybe' m -> Maybe' m -> Maybe' m)
-> Maybe' m
-> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (b -> (m -> b) -> Maybe' m -> b
forall b a. b -> (a -> b) -> Maybe' a -> b
maybe' (m -> b
k m
z) m -> b
k) a -> Maybe' m
h' Maybe' m -> Maybe' m -> Maybe' m
m' Maybe' m
forall a. Maybe' a
Nothing' where
    h' :: a -> Maybe' m
h' a
r  = m -> Maybe' m
forall a. a -> Maybe' a
Just' (a -> m
h a
r)
    m' :: Maybe' m -> Maybe' m -> Maybe' m
m' (Just' m
x) (Just' m
y) = m -> Maybe' m
forall a. a -> Maybe' a
Just' (m
x m -> m -> m
`m` a -> m
h a
a m -> m -> m
`m` m
y)
    m' Maybe' m
Nothing' Maybe' m
my = Maybe' m
my
    m' Maybe' m
mx Maybe' m
Nothing' = Maybe' m
mx
  {-# INLINE run1 #-}
  {-# INLINE prefix1 #-}
  {-# INLINE postfix1 #-}
  {-# INLINE interspersing #-}

-- | efficient 'prefix', efficient 'postfix'
instance Folding M where
  run :: t a -> M a b -> b
run t a
s (M m -> b
k a -> m
h m -> m -> m
m (m
z :: m)) = (m -> m -> m, m)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> b) -> b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify (m -> m -> m
m, m
z) ((forall s. Reifies s (m -> m -> m, m) => Proxy s -> b) -> b)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> b) -> b
forall a b. (a -> b) -> a -> b
$
    \ (Proxy s
_ :: Proxy s) -> m -> b
k (m -> b) -> m -> b
forall a b. (a -> b) -> a -> b
$ N m s -> m
forall a s. N a s -> a
runN ((a -> N m s) -> t a -> N m s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (m -> N m s
forall a s. a -> N a s
N (m -> N m s) -> (a -> m) -> a -> N m s
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m
h) t a
s :: N m s)
  runOf :: Fold s a -> s -> M a b -> b
runOf Fold s a
l s
s (M m -> b
k a -> m
h m -> m -> m
m (m
z :: m)) = (m -> m -> m, m)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> b) -> b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify (m -> m -> m
m, m
z) ((forall s. Reifies s (m -> m -> m, m) => Proxy s -> b) -> b)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> b) -> b
forall a b. (a -> b) -> a -> b
$
    \ (Proxy s
_ :: Proxy s) -> m -> b
k (m -> b) -> m -> b
forall a b. (a -> b) -> a -> b
$ N m s -> m
forall a s. N a s -> a
runN (Getting (N m s) s a -> (a -> N m s) -> s -> N m s
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting (N m s) s a
Fold s a
l (m -> N m s
forall a s. a -> N a s
N (m -> N m s) -> (a -> m) -> a -> N m s
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m
h) s
s :: N m s)
  prefix :: t a -> M a b -> M a b
prefix t a
s (M m -> b
k a -> m
h m -> m -> m
m (m
z :: m)) = (m -> m -> m, m)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify (m -> m -> m
m, m
z) ((forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
 -> M a b)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a b. (a -> b) -> a -> b
$
    \ (Proxy s
_ :: Proxy s) -> case N m s -> m
forall a s. N a s -> a
runN ((a -> N m s) -> t a -> N m s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (m -> N m s
forall a s. a -> N a s
N (m -> N m s) -> (a -> m) -> a -> N m s
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m
h) t a
s :: N m s) of
      m
x -> (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
y -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m m
z
  prefixOf :: Fold s a -> s -> M a b -> M a b
prefixOf Fold s a
l s
s (M m -> b
k a -> m
h m -> m -> m
m (m
z :: m)) = (m -> m -> m, m)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify (m -> m -> m
m, m
z) ((forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
 -> M a b)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a b. (a -> b) -> a -> b
$
    \ (Proxy s
_ :: Proxy s) -> case N m s -> m
forall a s. N a s -> a
runN (Getting (N m s) s a -> (a -> N m s) -> s -> N m s
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting (N m s) s a
Fold s a
l (m -> N m s
forall a s. a -> N a s
N (m -> N m s) -> (a -> m) -> a -> N m s
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m
h) s
s :: N m s) of
      m
x -> (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
y -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m m
z
  postfix :: M a b -> t a -> M a b
postfix (M m -> b
k a -> m
h m -> m -> m
m (m
z :: m)) t a
s = (m -> m -> m, m)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify (m -> m -> m
m, m
z) ((forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
 -> M a b)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a b. (a -> b) -> a -> b
$
    \ (Proxy s
_ :: Proxy s) -> case N m s -> m
forall a s. N a s -> a
runN ((a -> N m s) -> t a -> N m s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (m -> N m s
forall a s. a -> N a s
N (m -> N m s) -> (a -> m) -> a -> N m s
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m
h) t a
s :: N m s) of
      m
y -> (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
x -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m m
z
  postfixOf :: Fold s a -> M a b -> s -> M a b
postfixOf Fold s a
l (M m -> b
k a -> m
h m -> m -> m
m (m
z :: m)) s
s = (m -> m -> m, m)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify (m -> m -> m
m, m
z) ((forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
 -> M a b)
-> (forall s. Reifies s (m -> m -> m, m) => Proxy s -> M a b)
-> M a b
forall a b. (a -> b) -> a -> b
$
    \ (Proxy s
_ :: Proxy s) -> case N m s -> m
forall a s. N a s -> a
runN (Getting (N m s) s a -> (a -> N m s) -> s -> N m s
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting (N m s) s a
Fold s a
l (m -> N m s
forall a s. a -> N a s
N (m -> N m s) -> (a -> m) -> a -> N m s
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> m
h) s
s :: N m s) of
      m
y -> (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
x -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m m
z
  filtering :: (a -> Bool) -> M a b -> M a b
filtering a -> Bool
p (M m -> b
k a -> m
h m -> m -> m
m m
z) = (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M m -> b
k (\a
a -> if a -> Bool
p a
a then a -> m
h a
a else m
z) m -> m -> m
m m
z
  {-# INLINE run #-}
  {-# INLINE runOf #-}
  {-# INLINE prefix #-}
  {-# INLINE prefixOf #-}
  {-# INLINE postfix #-}
  {-# INLINE postfixOf #-}
  {-# INLINE filtering #-}

instance Profunctor M where
  dimap :: (a -> b) -> (c -> d) -> M b c -> M a d
dimap a -> b
f c -> d
g (M m -> c
k b -> m
h m -> m -> m
m m
e) = (m -> d) -> (a -> m) -> (m -> m -> m) -> m -> M a d
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (c -> d
g(c -> d) -> (m -> c) -> m -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
.m -> c
k) (b -> m
h(b -> m) -> (a -> b) -> a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> b
f) m -> m -> m
m m
e
  {-# INLINE dimap #-}
  rmap :: (b -> c) -> M a b -> M a c
rmap b -> c
g (M m -> b
k a -> m
h m -> m -> m
m m
e) = (m -> c) -> (a -> m) -> (m -> m -> m) -> m -> M a c
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (b -> c
g(b -> c) -> (m -> b) -> m -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.m -> b
k) a -> m
h m -> m -> m
m m
e
  {-# INLINE rmap #-}
  lmap :: (a -> b) -> M b c -> M a c
lmap a -> b
f (M m -> c
k b -> m
h m -> m -> m
m m
e) = (m -> c) -> (a -> m) -> (m -> m -> m) -> m -> M a c
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M m -> c
k (b -> m
h(b -> m) -> (a -> b) -> a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> b
f) m -> m -> m
m m
e
  {-# INLINE lmap #-}
  #. :: q b c -> M a b -> M a c
(#.) q b c
_ = M a b -> M a c
forall a b. a -> b
unsafeCoerce
  {-# INLINE (#.) #-}
  M b c
x .# :: M b c -> q a b -> M a c
.# q a b
_ = M b c -> M a c
forall a b. a -> b
unsafeCoerce M b c
x
  {-# INLINE (.#) #-}

instance Choice M where
  left' :: M a b -> M (Either a c) (Either b c)
left' (M m -> b
k a -> m
h m -> m -> m
m m
z) = (Either m c -> Either b c)
-> (Either a c -> Either m c)
-> (Either m c -> Either m c -> Either m c)
-> Either m c
-> M (Either a c) (Either b c)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M ((m -> Identity b) -> Either m c -> Identity (Either b c)
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((m -> Identity b) -> Either m c -> Identity (Either b c))
-> (m -> b) -> Either m c -> Either b c
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ m -> b
k) ((a -> Identity m) -> Either a c -> Identity (Either m c)
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((a -> Identity m) -> Either a c -> Identity (Either m c))
-> (a -> m) -> Either a c -> Either m c
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> m
h) Either m c -> Either m c -> Either m c
step (m -> Either m c
forall a b. a -> Either a b
Left m
z) where
    step :: Either m c -> Either m c -> Either m c
step (Left m
x) (Left m
y) = m -> Either m c
forall a b. a -> Either a b
Left (m -> m -> m
m m
x m
y)
    step (Right c
c) Either m c
_ = c -> Either m c
forall a b. b -> Either a b
Right c
c
    step Either m c
_ (Right c
c) = c -> Either m c
forall a b. b -> Either a b
Right c
c
  {-# INLINE left' #-}

  right' :: M a b -> M (Either c a) (Either c b)
right' (M m -> b
k a -> m
h m -> m -> m
m m
z) = (Either c m -> Either c b)
-> (Either c a -> Either c m)
-> (Either c m -> Either c m -> Either c m)
-> Either c m
-> M (Either c a) (Either c b)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M ((m -> Identity b) -> Either c m -> Identity (Either c b)
forall c a b. Prism (Either c a) (Either c b) a b
_Right ((m -> Identity b) -> Either c m -> Identity (Either c b))
-> (m -> b) -> Either c m -> Either c b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ m -> b
k) ((a -> Identity m) -> Either c a -> Identity (Either c m)
forall c a b. Prism (Either c a) (Either c b) a b
_Right ((a -> Identity m) -> Either c a -> Identity (Either c m))
-> (a -> m) -> Either c a -> Either c m
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> m
h) Either c m -> Either c m -> Either c m
step (m -> Either c m
forall a b. b -> Either a b
Right m
z) where
    step :: Either c m -> Either c m -> Either c m
step (Right m
x) (Right m
y) = m -> Either c m
forall a b. b -> Either a b
Right (m -> m -> m
m m
x m
y)
    step (Left c
c) Either c m
_ = c -> Either c m
forall a b. a -> Either a b
Left c
c
    step Either c m
_ (Left c
c) = c -> Either c m
forall a b. a -> Either a b
Left c
c
  {-# INLINE right' #-}

instance Functor (M a) where
  fmap :: (a -> b) -> M a a -> M a b
fmap a -> b
f (M m -> a
k a -> m
h m -> m -> m
m m
z) = (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (a -> b
f(a -> b) -> (m -> a) -> m -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.m -> a
k) a -> m
h m -> m -> m
m m
z
  {-# INLINE fmap #-}

  <$ :: a -> M a b -> M a a
(<$) a
b = \M a b
_ -> a -> M a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
  {-# INLINE (<$) #-}

instance Comonad (M a) where
  extract :: M a a -> a
extract (M m -> a
k a -> m
_ m -> m -> m
_ m
z) = m -> a
k m
z
  {-# INLINE extract #-}

  duplicate :: M a a -> M a (M a a)
duplicate (M m -> a
k a -> m
h m -> m -> m
m m
z) = (m -> M a a) -> (a -> m) -> (m -> m -> m) -> m -> M a (M a a)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\m
n -> (m -> a) -> (a -> m) -> (m -> m -> m) -> m -> M a a
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (m -> a
k (m -> a) -> (m -> m) -> m -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> m -> m
m m
n) a -> m
h m -> m -> m
m m
z) a -> m
h m -> m -> m
m m
z
  {-# INLINE duplicate #-}

instance Applicative (M a) where
  pure :: a -> M a a
pure a
b = (() -> a) -> (a -> ()) -> (() -> () -> ()) -> () -> M a a
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\() -> a
b) (\a
_ -> ()) (\() () -> ()) ()
  {-# INLINE pure #-}

  M m -> a -> b
xf a -> m
bx m -> m -> m
xx m
xz <*> :: M a (a -> b) -> M a a -> M a b
<*> M m -> a
ya a -> m
by m -> m -> m
yy m
yz = (Pair' m m -> b)
-> (a -> Pair' m m)
-> (Pair' m m -> Pair' m m -> Pair' m m)
-> Pair' m m
-> M a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M
    (\(Pair' m
x m
y) -> m -> a -> b
xf m
x (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ m -> a
ya m
y)
    (\a
b -> m -> m -> Pair' m m
forall a b. a -> b -> Pair' a b
Pair' (a -> m
bx a
b) (a -> m
by a
b))
    (\(Pair' m
x1 m
y1) (Pair' m
x2 m
y2) -> m -> m -> Pair' m m
forall a b. a -> b -> Pair' a b
Pair' (m -> m -> m
xx m
x1 m
x2) (m -> m -> m
yy m
y1 m
y2))
    (m -> m -> Pair' m m
forall a b. a -> b -> Pair' a b
Pair' m
xz m
yz)
  {-# INLINE (<*>) #-}

  <* :: M a a -> M a b -> M a a
(<*) M a a
m = \M a b
_ -> M a a
m
  {-# INLINE (<*) #-}

  M a a
_ *> :: M a a -> M a b -> M a b
*> M a b
m = M a b
m
  {-# INLINE (*>) #-}

instance Bind (M a) where
  >>- :: M a a -> (a -> M a b) -> M a b
(>>-) = M a a -> (a -> M a b) -> M a b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
  {-# INLINE (>>-) #-}

instance Monad (M a) where
  return :: a -> M a a
return = a -> M a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}

  -- TODO: exploit observable sharing?
  M a a
m >>= :: M a a -> (a -> M a b) -> M a b
>>= a -> M a b
f = (Tree a -> a -> b)
-> (a -> Tree a)
-> (Tree a -> Tree a -> Tree a)
-> Tree a
-> M a (a -> b)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\Tree a
xs a
a -> Tree a -> M a b -> b
forall (p :: * -> * -> *) (t :: * -> *) a b.
(Folding p, Foldable t) =>
t a -> p a b -> b
run Tree a
xs (a -> M a b
f a
a)) a -> Tree a
forall a. a -> Tree a
One Tree a -> Tree a -> Tree a
forall a. Tree a -> Tree a -> Tree a
Two Tree a
forall a. Tree a
Zero M a (a -> b) -> M a a -> M a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> M a a
m
  {-# INLINE (>>=) #-}

  >> :: M a a -> M a b -> M a b
(>>) = M a a -> M a b -> M a b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  {-# INLINE (>>) #-}

instance MonadZip (M a) where
  mzipWith :: (a -> b -> c) -> M a a -> M a b -> M a c
mzipWith = (a -> b -> c) -> M a a -> M a b -> M a c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
  {-# INLINE mzipWith #-}

instance Extend (M a) where
  extended :: (M a a -> b) -> M a a -> M a b
extended = (M a a -> b) -> M a a -> M a b
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend
  {-# INLINE extended #-}

  duplicated :: M a a -> M a (M a a)
duplicated = M a a -> M a (M a a)
forall (w :: * -> *) a. Comonad w => w a -> w (w a)
duplicate
  {-# INLINE duplicated #-}

instance Apply (M a) where
  <.> :: M a (a -> b) -> M a a -> M a b
(<.>) = M a (a -> b) -> M a a -> M a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<.>) #-}

  <. :: M a a -> M a b -> M a a
(<.) M a a
m = \M a b
_ -> M a a
m
  {-# INLINE (<.) #-}

  M a a
_ .> :: M a a -> M a b -> M a b
.> M a b
m = M a b
m
  {-# INLINE (.>) #-}

instance ComonadApply (M a) where
  <@> :: M a (a -> b) -> M a a -> M a b
(<@>) = M a (a -> b) -> M a a -> M a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<@>) #-}

  <@ :: M a a -> M a b -> M a a
(<@) M a a
m = \M a b
_ -> M a a
m
  {-# INLINE (<@) #-}

  M a a
_ @> :: M a a -> M a b -> M a b
@> M a b
m = M a b
m
  {-# INLINE (@>) #-}

instance Distributive (M a) where
  distribute :: f (M a a) -> M a (f a)
distribute f (M a a)
fm = (Tree a -> f a)
-> (a -> Tree a)
-> (Tree a -> Tree a -> Tree a)
-> Tree a
-> M a (f a)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\Tree a
t -> let g :: FreeMonoid a
g = Tree a -> FreeMonoid a
forall (f :: * -> *) a.
(MuRef1 f, Bifoldable (DeRef1 f)) =>
f a -> FreeMonoid a
foldDeRef Tree a
t in FreeMonoid a -> M a a -> a
forall (p :: * -> * -> *) (t :: * -> *) a b.
(Folding p, Foldable t) =>
t a -> p a b -> b
run FreeMonoid a
g (M a a -> a) -> f (M a a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (M a a)
fm) a -> Tree a
forall a. a -> Tree a
One Tree a -> Tree a -> Tree a
forall a. Tree a -> Tree a -> Tree a
Two Tree a
forall a. Tree a
Zero
  {-# INLINE distribute #-}

instance Closed M where
  closed :: M a b -> M (x -> a) (x -> b)
closed (M m -> b
k a -> m
h m -> m -> m
m m
z) = ((x -> m) -> x -> b)
-> ((x -> a) -> x -> m)
-> ((x -> m) -> (x -> m) -> x -> m)
-> (x -> m)
-> M (x -> a) (x -> b)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (\x -> m
f x
x -> m -> b
k (x -> m
f x
x)) ((a -> m) -> (x -> a) -> x -> m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m
h) ((m -> m -> m) -> (x -> m) -> (x -> m) -> x -> m
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 m -> m -> m
m) (m -> x -> m
forall (f :: * -> *) a. Applicative f => a -> f a
pure m
z)

instance Cosieve M FreeMonoid where
  cosieve :: M a b -> FreeMonoid a -> b
cosieve = (FreeMonoid a -> M a b -> b) -> M a b -> FreeMonoid a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip FreeMonoid a -> M a b -> b
forall (p :: * -> * -> *) (t :: * -> *) a b.
(Folding p, Foldable t) =>
t a -> p a b -> b
run

instance Profunctor.Corepresentable M where
  type Corep M = FreeMonoid
  cotabulate :: (Corep M d -> c) -> M d c
cotabulate Corep M d -> c
f = (Tree d -> c)
-> (d -> Tree d) -> (Tree d -> Tree d -> Tree d) -> Tree d -> M d c
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> m -> M a b
M (Corep M d -> c
FreeMonoid d -> c
f (FreeMonoid d -> c) -> (Tree d -> FreeMonoid d) -> Tree d -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree d -> FreeMonoid d
forall (f :: * -> *) a.
(MuRef1 f, Bifoldable (DeRef1 f)) =>
f a -> FreeMonoid a
foldDeRef) d -> Tree d
forall a. a -> Tree a
One Tree d -> Tree d -> Tree d
forall a. Tree a -> Tree a -> Tree a
Two Tree d
forall a. Tree a
Zero

instance MonadReader (FreeMonoid a) (M a) where
  ask :: M a (FreeMonoid a)
ask = M a (FreeMonoid a)
forall (f :: * -> *). Representable f => f (Rep f)
askRep
  local :: (FreeMonoid a -> FreeMonoid a) -> M a a -> M a a
local = (FreeMonoid a -> FreeMonoid a) -> M a a -> M a a
forall (f :: * -> *) a.
Representable f =>
(Rep f -> Rep f) -> f a -> f a
localRep

instance Functor.Representable (M a) where
  type Rep (M a) = FreeMonoid a
  tabulate :: (Rep (M a) -> a) -> M a a
tabulate = (Rep (M a) -> a) -> M a a
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate
  index :: M a a -> Rep (M a) -> a
index = M a a -> Rep (M a) -> a
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve

instance Costrong M where
  unfirst :: M (a, d) (b, d) -> M a b
unfirst = M (a, d) (b, d) -> M a b
forall (p :: * -> * -> *) a d b.
Corepresentable p =>
p (a, d) (b, d) -> p a b
unfirstCorep
  unsecond :: M (d, a) (d, b) -> M a b
unsecond = M (d, a) (d, b) -> M a b
forall (p :: * -> * -> *) d a b.
Corepresentable p =>
p (d, a) (d, b) -> p a b
unsecondCorep

instance MonadFix (M a) where
  mfix :: (a -> M a a) -> M a a
mfix = (a -> M a a) -> M a a
forall (f :: * -> *) a. Representable f => (a -> f a) -> f a
mfixRep