-- |
-- Module      : Data.HFunctor.Chain
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- This module provides an 'Interpret'able data type of "linked list of
-- tensor applications".
--
-- The type @'Chain' t@, for any @'Tensor' t@, is meant to be the same as
-- @'ListBy' t@ (the monoidal functor combinator for @t@), and represents
-- "zero or more" applications of @f@ to @t@.
--
-- The type @'Chain1' t@, for any @'Associative' t@, is meant to be the
-- same as @'NonEmptyBy' t@ (the semigroupoidal functor combinator for @t@) and
-- represents "one or more" applications of @f@ to @t@.
--
-- The advantage of using 'Chain' and 'Chain1' over 'ListBy' or 'NonEmptyBy' is that
-- they provide a universal interface for pattern matching and constructing
-- such values, which may simplify working with new such functor
-- combinators you might encounter.
module Data.HFunctor.Chain (
  -- * 'Chain'
    Chain(..)
  , foldChain
  , unfoldChain
  , unroll
  , reroll
  , unrolling
  , appendChain
  , splittingChain
  , toChain
  , injectChain
  , unconsChain
  -- * 'Chain1'
  , Chain1(..)
  , foldChain1
  , unfoldChain1
  , unrollingNE
  , unrollNE
  , rerollNE
  , appendChain1
  , fromChain1
  , matchChain1
  , toChain1
  , injectChain1
  -- ** Matchable
  -- | The following conversions between 'Chain' and 'Chain1' are only
  -- possible if @t@ is 'Matchable'
  , splittingChain1
  , splitChain1
  , matchingChain
  , unmatchChain
  ) where

import           Control.Monad.Freer.Church
import           Control.Natural
import           Control.Natural.IsoF
import           Data.Functor.Bind
import           Data.Functor.Classes
import           Data.Functor.Contravariant
import           Data.Functor.Contravariant.Conclude
import           Data.Functor.Contravariant.Decide
import           Data.Functor.Contravariant.Divise
import           Data.Functor.Contravariant.Divisible
import           Data.Functor.Day hiding              (intro1, intro2, elim1, elim2)
import           Data.Functor.Identity
import           Data.Functor.Invariant
import           Data.Functor.Plus
import           Data.Functor.Product
import           Data.HBifunctor
import           Data.HBifunctor.Associative
import           Data.HBifunctor.Tensor
import           Data.HFunctor
import           Data.HFunctor.Interpret
import           Data.Kind
import           Data.Typeable
import           GHC.Generics
import qualified Data.Functor.Contravariant.Day       as CD
import qualified Data.Functor.Contravariant.Night     as N

-- | A useful construction that works like a "non-empty linked list" of @t
-- f@ applied to itself multiple times.  That is, it contains @t f f@, @t
-- f (t f f)@, @t f (t f (t f f))@, etc, with @f@ occuring /one or more/
-- times.  It is meant to be the same as @'NonEmptyBy' t@.
--
-- A @'Chain1' t f a@ is explicitly one of:
--
-- *  @f a@
-- *  @t f f a@
-- *  @t f (t f f) a@
-- *  @t f (t f (t f f)) a@
-- *  .. etc
--
-- Note that this is exactly the description of @'NonEmptyBy' t@.  And that's "the
-- point": for all instances of 'Associative', @'Chain1' t@ is
-- isomorphic to @'NonEmptyBy' t@ (witnessed by 'unrollingNE').  That's big picture
-- of 'NonEmptyBy': it's supposed to be a type that consists of all possible
-- self-applications of @f@ to @t@.
--
-- 'Chain1' gives you a way to work with all @'NonEmptyBy' t@ in a uniform way.
-- Unlike for @'NonEmptyBy' t f@ in general, you can always explicitly /pattern
-- match/ on a 'Chain1' (with its two constructors) and do what you please
-- with it.  You can also /construct/ 'Chain1' using normal constructors
-- and functions.
--
-- You can convert in between @'NonEmptyBy' t f@ and @'Chain1' t f@ with 'unrollNE'
-- and 'rerollNE'.  You can fully "collapse" a @'Chain1' t f@ into an @f@
-- with 'retract', if you have @'SemigroupIn' t f@; this could be considered
-- a fundamental property of semigroup-ness.
--
-- See 'Chain' for a version that has an "empty" value.
--
-- Another way of thinking of this is that @'Chain1' t@ is the "free
-- @'SemigroupIn' t@".  Given any functor @f@, @'Chain1' t f@ is
-- a semigroup in the semigroupoidal category of endofunctors enriched by
-- @t@.  So, @'Chain1' 'Control.Monad.Freer.Church.Comp'@ is the "free
-- 'Data.Functor.Bind.Bind'", @'Chain1' 'Day'@ is the "free
-- 'Data.Functor.Apply.Apply'", etc. You "lift" from @f a@ to @'Chain1'
-- t f a@ using 'inject'.
--
-- Note: this instance doesn't exist directly because of restrictions in
-- typeclasses, but is implemented as
--
-- @
-- 'Associative' t => 'SemigroupIn' ('WrapHBF' t) ('Chain1' t f)
-- @
--
-- where 'biretract' is 'appendChain1'.
--
-- You can fully "collapse" a @'Chain' t i f@ into an @f@ with
-- 'retract', if you have @'MonoidIn' t i f@; this could be considered
-- a fundamental property of monoid-ness.
--
--
-- This construction is inspired by iteratees and machines.
data Chain1 t f a = Done1 (f a)
                  | More1 (t f (Chain1 t f) a)
  deriving (Typeable, (forall x. Chain1 t f a -> Rep (Chain1 t f a) x)
-> (forall x. Rep (Chain1 t f a) x -> Chain1 t f a)
-> Generic (Chain1 t f a)
forall x. Rep (Chain1 t f a) x -> Chain1 t f a
forall x. Chain1 t f a -> Rep (Chain1 t f a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k) x.
Rep (Chain1 t f a) x -> Chain1 t f a
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k) x.
Chain1 t f a -> Rep (Chain1 t f a) x
$cto :: forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k) x.
Rep (Chain1 t f a) x -> Chain1 t f a
$cfrom :: forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k) x.
Chain1 t f a -> Rep (Chain1 t f a) x
Generic)

deriving instance (Eq (f a), Eq (t f (Chain1 t f) a)) => Eq (Chain1 t f a)
deriving instance (Ord (f a), Ord (t f (Chain1 t f) a)) => Ord (Chain1 t f a)
deriving instance (Show (f a), Show (t f (Chain1 t f) a)) => Show (Chain1 t f a)
deriving instance (Read (f a), Read (t f (Chain1 t f) a)) => Read (Chain1 t f a)
deriving instance (Functor f, Functor (t f (Chain1 t f))) => Functor (Chain1 t f)
deriving instance (Foldable f, Foldable (t f (Chain1 t f))) => Foldable (Chain1 t f)
deriving instance (Traversable f, Traversable (t f (Chain1 t f))) => Traversable (Chain1 t f)

instance (Eq1 f, Eq1 (t f (Chain1 t f))) => Eq1 (Chain1 t f) where
    liftEq :: (a -> b -> Bool) -> Chain1 t f a -> Chain1 t f b -> Bool
liftEq eq :: a -> b -> Bool
eq = \case
      Done1 x :: f a
x -> \case
        Done1 y :: f b
y -> (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq f a
x f b
y
        More1 _ -> Bool
False
      More1 x :: t f (Chain1 t f) a
x -> \case
        Done1 _ -> Bool
False
        More1 y :: t f (Chain1 t f) b
y -> (a -> b -> Bool)
-> t f (Chain1 t f) a -> t f (Chain1 t f) b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq t f (Chain1 t f) a
x t f (Chain1 t f) b
y

instance (Ord1 f, Ord1 (t f (Chain1 t f))) => Ord1 (Chain1 t f) where
    liftCompare :: (a -> b -> Ordering) -> Chain1 t f a -> Chain1 t f b -> Ordering
liftCompare c :: a -> b -> Ordering
c = \case
      Done1 x :: f a
x -> \case
        Done1 y :: f b
y -> (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
c f a
x f b
y
        More1 _ -> Ordering
LT
      More1 x :: t f (Chain1 t f) a
x -> \case
        Done1 _ -> Ordering
GT
        More1 y :: t f (Chain1 t f) b
y -> (a -> b -> Ordering)
-> t f (Chain1 t f) a -> t f (Chain1 t f) b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
c t f (Chain1 t f) a
x t f (Chain1 t f) b
y

instance (Show1 (t f (Chain1 t f)), Show1 f) => Show1 (Chain1 t f) where
    liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Chain1 t f a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d = \case
        Done1 x :: f a
x  -> (Int -> f a -> ShowS) -> String -> Int -> f a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) "Done1" Int
d f a
x
        More1 xs :: t f (Chain1 t f) a
xs -> (Int -> t f (Chain1 t f) a -> ShowS)
-> String -> Int -> t f (Chain1 t f) a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> t f (Chain1 t f) a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) "More1" Int
d t f (Chain1 t f) a
xs

instance (Functor f, Read1 (t f (Chain1 t f)), Read1 f) => Read1 (Chain1 t f) where
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Chain1 t f a)
liftReadsPrec rp :: Int -> ReadS a
rp rl :: ReadS [a]
rl = (String -> ReadS (Chain1 t f a)) -> Int -> ReadS (Chain1 t f a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Chain1 t f a)) -> Int -> ReadS (Chain1 t f a))
-> (String -> ReadS (Chain1 t f a)) -> Int -> ReadS (Chain1 t f a)
forall a b. (a -> b) -> a -> b
$
            (Int -> ReadS (f a))
