{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
module Data.Fold.M1
  ( M1(..)
  , runM1
  ) where

import Control.Applicative
import Control.Arrow
import Control.Category
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.Functor.Apply
import Data.Functor.Rep as Functor
import Data.Pointed
import Data.Profunctor.Closed
import Data.Profunctor
import Data.Profunctor.Sieve
import Data.Profunctor.Rep as Profunctor
import Data.Profunctor.Unsafe
import Data.Proxy
import Data.Reflection
import Data.Semigroup.Foldable
import Data.Semigroupoid
import Prelude hiding (id,(.))
import Unsafe.Coerce

-- | A semigroup reducer
data M1 a b = forall m. M1 (m -> b) (a -> m) (m -> m -> m)

instance Scan M1 where
  run1 :: a -> M1 a b -> b
run1 a
a (M1 m -> b
k a -> m
h m -> m -> m
_) = m -> b
k (a -> m
h a
a)
  prefix1 :: a -> M1 a b -> M1 a b
prefix1 a
a (M1 m -> b
k a -> m
h m -> m -> m
m) = case a -> m
h a
a of
     m
x -> (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\m
y -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m
  postfix1 :: M1 a b -> a -> M1 a b
postfix1 (M1 m -> b
k a -> m
h m -> m -> m
m) a
a = case a -> m
h a
a of
     m
y -> (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\m
x -> m -> b
k (m -> m -> m
m m
x m
y)) a -> m
h m -> m -> m
m
  interspersing :: a -> M1 a b -> M1 a b
interspersing a
a (M1 m -> b
k a -> m
h m -> m -> m
m) = (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 m -> b
k a -> m
h m -> m -> m
m' where
    m' :: m -> m -> m
m' m
x m
y = m
x m -> m -> m
`m` a -> m
h a
a m -> m -> m
`m` m
y
  {-# INLINE run1 #-}
  {-# INLINE prefix1 #-}
  {-# INLINE postfix1 #-}
  {-# INLINE interspersing #-}

instance Functor (M1 a) where
  fmap :: (a -> b) -> M1 a a -> M1 a b
fmap a -> b
f (M1 m -> a
k a -> m
h m -> m -> m
m) = (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (a -> b
f(a -> b) -> (m -> a) -> m -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.m -> a
k) a -> m
h m -> m -> m
m
  {-# INLINE fmap #-}
  a
b <$ :: a -> M1 a b -> M1 a a
<$ M1 a b
_ = a -> M1 a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
  {-# INLINE (<$) #-}

instance Pointed (M1 a) where
  point :: a -> M1 a a
point a
x = (() -> a) -> (a -> ()) -> (() -> () -> ()) -> M1 a a
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\() -> a
x) (\a
_ -> ()) (\() () -> ())
  {-# INLINE point #-}

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

instance Applicative (M1 a) where
  pure :: a -> M1 a a
pure a
x = (() -> a) -> (a -> ()) -> (() -> () -> ()) -> M1 a a
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\() -> a
x) (\a
_ -> ()) (\() () -> ())
  {-# INLINE pure #-}
  M1 m -> a -> b
kf a -> m
hf m -> m -> m
mf <*> :: M1 a (a -> b) -> M1 a a -> M1 a b
<*> M1 m -> a
ka a -> m
ha m -> m -> m
ma = (Pair' m m -> b)
-> (a -> Pair' m m)
-> (Pair' m m -> Pair' m m -> Pair' m m)
-> M1 a b
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1
    (\(Pair' m
x m
y) -> m -> a -> b
kf m
x (m -> a
ka m
y))
    (\a
a -> m -> m -> Pair' m m
forall a b. a -> b -> Pair' a b
Pair' (a -> m
hf a
a) (a -> m
ha a
a))
    (\(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
mf m
x1 m
x2) (m -> m -> m
ma m
y1 m
y2))
  <* :: M1 a a -> M1 a b -> M1 a a
(<*) M1 a a
m = \ M1 a b
_ -> M1 a a
m
  {-# INLINE (<*) #-}
  M1 a a
_ *> :: M1 a a -> M1 a b -> M1 a b
*> M1 a b
m = M1 a b
m
  {-# INLINE (*>) #-}

instance Monad (M1 a) where
  return :: a -> M1 a a
return = a -> M1 a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  M1 a a
m >>= :: M1 a a -> (a -> M1 a b) -> M1 a b
>>= a -> M1 a b
f = (Tree1 a -> a -> b)
-> (a -> Tree1 a)
-> (Tree1 a -> Tree1 a -> Tree1 a)
-> M1 a (a -> b)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\Tree1 a
xs a
a -> Tree1 a -> M1 a b -> b
forall a b. Tree1 a -> M1 a b -> b
walk Tree1 a
xs (a -> M1 a b
f a
a)) a -> Tree1 a
forall a. a -> Tree1 a
Tip1 Tree1 a -> Tree1 a -> Tree1 a
forall a. Tree1 a -> Tree1 a -> Tree1 a
Bin1 M1 a (a -> b) -> M1 a a -> M1 a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> M1 a a
m
  {-# INLINE (>>=) #-}
  >> :: M1 a a -> M1 a b -> M1 a b
(>>) = M1 a a -> M1 a b -> M1 a b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  {-# INLINE (>>) #-}

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

instance Semigroupoid M1 where
  o :: M1 j k1 -> M1 i j -> M1 i k1
o = M1 j k1 -> M1 i j -> M1 i k1
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)
  {-# INLINE o #-}

instance Category M1 where
  id :: M1 a a
id = (a -> a) -> (a -> a) -> (a -> a -> a) -> M1 a a
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a -> a -> a
forall a b. a -> b -> a
const
  {-# INLINE id #-}
  M1 m -> c
k b -> m
h m -> m -> m
m . :: M1 b c -> M1 a b -> M1 a c
. M1 m -> b
k' a -> m
h' m -> m -> m
m' = (Pair' m m -> c)
-> (a -> Pair' m m)
-> (Pair' m m -> Pair' m m -> Pair' m m)
-> M1 a c
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\(Pair' m
b m
_) -> m -> c
k m
b) a -> Pair' m m
h'' Pair' m m -> Pair' m m -> Pair' m m
m'' where
    m'' :: Pair' m m -> Pair' m m -> Pair' m m
m'' (Pair' m
a m
b) (Pair' m
c m
d) = m -> m -> Pair' m m
forall a b. a -> b -> Pair' a b
Pair' (m -> m -> m
m m
a m
c) (m -> m -> m
m' m
b m
d)
    h'' :: a -> Pair' m m
h'' a
a = m -> m -> Pair' m m
forall a b. a -> b -> Pair' a b
Pair' (b -> m
h (m -> b
k' m
d)) m
d where d :: m
d = a -> m
h' a
a
  {-# INLINE (.) #-}

instance Arrow M1 where
  arr :: (b -> c) -> M1 b c
arr b -> c
h = (b -> c) -> (b -> b) -> (b -> b -> b) -> M1 b c
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 b -> c
h b -> b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id b -> b -> b
forall a b. a -> b -> a
const
  {-# INLINE arr #-}
  first :: M1 b c -> M1 (b, d) (c, d)
first (M1 m -> c
k b -> m
h m -> m -> m
m) = ((m, d) -> (c, d))
-> ((b, d) -> (m, d))
-> ((m, d) -> (m, d) -> (m, d))
-> M1 (b, d) (c, d)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 ((m -> c) -> (m, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first m -> c
k) ((b -> m) -> (b, d) -> (m, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first b -> m
h) (m, d) -> (m, d) -> (m, d)
m' where
    m' :: (m, d) -> (m, d) -> (m, d)
m' (m
a,d
_) (m
c,d
b) = (m -> m -> m
m m
a m
c, d
b)
  {-# INLINE first #-}
  second :: M1 b c -> M1 (d, b) (d, c)
second (M1 m -> c
k b -> m
h m -> m -> m
m) = ((d, m) -> (d, c))
-> ((d, b) -> (d, m))
-> ((d, m) -> (d, m) -> (d, m))
-> M1 (d, b) (d, c)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 ((m -> c) -> (d, m) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second m -> c
k) ((b -> m) -> (d, b) -> (d, m)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b -> m
h) (d, m) -> (d, m) -> (d, m)
m' where
    m' :: (d, m) -> (d, m) -> (d, m)
m' (d
_,m
b) (d
a,m
c) = (d
a, m -> m -> m
m m
b m
c)
  {-# INLINE second #-}
  M1 m -> c
k b -> m
h m -> m -> m
m *** :: M1 b c -> M1 b' c' -> M1 (b, b') (c, c')
*** M1 m -> c'
k' b' -> m
h' m -> m -> m
m' = ((m, m) -> (c, c'))
-> ((b, b') -> (m, m))
-> ((m, m) -> (m, m) -> (m, m))
-> M1 (b, b') (c, c')
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (m -> c
k (m -> c) -> (m -> c') -> (m, m) -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** m -> c'
k') (b -> m
h (b -> m) -> (b' -> m) -> (b, b') -> (m, m)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** b' -> m
h') (m, m) -> (m, m) -> (m, m)
m'' where
    m'' :: (m, m) -> (m, m) -> (m, m)
m'' (m
a,m
b) (m
c,m
d) = (m -> m -> m
m m
a m
c, m -> m -> m
m' m
b m
d)
  {-# INLINE (***) #-}
  M1 m -> c
k b -> m
h m -> m -> m
m &&& :: M1 b c -> M1 b c' -> M1 b (c, c')
&&& M1 m -> c'
k' b -> m
h' m -> m -> m
m' = ((m, m) -> (c, c'))
-> (b -> (m, m)) -> ((m, m) -> (m, m) -> (m, m)) -> M1 b (c, c')
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (m -> c
k (m -> c) -> (m -> c') -> (m, m) -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** m -> c'
k') (b -> m
h (b -> m) -> (b -> m) -> b -> (m, m)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& b -> m
h') (m, m) -> (m, m) -> (m, m)
m'' where
    m'' :: (m, m) -> (m, m) -> (m, m)
m'' (m
a,m
b) (m
c,m
d) = (m -> m -> m
m m
a m
c, m -> m -> m
m' m
b m
d)
  {-# INLINE (&&&) #-}

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

instance Strong M1 where
  first' :: M1 a b -> M1 (a, c) (b, c)
first' = M1 a b -> M1 (a, c) (b, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first
  {-# INLINE first' #-}
  second' :: M1 a b -> M1 (c, a) (c, b)
second' = M1 a b -> M1 (c, a) (c, b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second
  {-# INLINE second' #-}

instance Choice M1 where
  left' :: M1 a b -> M1 (Either a c) (Either b c)
left' (M1 m -> b
k a -> m
h m -> m -> m
m) = (Either m c -> Either b c)
-> (Either a c -> Either m c)
-> (Either m c -> Either m c -> Either m c)
-> M1 (Either a c) (Either b c)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 ((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 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' :: M1 a b -> M1 (Either c a) (Either c b)
right' (M1 m -> b
k a -> m
h m -> m -> m
m) = (Either c m -> Either c b)
-> (Either c a -> Either c m)
-> (Either c m -> Either c m -> Either c m)
-> M1 (Either c a) (Either c b)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 ((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 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 ArrowChoice M1 where
  left :: M1 b c -> M1 (Either b d) (Either c d)
left (M1 m -> c
k b -> m
h m -> m -> m
m) = (Either m d -> Either c d)
-> (Either b d -> Either m d)
-> (Either m d -> Either m d -> Either m d)
-> M1 (Either b d) (Either c d)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 ((m -> Identity c) -> Either m d -> Identity (Either c d)
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((m -> Identity c) -> Either m d -> Identity (Either c d))
-> (m -> c) -> Either m d -> Either c d
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ m -> c
k) ((b -> Identity m) -> Either b d -> Identity (Either m d)
forall a c b. Prism (Either a c) (Either b c) a b
_Left ((b -> Identity m) -> Either b d -> Identity (Either m d))
-> (b -> m) -> Either b d -> Either m d
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ b -> m
h) Either m d -> Either m d -> Either m d
step where
    step :: Either m d -> Either m d -> Either m d
step (Left m
x) (Left m
y) = m -> Either m d
forall a b. a -> Either a b
Left (m -> m -> m
m m
x m
y)
    step (Right d
c) Either m d
_ = d -> Either m d
forall a b. b -> Either a b
Right d
c
    step Either m d
_ (Right d
c) = d -> Either m d
forall a b. b -> Either a b
Right d
c
  {-# INLINE left #-}

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

walk :: Tree1 a -> M1 a b -> b
walk :: Tree1 a -> M1 a b -> b
walk Tree1 a
xs0 (M1 m -> b
k a -> m
h m -> m -> m
m) = m -> b
k (Tree1 a -> m
go Tree1 a
xs0) where
  go :: Tree1 a -> m
go (Tip1 a
a) = a -> m
h a
a
  go (Bin1 Tree1 a
xs Tree1 a
ys) = m -> m -> m
m (Tree1 a -> m
go Tree1 a
xs) (Tree1 a -> m
go Tree1 a
ys)
{-# INLINE walk #-}

runM1 :: Foldable1 f => f a -> M1 a b -> b
runM1 :: f a -> M1 a b -> b
runM1 f a
p (M1 m -> b
k a -> m
h (m -> m -> m
m :: m -> m -> m)) = (m -> m -> m)
-> (forall s. Reifies s (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 ((forall s. Reifies s (m -> m -> m) => Proxy s -> b) -> b)
-> (forall s. Reifies s (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
$ S m s -> m
forall a s. S a s -> a
runS ((a -> S m s) -> f a -> S m s
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (m -> S m s
forall a s. a -> S a s
S (m -> S m s) -> (a -> m) -> a -> S 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) f a
p :: S m s)

instance Closed M1 where
  closed :: M1 a b -> M1 (x -> a) (x -> b)
closed (M1 m -> b
k a -> m
h m -> m -> m
m) = ((x -> m) -> x -> b)
-> ((x -> a) -> x -> m)
-> ((x -> m) -> (x -> m) -> x -> m)
-> M1 (x -> a) (x -> b)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\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)

instance Distributive (M1 a) where
  distribute :: f (M1 a a) -> M1 a (f a)
distribute f (M1 a a)
fm = (Tree1 a -> f a)
-> (a -> Tree1 a) -> (Tree1 a -> Tree1 a -> Tree1 a) -> M1 a (f a)
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (\Tree1 a
t -> let g :: FreeSemigroup a
g = Tree1 a -> FreeSemigroup a
forall (f :: * -> *) a.
(MuRef1 f, Bifoldable1 (DeRef1 f)) =>
f a -> FreeSemigroup a
foldDeRef1 Tree1 a
t in FreeSemigroup a -> M1 a a -> a
forall (f :: * -> *) a b. Foldable1 f => f a -> M1 a b -> b
runM1 FreeSemigroup a
g (M1 a a -> a) -> f (M1 a a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (M1 a a)
fm) a -> Tree1 a
forall a. a -> Tree1 a
Tip1 Tree1 a -> Tree1 a -> Tree1 a
forall a. Tree1 a -> Tree1 a -> Tree1 a
Bin1
  {-# INLINE distribute #-}

instance Cosieve M1 FreeSemigroup where
  cosieve :: M1 a b -> FreeSemigroup a -> b
cosieve = (FreeSemigroup a -> M1 a b -> b) -> M1 a b -> FreeSemigroup a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip FreeSemigroup a -> M1 a b -> b
forall (f :: * -> *) a b. Foldable1 f => f a -> M1 a b -> b
runM1

instance Profunctor.Corepresentable M1 where
  type Corep M1 = FreeSemigroup
  cotabulate :: (Corep M1 d -> c) -> M1 d c
cotabulate Corep M1 d -> c
f = (Tree1 d -> c)
-> (d -> Tree1 d) -> (Tree1 d -> Tree1 d -> Tree1 d) -> M1 d c
forall a b m. (m -> b) -> (a -> m) -> (m -> m -> m) -> M1 a b
M1 (Corep M1 d -> c
FreeSemigroup d -> c
f (FreeSemigroup d -> c)
-> (Tree1 d -> FreeSemigroup d) -> Tree1 d -> c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tree1 d -> FreeSemigroup d
forall (f :: * -> *) a.
(MuRef1 f, Bifoldable1 (DeRef1 f)) =>
f a -> FreeSemigroup a
foldDeRef1) d -> Tree1 d
forall a. a -> Tree1 a
Tip1 Tree1 d -> Tree1 d -> Tree1 d
forall a. Tree1 a -> Tree1 a -> Tree1 a
Bin1

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

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

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

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