-> String
-> (f a -> Chain1 t f a)
-> String
-> ReadS (Chain1 t f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) "Done1" f a -> Chain1 t f a
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1
         (String -> ReadS (Chain1 t f a))
-> (String -> ReadS (Chain1 t f a))
-> String
-> ReadS (Chain1 t f a)
forall a. Semigroup a => a -> a -> a
<> (Int -> ReadS (t f (Chain1 t f) a))
-> String
-> (t f (Chain1 t f) a -> Chain1 t f a)
-> String
-> ReadS (Chain1 t f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (t f (Chain1 t f) a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) "More1" t f (Chain1 t f) a -> Chain1 t f a
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1

-- | @since 0.3.0.0
instance (Contravariant f, Contravariant (t f (Chain1 t f))) => Contravariant (Chain1 t f) where
    contramap :: (a -> b) -> Chain1 t f b -> Chain1 t f a
contramap f :: a -> b
f = \case
      Done1 x :: f b
x  -> f a -> Chain1 t f a
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1 ((a -> b) -> f b -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f f b
x )
      More1 xs :: t f (Chain1 t f) b
xs -> t f (Chain1 t f) a -> Chain1 t f a
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 ((a -> b) -> t f (Chain1 t f) b -> t f (Chain1 t f) a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f t f (Chain1 t f) b
xs)

-- | @since 0.3.0.0
instance (Invariant f, Invariant (t f (Chain1 t f))) => Invariant (Chain1 t f) where
    invmap :: (a -> b) -> (b -> a) -> Chain1 t f a -> Chain1 t f b
invmap f :: a -> b
f g :: b -> a
g = \case
      Done1 x :: f a
x  -> f b -> Chain1 t f b
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1 ((a -> b) -> (b -> a) -> f a -> f b
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap a -> b
f b -> a
g f a
x )
      More1 xs :: t f (Chain1 t f) a
xs -> t f (Chain1 t f) b -> Chain1 t f b
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 ((a -> b) -> (b -> a) -> t f (Chain1 t f) a -> t f (Chain1 t f) b
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap a -> b
f b -> a
g t f (Chain1 t f) a
xs)


-- | Recursively fold down a 'Chain1'.  Provide a function on how to handle
-- the "single @f@ case" ('inject'), and how to handle the "combined @t
-- f g@ case", and this will fold the entire @'Chain1' t f@ into a single
-- @g@.
--
-- This is a catamorphism.
foldChain1
    :: forall t f g. HBifunctor t
    => f ~> g                   -- ^ handle 'Done1'
    -> t f g ~> g               -- ^ handle 'More1'
    -> Chain1 t f ~> g
foldChain1 :: (f ~> g) -> (t f g ~> g) -> Chain1 t f ~> g
foldChain1 f :: f ~> g
f g :: t f g ~> g
g = Chain1 t f x -> g x
Chain1 t f ~> g
go
  where
    go :: Chain1 t f ~> g
    go :: Chain1 t f x -> g x
go = \case
      Done1 x :: f x
x  -> f x -> g x
f ~> g
f f x
x
      More1 xs :: t f (Chain1 t f) x
xs -> t f g x -> g x
t f g ~> g
g ((Chain1 t f ~> g) -> t f (Chain1 t f) x -> t f g x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright Chain1 t f ~> g
go t f (Chain1 t f) x
xs)

-- | Recursively build up a 'Chain1'.  Provide a function that takes some
-- starting seed @g@ and returns either "done" (@f@) or "continue further"
-- (@t f g@), and it will create a @'Chain1' t f@ from a @g@.
--
-- This is an anamorphism.
unfoldChain1
    :: forall t f (g :: Type -> Type). HBifunctor t
    => (g ~> f :+: t f g)
    -> g ~> Chain1 t f
unfoldChain1 :: (g ~> (f :+: t f g)) -> g ~> Chain1 t f
unfoldChain1 f :: g ~> (f :+: t f g)
f = g x -> Chain1 t f x
g ~> Chain1 t f
go
  where
    go :: g ~> Chain1 t f
    go :: g x -> Chain1 t f x
go = (forall x. f x -> Chain1 t f x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1 (forall x. f x -> Chain1 t f x)
-> (t f g ~> Chain1 t f) -> (f :+: t f g) ~> Chain1 t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (h :: * -> *)
       (f :: * -> *) (g :: * -> *).
SemigroupIn t h =>
(f ~> h) -> (g ~> h) -> t f g ~> h
!*! t f (Chain1 t f) x -> Chain1 t f x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 (t f (Chain1 t f) x -> Chain1 t f x)
-> (t f g x -> t f (Chain1 t f) x) -> t f g x -> Chain1 t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> Chain1 t f) -> t f g ~> t f (Chain1 t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright g ~> Chain1 t f
go) ((:+:) f (t f g) x -> Chain1 t f x)
-> (g x -> (:+:) f (t f g) x) -> g x -> Chain1 t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> (:+:) f (t f g) x
g ~> (f :+: t f g)
f

instance HBifunctor t => HFunctor (Chain1 t) where
    hmap :: (f ~> g) -> Chain1 t f ~> Chain1 t g
hmap f :: f ~> g
f = (f ~> Chain1 t g)
-> (t f (Chain1 t g) ~> Chain1 t g) -> Chain1 t f ~> Chain1 t g
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *).
HBifunctor t =>
(f ~> g) -> (t f g ~> g) -> Chain1 t f ~> g
foldChain1 (g x -> Chain1 t g x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1 (g x -> Chain1 t g x) -> (f x -> g x) -> f x -> Chain1 t g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
f ~> g
f) (t g (Chain1 t g) x -> Chain1 t g x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 (t g (Chain1 t g) x -> Chain1 t g x)
-> (t f (Chain1 t g) x -> t g (Chain1 t g) x)
-> t f (Chain1 t g) x
-> Chain1 t g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ~> g) -> t f (Chain1 t g) ~> t g (Chain1 t g)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (j :: k -> *) (g :: k -> *).
HBifunctor t =>
(f ~> j) -> t f g ~> t j g
hleft f ~> g
f)

instance HBifunctor t => Inject (Chain1 t) where
    inject :: f x -> Chain1 t f x
inject  = f x -> Chain1 t f x
forall k (f :: k -> *) (t :: (k -> *) -> (k -> *) -> k -> *).
f ~> Chain1 t f
injectChain1

instance (HBifunctor t, SemigroupIn t f) => Interpret (Chain1 t) f where
    retract :: Chain1 t f x -> f x
retract = \case
      Done1 x :: f x
x  -> f x
x
      More1 xs :: t f (Chain1 t f) x
xs -> (f ~> f) -> (Chain1 t f ~> f) -> t f (Chain1 t f) x -> f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
SemigroupIn t f =>
(g ~> f) -> (h ~> f) -> t g h ~> f
binterpret forall a. a -> a
f ~> f
id Chain1 t f ~> f
forall k (t :: (k -> *) -> k -> *) (f :: k -> *).
Interpret t f =>
t f ~> f
retract t f (Chain1 t f) x
xs
    interpret :: forall g. g ~> f -> Chain1 t g ~> f
    interpret :: (g ~> f) -> Chain1 t g ~> f
interpret f :: g ~> f
f = Chain1 t g x -> f x
Chain1 t g ~> f
go
      where
        go :: Chain1 t g ~> f
        go :: Chain1 t g x -> f x
go = \case
          Done1 x :: g x
x  -> g x -> f x
g ~> f
f g x
x
          More1 xs :: t g (Chain1 t g) x
xs -> (g ~> f) -> (Chain1 t g ~> f) -> t g (Chain1 t g) x -> f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
SemigroupIn t f =>
(g ~> f) -> (h ~> f) -> t g h ~> f
binterpret g ~> f
f Chain1 t g ~> f
go t g (Chain1 t g) x
xs

-- | Convert a tensor value pairing two @f@s into a two-item 'Chain1'.  An
-- analogue of 'toNonEmptyBy'.
--
-- @since 0.3.1.0
toChain1 :: HBifunctor t => t f f ~> Chain1 t f
toChain1 :: t f f ~> Chain1 t f
toChain1 = t f (Chain1 t f) x -> Chain1 t f x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
t f (Chain1 t f) a -> Chain1 t f a
More1 (t f (Chain1 t f) x -> Chain1 t f x)
-> (t f f x -> t f (Chain1 t f) x) -> t f f x -> Chain1 t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ~> Chain1 t f) -> t f f ~> t f (Chain1 t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright f ~> Chain1 t f
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1

-- | Create a singleton 'Chain1'.
--
-- @since 0.3.0.0
injectChain1 :: f ~> Chain1 t f
injectChain1 :: f x -> Chain1 t f x
injectChain1 = f x -> Chain1 t f x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (a :: k).
f a -> Chain1 t f a
Done1

-- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of
-- @t@s to itself.  The type @'Chain1' t f@ is an actual concrete ADT that contains
-- successive applications of @t@ to itself, and you can pattern match on
-- each layer.
--
-- 'unrollingNE' states that the two types are isormorphic.  Use 'unrollNE'
-- and 'rerollNE' to convert between the two.
unrollingNE :: forall t f. (Associative t, FunctorBy t f) => NonEmptyBy t f <~> Chain1 t f
unrollingNE :: NonEmptyBy t f <~> Chain1 t f
unrollingNE = (NonEmptyBy t f ~> Chain1 t f)
-> (Chain1 t f ~> NonEmptyBy t f) -> NonEmptyBy t f <~> Chain1 t f
forall k (f :: k -> *) (g :: k -> *).
(f ~> g) -> (g ~> f) -> f <~> g
isoF NonEmptyBy t f ~> Chain1 t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
NonEmptyBy t f ~> Chain1 t f
unrollNE Chain1 t f ~> NonEmptyBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
Chain1 t f ~> NonEmptyBy t f
rerollNE

-- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of
-- @t@s to itself.  'unrollNE' makes that successive application explicit,
-- buy converting it to a literal 'Chain1' of applications of @t@ to
-- itself.
--
-- @
-- 'unrollNE' = 'unfoldChain1' 'matchNE'
-- @
unrollNE :: (Associative t, FunctorBy t f) => NonEmptyBy t f ~> Chain1 t f
unrollNE :: NonEmptyBy t f ~> Chain1 t f
unrollNE = (NonEmptyBy t f ~> (f :+: t f (NonEmptyBy t f)))
-> NonEmptyBy t f ~> Chain1 t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *).
HBifunctor t =>
(g ~> (f :+: t f g)) -> g ~> Chain1 t f
unfoldChain1 NonEmptyBy t f ~> (f :+: t f (NonEmptyBy t f))
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
NonEmptyBy t f ~> (f :+: t f (NonEmptyBy t f))
matchNE

-- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of
-- @t@s to itself.  'rerollNE' takes an explicit 'Chain1' of applications
-- of @t@ to itself and rolls it back up into an @'NonEmptyBy' t@.
--
-- @
-- 'rerollNE' = 'foldChain1' 'inject' 'consNE'
-- @
rerollNE :: Associative t => Chain1 t f ~> NonEmptyBy t f
rerollNE :: Chain1 t f ~> NonEmptyBy t f
rerollNE = (f ~> NonEmptyBy t f)
-> (t f (NonEmptyBy t f) ~> NonEmptyBy t f)
-> Chain1 t f ~> NonEmptyBy t f
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *).
HBifunctor t =>
(f ~> g) -> (t f g ~> g) -> Chain1 t f ~> g
foldChain1 f ~> NonEmptyBy t f
forall k (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
inject t f (NonEmptyBy t f) ~> NonEmptyBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
t f (NonEmptyBy t f) ~> NonEmptyBy t f
consNE

-- | 'Chain1' is a semigroup with respect to @t@: we can "combine" them in
-- an associative way.
--
-- This is essentially 'biretract', but only requiring @'Associative' t@:
-- it comes from the fact that @'Chain1' t@ is the "free @'SemigroupIn'
-- t@".
--
-- @since 0.1.1.0
appendChain1
    :: forall t f. (Associative t, FunctorBy t f)
    => t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 :: t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 = NonEmptyBy t f x -> Chain1 t f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
NonEmptyBy t f ~> Chain1 t f
unrollNE
             (NonEmptyBy t f x -> Chain1 t f x)
-> (t (Chain1 t f) (Chain1 t f) x -> NonEmptyBy t f x)
-> t (Chain1 t f) (Chain1 t f) x
-> Chain1 t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (NonEmptyBy t f) (NonEmptyBy t f) x -> NonEmptyBy t f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
t (NonEmptyBy t f) (NonEmptyBy t f) ~> NonEmptyBy t f
appendNE
             (t (NonEmptyBy t f) (NonEmptyBy t f) x -> NonEmptyBy t f x)
-> (t (Chain1 t f) (Chain1 t f) x
    -> t (NonEmptyBy t f) (NonEmptyBy t f) x)
-> t (Chain1 t f) (Chain1 t f) x
-> NonEmptyBy t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain1 t f ~> NonEmptyBy t f)
-> (Chain1 t f ~> NonEmptyBy t f)
-> t (Chain1 t f) (Chain1 t f)
   ~> t (NonEmptyBy t f) (NonEmptyBy t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (j :: k -> *) (g :: k -> *) (l :: k -> *).
HBifunctor t =>
(f ~> j) -> (g ~> l) -> t f g ~> t j l
hbimap Chain1 t f ~> NonEmptyBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
Chain1 t f ~> NonEmptyBy t f
rerollNE Chain1 t f ~> NonEmptyBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
Chain1 t f ~> NonEmptyBy t f
rerollNE

-- | @'Chain1' t@ is the "free @'SemigroupIn' t@".  However, we have to
-- wrap @t@ in 'WrapHBF' to prevent overlapping instances.
instance (Associative t, FunctorBy t f, FunctorBy t (Chain1 t f)) => SemigroupIn (WrapHBF t) (Chain1 t f) where
    biretract :: WrapHBF t (Chain1 t f) (Chain1 t f) x -> Chain1 t f x
biretract = t (Chain1 t f) (Chain1 t f) x -> Chain1 t f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (t (Chain1 t f) (Chain1 t f) x -> Chain1 t f x)
-> (WrapHBF t (Chain1 t f) (Chain1 t f) x
    -> t (Chain1 t f) (Chain1 t f) x)
-> WrapHBF t (Chain1 t f) (Chain1 t f) x
-> Chain1 t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapHBF t (Chain1 t f) (Chain1 t f) x
-> t (Chain1 t f) (Chain1 t f) x
forall k1 k2 k3 (t :: k1 -> k2 -> k3 -> *) (f :: k1) (g :: k2)
       (a :: k3).
WrapHBF t f g a -> t f g a
unwrapHBF
    binterpret :: (g ~> Chain1 t f)
-> (h ~> Chain1 t f) -> WrapHBF t g h ~> Chain1 t f
binterpret f :: g ~> Chain1 t f
f g :: h ~> Chain1 t f
g = WrapHBF t (Chain1 t f) (Chain1 t f) x -> Chain1 t f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
SemigroupIn t f =>
t f f ~> f
biretract (WrapHBF t (Chain1 t f) (Chain1 t f) x -> Chain1 t f x)
-> (WrapHBF t g h x -> WrapHBF t (Chain1 t f) (Chain1 t f) x)
-> WrapHBF t g h x
-> Chain1 t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> Chain1 t f)
-> (h ~> Chain1 t f)
-> WrapHBF t g h ~> WrapHBF t (Chain1 t f) (Chain1 t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (j :: k -> *) (g :: k -> *) (l :: k -> *).
HBifunctor t =>
(f ~> j) -> (g ~> l) -> t f g ~> t j l
hbimap g ~> Chain1 t f
f h ~> Chain1 t f
g

-- | @'Chain1' 'Day'@ is the free "semigroup in the semigroupoidal category
-- of endofunctors enriched by 'Day'" --- aka, the free 'Apply'.
instance Functor f => Apply (Chain1 Day f) where
    f :: Chain1 Day f (a -> b)
f <.> :: Chain1 Day f (a -> b) -> Chain1 Day f a -> Chain1 Day f b
<.> x :: Chain1 Day f a
x = Day (Chain1 Day f) (Chain1 Day f) b -> Chain1 Day f b
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (Day (Chain1 Day f) (Chain1 Day f) b -> Chain1 Day f b)
-> Day (Chain1 Day f) (Chain1 Day f) b -> Chain1 Day f b
forall a b. (a -> b) -> a -> b
$ Chain1 Day f (a -> b)
-> Chain1 Day f a
-> ((a -> b) -> a -> b)
-> Day (Chain1 Day f) (Chain1 Day f) b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day Chain1 Day f (a -> b)
f Chain1 Day f a
x (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)

instance Functor f => Apply (Chain1 Comp f) where
    <.> :: Chain1 Comp f (a -> b) -> Chain1 Comp f a -> Chain1 Comp f b
(<.>) = Chain1 Comp f (a -> b) -> Chain1 Comp f a -> Chain1 Comp f b
forall (f :: * -> *) a b. Bind f => f (a -> b) -> f a -> f b
apDefault

-- | @'Chain1' 'Comp'@ is the free "semigroup in the semigroupoidal
-- category of endofunctors enriched by 'Comp'" --- aka, the free 'Bind'.
instance Functor f => Bind (Chain1 Comp f) where
    x :: Chain1 Comp f a
x >>- :: Chain1 Comp f a -> (a -> Chain1 Comp f b) -> Chain1 Comp f b
>>- f :: a -> Chain1 Comp f b
f = Comp (Chain1 Comp f) (Chain1 Comp f) b -> Chain1 Comp f b
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (Chain1 Comp f a
x Chain1 Comp f a
-> (a -> Chain1 Comp f b) -> Comp (Chain1 Comp f) (Chain1 Comp f) b
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= a -> Chain1 Comp f b
f)

-- | @'Chain1' (':*:')@ is the free "semigroup in the semigroupoidal
-- category of endofunctors enriched by ':*:'" --- aka, the free 'Alt'.
instance Functor f => Alt (Chain1 (:*:) f) where
    x :: Chain1 (:*:) f a
x <!> :: Chain1 (:*:) f a -> Chain1 (:*:) f a -> Chain1 (:*:) f a
<!> y :: Chain1 (:*:) f a
y = (:*:) (Chain1 (:*:) f) (Chain1 (:*:) f) a -> Chain1 (:*:) f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (Chain1 (:*:) f a
x Chain1 (:*:) f a
-> Chain1 (:*:) f a -> (:*:) (Chain1 (:*:) f) (Chain1 (:*:) f) a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Chain1 (:*:) f a
y)

-- | @'Chain1' 'Product'@ is the free "semigroup in the semigroupoidal
-- category of endofunctors enriched by 'Product'" --- aka, the free 'Alt'.
instance Functor f => Alt (Chain1 Product f) where
    x :: Chain1 Product f a
x <!> :: Chain1 Product f a -> Chain1 Product f a -> Chain1 Product f a
<!> y :: Chain1 Product f a
y = Product (Chain1 Product f) (Chain1 Product f) a
-> Chain1 Product f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (Chain1 Product f a
-> Chain1 Product f a
-> Product (Chain1 Product f) (Chain1 Product f) a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair Chain1 Product f a
x Chain1 Product f a
y)

-- | @'Chain1' 'CD.Day'@ is the free "semigroup in the semigroupoidal
-- category of endofunctors enriched by 'CD.Day'" --- aka, the free 'Divise'.
--
-- @since 0.3.0.0
instance Contravariant f => Divise (Chain1 CD.Day f) where
    divise :: (a -> (b, c)) -> Chain1 Day f b -> Chain1 Day f c -> Chain1 Day f a
divise f :: a -> (b, c)
f x :: Chain1 Day f b
x y :: Chain1 Day f c
y = Day (Chain1 Day f) (Chain1 Day f) a -> Chain1 Day f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (Day (Chain1 Day f) (Chain1 Day f) a -> Chain1 Day f a)
-> Day (Chain1 Day f) (Chain1 Day f) a -> Chain1 Day f a
forall a b. (a -> b) -> a -> b
$ Chain1 Day f b
-> Chain1 Day f c
-> (a -> (b, c))
-> Day (Chain1 Day f) (Chain1 Day f) a
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (a -> (b, c)) -> Day f g a
CD.Day Chain1 Day f b
x Chain1 Day f c
y a -> (b, c)
f

-- | @'Chain1' 'N.Night'@ is the free "semigroup in the semigroupoidal
-- category of endofunctors enriched by 'N.Night'" --- aka, the free
-- 'Decide'.
--
-- @since 0.3.0.0
instance Contravariant f => Decide (Chain1 N.Night f) where
    decide :: (a -> Either b c)
-> Chain1 Night f b -> Chain1 Night f c -> Chain1 Night f a
decide f :: a -> Either b c
f x :: Chain1 Night f b
x y :: Chain1 Night f c
y = Night (Chain1 Night f) (Chain1 Night f) a -> Chain1 Night f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
t (Chain1 t f) (Chain1 t f) ~> Chain1 t f
appendChain1 (Night (Chain1 Night f) (Chain1 Night f) a -> Chain1 Night f a)
-> Night (Chain1 Night f) (Chain1 Night f) a -> Chain1 Night f a
forall a b. (a -> b) -> a -> b
$ Chain1 Night f b
-> Chain1 Night f c
-> (a -> Either b c)
-> Night (Chain1 Night f) (Chain1 Night f) a
forall (f :: * -> *) b (g :: * -> *) c a.
f b -> g c -> (a -> Either b c) -> Night f g a
N.Night Chain1 Night f b
x Chain1 Night f c
y a -> Either b c
f

-- | A useful construction that works like a "linked list" of @t f@ applied
-- to itself multiple times.  That is, it contains @t f f@, @t f (t f f)@,
-- @t f (t f (t f f))@, etc, with @f@ occuring /zero or more/ times.  It is
-- meant to be the same as @'ListBy' t@.
--
-- If @t@ is 'Tensor', then it means we can "collapse" this linked list
-- into some final type @'ListBy' t@ ('reroll'), and also extract it back
-- into a linked list ('unroll').
--
-- So, a value of type @'Chain' t i f a@ is one of either:
--
-- *  @i a@
-- *  @f a@
-- *  @t f f a@
-- *  @t f (t f f) a@
-- *  @t f (t f (t f f)) a@
-- *  .. etc.
--
-- Note that this is /exactly/ what an @'ListBy' t@ is supposed to be.  Using
-- 'Chain' allows us to work with all @'ListBy' t@s in a uniform way, with
-- normal pattern matching and normal constructors.
--
-- You can fully "collapse" a @'Chain' t i f@ into an @f@ with
-- 'retract', if you have @'MonoidIn' t i f@; this could be considered
-- a fundamental property of monoid-ness.
--
-- Another way of thinking of this is that @'Chain' t i@ is the "free
-- @'MonoidIn' t i@".  Given any functor @f@, @'Chain' t i f@ is a monoid
-- in the monoidal category of endofunctors enriched by @t@.  So, @'Chain'
-- 'Control.Monad.Freer.Church.Comp' 'Data.Functor.Identity.Identity'@ is
-- the "free 'Monad'", @'Chain' 'Data.Functor.Day.Day'
-- 'Data.Functor.Identity.Identity'@ is the "free 'Applicative'", etc.  You
-- "lift" from @f a@ to @'Chain' t i f a@ using 'inject'.
--
-- Note: this instance doesn't exist directly because of restrictions in
-- typeclasses, but is implemented as
--
-- @
-- 'Tensor' t i => 'MonoidIn' ('WrapHBF' t) ('WrapF' i) ('Chain' t i f)
-- @
--
-- where 'pureT' is 'Done' and 'biretract' is 'appendChain'.
--
-- This construction is inspired by
-- <http://oleg.fi/gists/posts/2018-02-21-single-free.html>
data Chain t i f a = Done (i a)
                   | More (t f (Chain t i f) a)

deriving instance (Eq (i a), Eq (t f (Chain t i f) a)) => Eq (Chain t i f a)
deriving instance (Ord (i a), Ord (t f (Chain t i f) a)) => Ord (Chain t i f a)
deriving instance (Show (i a), Show (t f (Chain t i f) a)) => Show (Chain t i f a)
deriving instance (Read (i a), Read (t f (Chain t i f) a)) => Read (Chain t i f a)
deriving instance (Functor i, Functor (t f (Chain t i f))) => Functor (Chain t i f)
deriving instance (Foldable i, Foldable (t f (Chain t i f))) => Foldable (Chain t i f)
deriving instance (Traversable i, Traversable (t f (Chain t i f))) => Traversable (Chain t i f)

instance (Eq1 i, Eq1 (t f (Chain t i f))) => Eq1 (Chain t i f) where
    liftEq :: (a -> b -> Bool) -> Chain t i f a -> Chain t i f b -> Bool
liftEq eq :: a -> b -> Bool
eq = \case
      Done x :: i a
x -> \case
        Done y :: i b
y -> (a -> b -> Bool) -> i a -> i b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq i a
x i b
y
        More _ -> Bool
False
      More x :: t f (Chain t i f) a
x -> \case
        Done _ -> Bool
False
        More y :: t f (Chain t i f) b
y -> (a -> b -> Bool)
-> t f (Chain t i f) a -> t f (Chain t i f) b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq t f (Chain t i f) a
x t f (Chain t i f) b
y

instance (Ord1 i, Ord1 (t f (Chain t i f))) => Ord1 (Chain t i f) where
    liftCompare :: (a -> b -> Ordering) -> Chain t i f a -> Chain t i f b -> Ordering
liftCompare c :: a -> b -> Ordering
c = \case
      Done x :: i a
x -> \case
        Done y :: i b
y -> (a -> b -> Ordering) -> i a -> i b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
c i a
x i b
y
        More _ -> Ordering
LT
      More x :: t f (Chain t i f) a
x -> \case
        Done _ -> Ordering
GT
        More y :: t f (Chain t i f) b
y -> (a -> b -> Ordering)
-> t f (Chain t i f) a -> t f (Chain t i f) b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
c t f (Chain t i f) a
x t f (Chain t i f) b
y

instance (Show1 (t f (Chain t i f)), Show1 i) => Show1 (Chain t i f) where
    liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Chain t i f a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d = \case
        Done x :: i a
x  -> (Int -> i a -> ShowS) -> String -> Int -> i a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> i a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) "Done" Int
d i a
x
        More xs :: t f (Chain t i f) a
xs -> (Int -> t f (Chain t i f) a -> ShowS)
-> String -> Int -> t f (Chain t i f) a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith ((Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> t f (Chain t i f) a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) "More" Int
d t f (Chain t i f) a
xs

instance (Functor i, Read1 (t f (Chain t i f)), Read1 i) => Read1 (Chain t i f) where
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Chain t i f a)
liftReadsPrec rp :: Int -> ReadS a
rp rl :: ReadS [a]
rl = (String -> ReadS (Chain t i f a)) -> Int -> ReadS (Chain t i f a)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Chain t i f a)) -> Int -> ReadS (Chain t i f a))
-> (String -> ReadS (Chain t i f a))
-> Int
-> ReadS (Chain t i f a)
forall a b. (a -> b) -> a -> b
$
            (Int -> ReadS (i a))
-> String
-> (i a -> Chain t i f a)
-> String
-> ReadS (Chain t i f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (i a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) "Done" i a -> Chain t i f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done
         (String -> ReadS (Chain t i f a))
-> (String -> ReadS (Chain t i f a))
-> String
-> ReadS (Chain t i f a)
forall a. Semigroup a => a -> a -> a
<> (Int -> ReadS (t f (Chain t i f) a))
-> String
-> (t f (Chain t i f) a -> Chain t i f a)
-> String
-> ReadS (Chain t i f a)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (t f (Chain t i f) a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) "More" t f (Chain t i f) a -> Chain t i f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More

instance (Contravariant i, Contravariant (t f (Chain t i f))) => Contravariant (Chain t i f) where
    contramap :: (a -> b) -> Chain t i f b -> Chain t i f a
contramap f :: a -> b
f = \case
      Done x :: i b
x  -> i a -> Chain t i f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done ((a -> b) -> i b -> i a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f i b
x )
      More xs :: t f (Chain t i f) b
xs -> t f (Chain t i f) a -> Chain t i f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More ((a -> b) -> t f (Chain t i f) b -> t f (Chain t i f) a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f t f (Chain t i f) b
xs)

instance (Invariant i, Invariant (t f (Chain t i f))) => Invariant (Chain t i f) where
    invmap :: (a -> b) -> (b -> a) -> Chain t i f a -> Chain t i f b
invmap f :: a -> b
f g :: b -> a
g = \case
      Done x :: i a
x  -> i b -> Chain t i f b
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done ((a -> b) -> (b -> a) -> i a -> i b
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap a -> b
f b -> a
g i a
x )
      More xs :: t f (Chain t i f) a
xs -> t f (Chain t i f) b -> Chain t i f b
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More ((a -> b) -> (b -> a) -> t f (Chain t i f) a -> t f (Chain t i f) b
forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap a -> b
f b -> a
g t f (Chain t i f) a
xs)

-- | Recursively fold down a 'Chain'.  Provide a function on how to handle
-- the "single @f@ case" ('nilLB'), and how to handle the "combined @t f g@
-- case", and this will fold the entire @'Chain' t i) f@ into a single @g@.
--
-- This is a catamorphism.
foldChain
    :: forall t i f g. HBifunctor t
    => (i ~> g)             -- ^ Handle 'Done'
    -> (t f g ~> g)         -- ^ Handle 'More'
    -> Chain t i f ~> g
foldChain :: (i ~> g) -> (t f g ~> g) -> Chain t i f ~> g
foldChain f :: i ~> g
f g :: t f g ~> g
g = Chain t i f x -> g x
Chain t i f ~> g
go
  where
    go :: Chain t i f ~> g
    go :: Chain t i f x -> g x
go = \case
      Done x :: i x
x  -> i x -> g x
i ~> g
f i x
x
      More xs :: t f (Chain t i f) x
xs -> t f g x -> g x
t f g ~> g
g ((Chain t i f ~> g) -> t f (Chain t i f) x -> t f g x
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright Chain t i f ~> g
go t f (Chain t i f) x
xs)

-- | Recursively build up a 'Chain'.  Provide a function that takes some
-- starting seed @g@ and returns either "done" (@i@) or "continue further"
-- (@t f g@), and it will create a @'Chain' t i f@ from a @g@.
--
-- This is an anamorphism.
unfoldChain
    :: forall t f (g :: Type -> Type) i. HBifunctor t
    => (g ~> i :+: t f g)
    -> g ~> Chain t i f
unfoldChain :: (g ~> (i :+: t f g)) -> g ~> Chain t i f
unfoldChain f :: g ~> (i :+: t f g)
f = g x -> Chain t i f x
g ~> Chain t i f
go
  where
    go :: g a -> Chain t i f a
    go :: g a -> Chain t i f a
go = (forall x. i x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (forall x. i x -> Chain t i f x)
-> (t f g ~> Chain t i f) -> (i :+: t f g) ~> Chain t i f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (h :: * -> *)
       (f :: * -> *) (g :: * -> *).
SemigroupIn t h =>
(f ~> h) -> (g ~> h) -> t f g ~> h
!*! t f (Chain t i f) x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More (t f (Chain t i f) x -> Chain t i f x)
-> (t f g x -> t f (Chain t i f) x) -> t f g x -> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> Chain t i f) -> t f g ~> t f (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright g ~> Chain t i f
go) ((:+:) i (t f g) a -> Chain t i f a)
-> (g a -> (:+:) i (t f g) a) -> g a -> Chain t i f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> (:+:) i (t f g) a
g ~> (i :+: t f g)
f

instance HBifunctor t => HFunctor (Chain t i) where
    hmap :: (f ~> g) -> Chain t i f ~> Chain t i g
hmap f :: f ~> g
f = (i ~> Chain t i g)
-> (t f (Chain t i g) ~> Chain t i g) -> Chain t i f ~> Chain t i g
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (i :: k -> *)
       (f :: k -> *) (g :: k -> *).
HBifunctor t =>
(i ~> g) -> (t f g ~> g) -> Chain t i f ~> g
foldChain i ~> Chain t i g
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (t g (Chain t i g) x -> Chain t i g x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More (t g (Chain t i g) x -> Chain t i g x)
-> (t f (Chain t i g) x -> t g (Chain t i g) x)
-> t f (Chain t i g) x
-> Chain t i g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ~> g) -> t f (Chain t i g) ~> t g (Chain t i g)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (j :: k -> *) (g :: k -> *).
HBifunctor t =>
(f ~> j) -> t f g ~> t j g
hleft f ~> g
f)

instance Tensor t i => Inject (Chain t i) where
    inject :: f x -> Chain t i f x
inject = f x -> Chain t i f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
f ~> Chain t i f
injectChain

-- | We can collapse and interpret an @'Chain' t i@ if we have @'Tensor' t@.
instance MonoidIn t i f => Interpret (Chain t i) f where
    interpret
        :: forall g. ()
        => g ~> f
        -> Chain t i g ~> f
    interpret :: (g ~> f) -> Chain t i g ~> f
interpret f :: g ~> f
f = Chain t i g x -> f x
Chain t i g ~> f
go
      where
        go :: Chain t i g ~> f
        go :: Chain t i g x -> f x
go = \case
          Done x :: i x
x  -> i x -> f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
MonoidIn t i f =>
i ~> f
pureT @t i x
x
          More xs :: t g (Chain t i g) x
xs -> (g ~> f) -> (Chain t i g ~> f) -> t g (Chain t i g) x -> f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (h :: * -> *).
SemigroupIn t f =>
(g ~> f) -> (h ~> f) -> t g h ~> f
binterpret g ~> f
f Chain t i g ~> f
go t g (Chain t i g) x
xs

-- | Convert a tensor value pairing two @f@s into a two-item 'Chain'.  An
-- analogue of 'toListBy'.
--
-- @since 0.3.1.0
toChain :: Tensor t i => t f f ~> Chain t i f
toChain :: t f f ~> Chain t i f
toChain = t f (Chain t i f) x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More (t f (Chain t i f) x -> Chain t i f x)
-> (t f f x -> t f (Chain t i f) x) -> t f f x -> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f ~> Chain t i f) -> t f f ~> t f (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright f ~> Chain t i f
forall k (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
inject

-- | Create a singleton chain.
--
-- @since 0.3.0.0
injectChain :: Tensor t i => f ~> Chain t i f
injectChain :: f ~> Chain t i f
injectChain = t f (Chain t i f) x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More (t f (Chain t i f) x -> Chain t i f x)
-> (f x -> t f (Chain t i f) x) -> f x -> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i ~> Chain t i f) -> t f i ~> t f (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright i ~> Chain t i f
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (t f i x -> t f (Chain t i f) x)
-> (f x -> t f i x) -> f x -> t f (Chain t i f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> t f i x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
f ~> t f i
intro1

-- | A 'Chain1' is "one or more linked @f@s", and a 'Chain' is "zero or
-- more linked @f@s".  So, we can convert from a 'Chain1' to a 'Chain' that
-- always has at least one @f@.
--
-- The result of this function always is made with 'More' at the top level.
fromChain1
    :: Tensor t i
    => Chain1 t f ~> Chain t i f
fromChain1 :: Chain1 t f ~> Chain t i f
fromChain1 = (f ~> Chain t i f)
-> (t f (Chain t i f) ~> Chain t i f) -> Chain1 t f ~> Chain t i f
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (g :: k -> *).
HBifunctor t =>
(f ~> g) -> (t f g ~> g) -> Chain1 t f ~> g
foldChain1 (t f (Chain t i f) x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More (t f (Chain t i f) x -> Chain t i f x)
-> (f x -> t f (Chain t i f) x) -> f x -> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i ~> Chain t i f) -> t f i ~> t f (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright i ~> Chain t i f
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (t f i x -> t f (Chain t i f) x)
-> (f x -> t f i x) -> f x -> t f (Chain t i f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> t f i x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
f ~> t f i
intro1) t f (Chain t i f) ~> Chain t i f
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More

-- | A type @'ListBy' t@ is supposed to represent the successive application of
-- @t@s to itself.  The type @'Chain' t i f@ is an actual concrete
-- ADT that contains successive applications of @t@ to itself, and you can
-- pattern match on each layer.
--
-- 'unrolling' states that the two types are isormorphic.  Use 'unroll'
-- and 'reroll' to convert between the two.
unrolling
    :: Tensor t i
    => ListBy t f <~> Chain t i f
unrolling :: ListBy t f <~> Chain t i f
unrolling = (ListBy t f ~> Chain t i f)
-> (Chain t i f ~> ListBy t f) -> ListBy t f <~> Chain t i f
forall k (f :: k -> *) (g :: k -> *).
(f ~> g) -> (g ~> f) -> f <~> g
isoF ListBy t f ~> Chain t i f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f ~> Chain t i f
unroll Chain t i f ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
Chain t i f ~> ListBy t f
reroll

-- | A type @'ListBy' t@ is supposed to represent the successive application of
-- @t@s to itself.  'unroll' makes that successive application explicit,
-- buy converting it to a literal 'Chain' of applications of @t@ to
-- itself.
--
-- @
-- 'unroll' = 'unfoldChain' 'unconsLB'
-- @
unroll
    :: Tensor t i
    => ListBy t f ~> Chain t i f
unroll :: ListBy t f ~> Chain t i f
unroll = (ListBy t f ~> (i :+: t f (ListBy t f)))
-> ListBy t f ~> Chain t i f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *)
       (g :: * -> *) (i :: * -> *).
HBifunctor t =>
(g ~> (i :+: t f g)) -> g ~> Chain t i f
unfoldChain ListBy t f ~> (i :+: t f (ListBy t f))
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f ~> (i :+: t f (ListBy t f))
unconsLB

-- | A type @'ListBy' t@ is supposed to represent the successive application of
-- @t@s to itself.  'rerollNE' takes an explicit 'Chain' of applications of
-- @t@ to itself and rolls it back up into an @'ListBy' t@.
--
-- @
-- 'reroll' = 'foldChain' 'nilLB' 'consLB'
-- @
--
-- Because @t@ cannot be inferred from the input or output, you should call
-- this with /-XTypeApplications/:
--
-- @
-- 'reroll' \@'Control.Monad.Freer.Church.Comp'
--     :: 'Chain' Comp 'Data.Functor.Identity.Identity' f a -> 'Control.Monad.Freer.Church.Free' f a
-- @
reroll
    :: forall t i f. Tensor t i
    => Chain t i f ~> ListBy t f
reroll :: Chain t i f ~> ListBy t f
reroll = (i ~> ListBy t f)
-> (t f (ListBy t f) ~> ListBy t f) -> Chain t i f ~> ListBy t f
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (i :: k -> *)
       (f :: k -> *) (g :: k -> *).
HBifunctor t =>
(i ~> g) -> (t f g ~> g) -> Chain t i f ~> g
foldChain (forall (i :: * -> *) (f :: * -> *). Tensor t i => i ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
i ~> ListBy t f
nilLB @t) t f (ListBy t f) ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t f (ListBy t f) ~> ListBy t f
consLB

-- | 'Chain' is a monoid with respect to @t@: we can "combine" them in
-- an associative way.  The identity here is anything made with the 'Done'
-- constructor.
--
-- This is essentially 'biretract', but only requiring @'Tensor' t i@: it
-- comes from the fact that @'Chain1' t i@ is the "free @'MonoidIn' t i@".
-- 'pureT' is 'Done'.
--
-- @since 0.1.1.0
appendChain
    :: forall t i f. Tensor t i
    => t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain :: t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain = ListBy t f x -> Chain t i f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f ~> Chain t i f
unroll
            (ListBy t f x -> Chain t i f x)
-> (t (Chain t i f) (Chain t i f) x -> ListBy t f x)
-> t (Chain t i f) (Chain t i f) x
-> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (ListBy t f) (ListBy t f) x -> ListBy t f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (ListBy t f) (ListBy t f) ~> ListBy t f
appendLB
            (t (ListBy t f) (ListBy t f) x -> ListBy t f x)
-> (t (Chain t i f) (Chain t i f) x
    -> t (ListBy t f) (ListBy t f) x)
-> t (Chain t i f) (Chain t i f) x
-> ListBy t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain t i f ~> ListBy t f)
-> (Chain t i f ~> ListBy t f)
-> t (Chain t i f) (Chain t i f) ~> t (ListBy t f) (ListBy t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (j :: k -> *) (g :: k -> *) (l :: k -> *).
HBifunctor t =>
(f ~> j) -> (g ~> l) -> t f g ~> t j l
hbimap Chain t i f ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
Chain t i f ~> ListBy t f
reroll Chain t i f ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
Chain t i f ~> ListBy t f
reroll

-- | For completeness, an isomorphism between 'Chain1' and its two
-- constructors, to match 'matchNE'.
--
-- @since 0.3.0.0
matchChain1 :: Chain1 t f ~> (f :+: t f (Chain1 t f))
matchChain1 :: Chain1 t f x -> (:+:) f (t f (Chain1 t f)) x
matchChain1 = \case
    Done1 x :: f x
x  -> f x -> (:+:) f (t f (Chain1 t f)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f x
x
    More1 xs :: t f (Chain1 t f) x
xs -> t f (Chain1 t f) x -> (:+:) f (t f (Chain1 t f)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 t f (Chain1 t f) x
xs

-- | For completeness, an isomorphism between 'Chain' and its two
-- constructors, to match 'splittingLB'.
--
-- @since 0.3.0.0
splittingChain :: Chain t i f <~> (i :+: t f (Chain t i f))
splittingChain :: p ((:+:) i (t f (Chain t i f)) a) ((:+:) i (t f (Chain t i f)) a)
-> p (Chain t i f a) (Chain t i f a)
splittingChain = (Chain t i f ~> (i :+: t f (Chain t i f)))
-> ((i :+: t f (Chain t i f)) ~> Chain t i f)
-> Chain t i f <~> (i :+: t f (Chain t i f))
forall k (f :: k -> *) (g :: k -> *).
(f ~> g) -> (g ~> f) -> f <~> g
isoF Chain t i f ~> (i :+: t f (Chain t i f))
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k).
Chain t i f ~> (i :+: t f (Chain t i f))
unconsChain (((i :+: t f (Chain t i f)) ~> Chain t i f)
 -> p ((:+:) i (t f (Chain t i f)) a)
      ((:+:) i (t f (Chain t i f)) a)
 -> p (Chain t i f a) (Chain t i f a))
-> ((i :+: t f (Chain t i f)) ~> Chain t i f)
-> p ((:+:) i (t f (Chain t i f)) a)
     ((:+:) i (t f (Chain t i f)) a)
-> p (Chain t i f a) (Chain t i f a)
forall a b. (a -> b) -> a -> b
$ \case
      L1 x  -> i x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done i x
x
      R1 xs -> t f (Chain t i f) x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
t f (Chain t i f) a -> Chain t i f a
More t f (Chain t i f) x
xs

-- | An analogue of 'unconsLB': match one of the two constructors of
-- a 'Chain'.
--
-- @since 0.3.0.0
unconsChain :: Chain t i f ~> i :+: t f (Chain t i f)
unconsChain :: Chain t i f x -> (:+:) i (t f (Chain t i f)) x
unconsChain = \case
    Done x :: i x
x  -> i x -> (:+:) i (t f (Chain t i f)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 i x
x
    More xs :: t f (Chain t i f) x
xs -> t f (Chain t i f) x -> (:+:) i (t f (Chain t i f)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 t f (Chain t i f) x
xs

-- | A @'Chain1' t f@ is like a non-empty linked list of @f@s, and
-- a @'Chain' t i f@ is a possibly-empty linked list of @f@s.  This
-- witnesses the fact that the former is isomorphic to @f@ consed to the
-- latter.
splittingChain1
    :: forall t i f. (Matchable t i, FunctorBy t f)
    => Chain1 t f <~> t f (Chain t i f)
splittingChain1 :: Chain1 t f <~> t f (Chain t i f)
splittingChain1 = (NonEmptyBy t f <~> Chain1 t f) -> Chain1 t f <~> NonEmptyBy t f
forall (f :: * -> *) (g :: * -> *). (f <~> g) -> g <~> f
fromF NonEmptyBy t f <~> Chain1 t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
NonEmptyBy t f <~> Chain1 t f
unrollingNE
                (p (NonEmptyBy t f a) (NonEmptyBy t f a)
 -> p (Chain1 t f a) (Chain1 t f a))
-> (p (t f (Chain t i f) a) (t f (Chain t i f) a)
    -> p (NonEmptyBy t f a) (NonEmptyBy t f a))
-> p (t f (Chain t i f) a) (t f (Chain t i f) a)
-> p (Chain1 t f a) (Chain1 t f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (i :: * -> *) (f :: * -> *).
(Matchable t i, FunctorBy t f) =>
NonEmptyBy t f <~> t f (ListBy t f)
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
(Matchable t i, FunctorBy t f) =>
NonEmptyBy t f <~> t f (ListBy t f)
splittingNE @t
                (p (t f (ListBy t f) a) (t f (ListBy t f) a)
 -> p (NonEmptyBy t f a) (NonEmptyBy t f a))
-> (p (t f (Chain t i f) a) (t f (Chain t i f) a)
    -> p (t f (ListBy t f) a) (t f (ListBy t f) a))
-> p (t f (Chain t i f) a) (t f (Chain t i f) a)
-> p (NonEmptyBy t f a) (NonEmptyBy t f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f <~> f)
-> (ListBy t f <~> Chain t i f)
-> t f (ListBy t f) <~> t f (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (f' :: k -> *) (g :: k -> *) (g' :: k -> *).
HBifunctor t =>
(f <~> f') -> (g <~> g') -> t f g <~> t f' g'
overHBifunctor forall a. a -> a
f <~> f
id ListBy t f <~> Chain t i f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f <~> Chain t i f
unrolling

-- | The "forward" function representing 'splittingChain1'.  Provided here
-- as a separate function because it does not require @'Functor' f@.
splitChain1
    :: forall t i f. Tensor t i
    => Chain1 t f ~> t f (Chain t i f)
splitChain1 :: Chain1 t f ~> t f (Chain t i f)
splitChain1 = (ListBy t f ~> Chain t i f)
-> t f (ListBy t f) ~> t f (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright (forall (i :: * -> *) (f :: * -> *).
Tensor t i =>
ListBy t f ~> Chain t i f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f ~> Chain t i f
unroll @t) (t f (ListBy t f) x -> t f (Chain t i f) x)
-> (Chain1 t f x -> t f (ListBy t f) x)
-> Chain1 t f x
-> t f (Chain t i f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (i :: * -> *) (f :: * -> *).
Tensor t i =>
NonEmptyBy t f ~> t f (ListBy t f)
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
NonEmptyBy t f ~> t f (ListBy t f)
splitNE @t (NonEmptyBy t f x -> t f (ListBy t f) x)
-> (Chain1 t f x -> NonEmptyBy t f x)
-> Chain1 t f x
-> t f (ListBy t f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain1 t f x -> NonEmptyBy t f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
Chain1 t f ~> NonEmptyBy t f
rerollNE

-- | A @'Chain' t i f@ is a linked list of @f@s, and a @'Chain1' t f@ is
-- a non-empty linked list of @f@s.  This witnesses the fact that
-- a @'Chain' t i f@ is either empty (@i@) or non-empty (@'Chain1' t f@).
matchingChain
    :: forall t i f. (Tensor t i, Matchable t i, FunctorBy t f)
    => Chain t i f <~> i :+: Chain1 t f
matchingChain :: Chain t i f <~> (i :+: Chain1 t f)
matchingChain = (ListBy t f <~> Chain t i f) -> Chain t i f <~> ListBy t f
forall (f :: * -> *) (g :: * -> *). (f <~> g) -> g <~> f
fromF ListBy t f <~> Chain t i f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f <~> Chain t i f
unrolling
              (p (ListBy t f a) (ListBy t f a)
 -> p (Chain t i f a) (Chain t i f a))
-> (p ((:+:) i (Chain1 t f) a) ((:+:) i (Chain1 t f) a)
    -> p (ListBy t f a) (ListBy t f a))
-> p ((:+:) i (Chain1 t f) a) ((:+:) i (Chain1 t f) a)
-> p (Chain t i f a) (Chain t i f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (i :: * -> *) (f :: * -> *).
(Matchable t i, FunctorBy t f) =>
ListBy t f <~> (i :+: NonEmptyBy t f)
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
(Matchable t i, FunctorBy t f) =>
ListBy t f <~> (i :+: NonEmptyBy t f)
matchingLB @t
              (p ((:+:) i (NonEmptyBy t f) a) ((:+:) i (NonEmptyBy t f) a)
 -> p (ListBy t f a) (ListBy t f a))
-> (p ((:+:) i (Chain1 t f) a) ((:+:) i (Chain1 t f) a)
    -> p ((:+:) i (NonEmptyBy t f) a) ((:+:) i (NonEmptyBy t f) a))
-> p ((:+:) i (Chain1 t f) a) ((:+:) i (Chain1 t f) a)
-> p (ListBy t f a) (ListBy t f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i <~> i)
-> (NonEmptyBy t f <~> Chain1 t f)
-> (i :+: NonEmptyBy t f) <~> (i :+: Chain1 t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (f' :: k -> *) (g :: k -> *) (g' :: k -> *).
HBifunctor t =>
(f <~> f') -> (g <~> g') -> t f g <~> t f' g'
overHBifunctor forall a. a -> a
i <~> i
id NonEmptyBy t f <~> Chain1 t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
(Associative t, FunctorBy t f) =>
NonEmptyBy t f <~> Chain1 t f
unrollingNE

-- | The "reverse" function representing 'matchingChain'.  Provided here
-- as a separate function because it does not require @'Functor' f@.
unmatchChain
    :: forall t i f. Tensor t i
    => i :+: Chain1 t f ~> Chain t i f
unmatchChain :: (i :+: Chain1 t f) ~> Chain t i f
unmatchChain = ListBy t f x -> Chain t i f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
ListBy t f ~> Chain t i f
unroll (ListBy t f x -> Chain t i f x)
-> ((:+:) i (Chain1 t f) x -> ListBy t f x)
-> (:+:) i (Chain1 t f) x
-> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (i :: * -> *) (f :: * -> *). Tensor t i => i ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
i ~> ListBy t f
nilLB @t (forall x. i x -> ListBy t f x)
-> (NonEmptyBy t f ~> ListBy t f)
-> (i :+: NonEmptyBy t f) ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (h :: * -> *)
       (f :: * -> *) (g :: * -> *).
SemigroupIn t h =>
(f ~> h) -> (g ~> h) -> t f g ~> h
!*! forall (i :: * -> *) (f :: * -> *).
Tensor t i =>
NonEmptyBy t f ~> ListBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
NonEmptyBy t f ~> ListBy t f
fromNE @t) ((:+:) i (NonEmptyBy t f) x -> ListBy t f x)
-> ((:+:) i (Chain1 t f) x -> (:+:) i (NonEmptyBy t f) x)
-> (:+:) i (Chain1 t f) x
-> ListBy t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain1 t f ~> NonEmptyBy t f)
-> (i :+: Chain1 t f) ~> (i :+: NonEmptyBy t f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (g :: k -> *)
       (l :: k -> *) (f :: k -> *).
HBifunctor t =>
(g ~> l) -> t f g ~> t f l
hright Chain1 t f ~> NonEmptyBy t f
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
Associative t =>
Chain1 t f ~> NonEmptyBy t f
rerollNE

-- | We have to wrap @t@ in 'WrapHBF' to prevent overlapping instances.
instance (Tensor t i, FunctorBy t (Chain t i f)) => SemigroupIn (WrapHBF t) (Chain t i f) where
    biretract :: WrapHBF t (Chain t i f) (Chain t i f) x -> Chain t i f x
biretract = t (Chain t i f) (Chain t i f) x -> Chain t i f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (t (Chain t i f) (Chain t i f) x -> Chain t i f x)
-> (WrapHBF t (Chain t i f) (Chain t i f) x
    -> t (Chain t i f) (Chain t i f) x)
-> WrapHBF t (Chain t i f) (Chain t i f) x
-> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapHBF t (Chain t i f) (Chain t i f) x
-> t (Chain t i f) (Chain t i f) x
forall k1 k2 k3 (t :: k1 -> k2 -> k3 -> *) (f :: k1) (g :: k2)
       (a :: k3).
WrapHBF t f g a -> t f g a
unwrapHBF
    binterpret :: (g ~> Chain t i f)
-> (h ~> Chain t i f) -> WrapHBF t g h ~> Chain t i f
binterpret f :: g ~> Chain t i f
f g :: h ~> Chain t i f
g = WrapHBF t (Chain t i f) (Chain t i f) x -> Chain t i f x
forall (t :: (* -> *) -> (* -> *) -> * -> *) (f :: * -> *).
SemigroupIn t f =>
t f f ~> f
biretract (WrapHBF t (Chain t i f) (Chain t i f) x -> Chain t i f x)
-> (WrapHBF t g h x -> WrapHBF t (Chain t i f) (Chain t i f) x)
-> WrapHBF t g h x
-> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g ~> Chain t i f)
-> (h ~> Chain t i f)
-> WrapHBF t g h ~> WrapHBF t (Chain t i f) (Chain t i f)
forall k (t :: (k -> *) -> (k -> *) -> k -> *) (f :: k -> *)
       (j :: k -> *) (g :: k -> *) (l :: k -> *).
HBifunctor t =>
(f ~> j) -> (g ~> l) -> t f g ~> t j l
hbimap g ~> Chain t i f
f h ~> Chain t i f
g

-- | @'Chain' t i@ is the "free @'MonoidIn' t i@".  However, we have to
-- wrap @t@ in 'WrapHBF' and @i@ in 'WrapF' to prevent overlapping instances.
instance (Tensor t i, FunctorBy t (Chain t i f)) => MonoidIn (WrapHBF t) (WrapF i) (Chain t i f) where
    pureT :: WrapF i x -> Chain t i f x
pureT = i x -> Chain t i f x
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (i x -> Chain t i f x)
-> (WrapF i x -> i x) -> WrapF i x -> Chain t i f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapF i x -> i x
forall k (f :: k -> *) (a :: k). WrapF f a -> f a
unwrapF

instance Apply (Chain Day Identity f) where
    f :: Chain Day Identity f (a -> b)
f <.> :: Chain Day Identity f (a -> b)
-> Chain Day Identity f a -> Chain Day Identity f b
<.> x :: Chain Day Identity f a
x = Day (Chain Day Identity f) (Chain Day Identity f) b
-> Chain Day Identity f b
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Day (Chain Day Identity f) (Chain Day Identity f) b
 -> Chain Day Identity f b)
-> Day (Chain Day Identity f) (Chain Day Identity f) b
-> Chain Day Identity f b
forall a b. (a -> b) -> a -> b
$ Chain Day Identity f (a -> b)
-> Chain Day Identity f a
-> ((a -> b) -> a -> b)
-> Day (Chain Day Identity f) (Chain Day Identity f) b
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (b -> c -> a) -> Day f g a
Day Chain Day Identity f (a -> b)
f Chain Day Identity f a
x (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)

-- | @'Chain' 'Day' 'Identity'@ is the free "monoid in the monoidal
-- category of endofunctors enriched by 'Day'" --- aka, the free
-- 'Applicative'.
instance Applicative (Chain Day Identity f) where
    pure :: a -> Chain Day Identity f a
pure  = Identity a -> Chain Day Identity f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (Identity a -> Chain Day Identity f a)
-> (a -> Identity a) -> a -> Chain Day Identity f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity a
forall a. a -> Identity a
Identity
    <*> :: Chain Day Identity f (a -> b)
-> Chain Day Identity f a -> Chain Day Identity f b
(<*>) = Chain Day Identity f (a -> b)
-> Chain Day Identity f a -> Chain Day Identity f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>)

-- | @since 0.3.0.0
instance Divise (Chain CD.Day Proxy f) where
    divise :: (a -> (b, c))
-> Chain Day Proxy f b
-> Chain Day Proxy f c
-> Chain Day Proxy f a
divise f :: a -> (b, c)
f x :: Chain Day Proxy f b
x y :: Chain Day Proxy f c
y = Day (Chain Day Proxy f) (Chain Day Proxy f) a
-> Chain Day Proxy f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Day (Chain Day Proxy f) (Chain Day Proxy f) a
 -> Chain Day Proxy f a)
-> Day (Chain Day Proxy f) (Chain Day Proxy f) a
-> Chain Day Proxy f a
forall a b. (a -> b) -> a -> b
$ Chain Day Proxy f b
-> Chain Day Proxy f c
-> (a -> (b, c))
-> Day (Chain Day Proxy f) (Chain Day Proxy f) a
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (a -> (b, c)) -> Day f g a
CD.Day Chain Day Proxy f b
x Chain Day Proxy f c
y a -> (b, c)
f

-- | @'Chain' 'CD.Day' 'Proxy'@ is the free "monoid in the monoidal
-- category of endofunctors enriched by contravariant 'CD.Day'" --- aka,
-- the free 'Divisible'.
--
-- @since 0.3.0.0
instance Divisible (Chain CD.Day Proxy f) where
    divide :: (a -> (b, c))
-> Chain Day Proxy f b
-> Chain Day Proxy f c
-> Chain Day Proxy f a
divide f :: a -> (b, c)
f x :: Chain Day Proxy f b
x y :: Chain Day Proxy f c
y = Day (Chain Day Proxy f) (Chain Day Proxy f) a
-> Chain Day Proxy f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Day (Chain Day Proxy f) (Chain Day Proxy f) a
 -> Chain Day Proxy f a)
-> Day (Chain Day Proxy f) (Chain Day Proxy f) a
-> Chain Day Proxy f a
forall a b. (a -> b) -> a -> b
$ Chain Day Proxy f b
-> Chain Day Proxy f c
-> (a -> (b, c))
-> Day (Chain Day Proxy f) (Chain Day Proxy f) a
forall (f :: * -> *) (g :: * -> *) a b c.
f b -> g c -> (a -> (b, c)) -> Day f g a
CD.Day Chain Day Proxy f b
x Chain Day Proxy f c
y a -> (b, c)
f
    conquer :: Chain Day Proxy f a
conquer = Proxy a -> Chain Day Proxy f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done Proxy a
forall k (t :: k). Proxy t
Proxy

-- | @since 0.3.0.0
instance Decide (Chain N.Night N.Not f) where
    decide :: (a -> Either b c)
-> Chain Night Not f b
-> Chain Night Not f c
-> Chain Night Not f a
decide f :: a -> Either b c
f x :: Chain Night Not f b
x y :: Chain Night Not f c
y = Night (Chain Night Not f) (Chain Night Not f) a
-> Chain Night Not f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Night (Chain Night Not f) (Chain Night Not f) a
 -> Chain Night Not f a)
-> Night (Chain Night Not f) (Chain Night Not f) a
-> Chain Night Not f a
forall a b. (a -> b) -> a -> b
$ Chain Night Not f b
-> Chain Night Not f c
-> (a -> Either b c)
-> Night (Chain Night Not f) (Chain Night Not f) a
forall (f :: * -> *) b (g :: * -> *) c a.
f b -> g c -> (a -> Either b c) -> Night f g a
N.Night Chain Night Not f b
x Chain Night Not f c
y a -> Either b c
f

-- | @'Chain' 'N.Night' 'N.Refutec'@ is the free "monoid in the monoidal
-- category of endofunctors enriched by 'N.Night'" --- aka, the free
-- 'Conclude'.
--
-- @since 0.3.0.0
instance Conclude (Chain N.Night N.Not f) where
    conclude :: (a -> Void) -> Chain Night Not f a
conclude = Not a -> Chain Night Not f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (Not a -> Chain Night Not f a)
-> ((a -> Void) -> Not a) -> (a -> Void) -> Chain Night Not f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Void) -> Not a
forall a. (a -> Void) -> Not a
N.Not

instance Apply (Chain Comp Identity f) where
    <.> :: Chain Comp Identity f (a -> b)
-> Chain Comp Identity f a -> Chain Comp Identity f b
(<.>) = Chain Comp Identity f (a -> b)
-> Chain Comp Identity f a -> Chain Comp Identity f b
forall (f :: * -> *) a b. Bind f => f (a -> b) -> f a -> f b
apDefault

instance Applicative (Chain Comp Identity f) where
    pure :: a -> Chain Comp Identity f a
pure  = Identity a -> Chain Comp Identity f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done (Identity a -> Chain Comp Identity f a)
-> (a -> Identity a) -> a -> Chain Comp Identity f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity a
forall a. a -> Identity a
Identity
    <*> :: Chain Comp Identity f (a -> b)
-> Chain Comp Identity f a -> Chain Comp Identity f b
(<*>) = Chain Comp Identity f (a -> b)
-> Chain Comp Identity f a -> Chain Comp Identity f b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>)

instance Bind (Chain Comp Identity f) where
    x :: Chain Comp Identity f a
x >>- :: Chain Comp Identity f a
-> (a -> Chain Comp Identity f b) -> Chain Comp Identity f b
>>- f :: a -> Chain Comp Identity f b
f = Comp (Chain Comp Identity f) (Chain Comp Identity f) b
-> Chain Comp Identity f b
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Chain Comp Identity f a
x Chain Comp Identity f a
-> (a -> Chain Comp Identity f b)
-> Comp (Chain Comp Identity f) (Chain Comp Identity f) b
forall k (f :: * -> *) (g :: k -> *) (a :: k) x.
f x -> (x -> g a) -> Comp f g a
:>>= a -> Chain Comp Identity f b
f)

-- | @'Chain' 'Comp' 'Identity'@ is the free "monoid in the monoidal
-- category of endofunctors enriched by 'Comp'" --- aka, the free
-- 'Monad'.
instance Monad (Chain Comp Identity f) where
    >>= :: Chain Comp Identity f a
-> (a -> Chain Comp Identity f b) -> Chain Comp Identity f b
(>>=) = Chain Comp Identity f a
-> (a -> Chain Comp Identity f b) -> Chain Comp Identity f b
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
(>>-)

instance Functor f => Alt (Chain (:*:) Proxy f) where
    x :: Chain (:*:) Proxy f a
x <!> :: Chain (:*:) Proxy f a
-> Chain (:*:) Proxy f a -> Chain (:*:) Proxy f a
<!> y :: Chain (:*:) Proxy f a
y = (:*:) (Chain (:*:) Proxy f) (Chain (:*:) Proxy f) a
-> Chain (:*:) Proxy f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Chain (:*:) Proxy f a
x Chain (:*:) Proxy f a
-> Chain (:*:) Proxy f a
-> (:*:) (Chain (:*:) Proxy f) (Chain (:*:) Proxy f) a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Chain (:*:) Proxy f a
y)

-- | @'Chain' (':*:') 'Proxy'@ is the free "monoid in the monoidal
-- category of endofunctors enriched by ':*:'" --- aka, the free
-- 'Plus'.
instance Functor f => Plus (Chain (:*:) Proxy f) where
    zero :: Chain (:*:) Proxy f a
zero = Proxy a -> Chain (:*:) Proxy f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done Proxy a
forall k (t :: k). Proxy t
Proxy

instance Functor f => Alt (Chain Product Proxy f) where
    x :: Chain Product Proxy f a
x <!> :: Chain Product Proxy f a
-> Chain Product Proxy f a -> Chain Product Proxy f a
<!> y :: Chain Product Proxy f a
y = Product (Chain Product Proxy f) (Chain Product Proxy f) a
-> Chain Product Proxy f a
forall (t :: (* -> *) -> (* -> *) -> * -> *) (i :: * -> *)
       (f :: * -> *).
Tensor t i =>
t (Chain t i f) (Chain t i f) ~> Chain t i f
appendChain (Chain Product Proxy f a
-> Chain Product Proxy f a
-> Product (Chain Product Proxy f) (Chain Product Proxy f) a
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair Chain Product Proxy f a
x Chain Product Proxy f a
y)

-- | @'Chain' (':*:') 'Proxy'@ is the free "monoid in the monoidal
-- category of endofunctors enriched by ':*:'" --- aka, the free
-- 'Plus'.
instance Functor f => Plus (Chain Product Proxy f) where
    zero :: Chain Product Proxy f a
zero = Proxy a -> Chain Product Proxy f a
forall k k (t :: k -> (k -> *) -> k -> *) (i :: k -> *) (f :: k)
       (a :: k).
i a -> Chain t i f a
Done Proxy a
forall k (t :: k). Proxy t
Proxy