functor-combinators 0.3.3.0 → 0.3.4.0

raw patch · 14 files changed

+2021/−1376 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• functor-combinators.cabal +7/−3
• src/Control/Natural/IsoF.hs +5/−0
• src/Data/Functor/Invariant/Day.hs +0/−506
• src/Data/Functor/Invariant/Day/Chain.hs +397/−0
• src/Data/Functor/Invariant/Night.hs +8/−323
• src/Data/Functor/Invariant/Night/Chain.hs +327/−0
• src/Data/HBifunctor/Associative.hs +44/−0
• src/Data/HBifunctor/Tensor.hs +64/−152
• src/Data/HBifunctor/Tensor/Internal.hs +241/−0
• src/Data/HFunctor/Chain.hs +4/−383
• src/Data/HFunctor/Chain/Internal.hs +406/−0
• src/Data/HFunctor/Internal.hs +20/−9
• src/Data/HFunctor/Route.hs +481/−0

@@ -1,6 +1,23 @@ Changelog ========= +Version 0.3.4.0+---------------++*August 14, 2020*++<https://github.com/mstksg/functor-combinators/releases/tag/v0.3.4.0>++*   *Data.HFunctor.Route*: A new twist on getting invariant functor+    combinators.  Instead of creating new ones, utilize existing functor+    combinators with `Pre`/`Post`.+*   *Data.Functor.Invariant.Day.Chain* and *Data.Functor.Invariant.Night.Chain*+    created, factoring out the `Chain` part of the invariant `Day`/`Night`.+    This was done to fix the fact that *Data.Functor.Invariant.Day* is a module+    that already existed in *kan-extensions*.  Oops!+    *   As a consequence, `DayChain` and `NightChain` are now newtype wrappers+        instead of plain type synonyms.+ Version 0.3.3.0 --------------- 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c410805d5e691767b93cffa33046c105029599cb34a0389840cbf00a85077538+-- hash: 86acf31904fa020637a382af8720e07d4f313ac5651b166963c268b0c7daf497  name:           functor-combinators-version:        0.3.3.0+version:        0.3.4.0 synopsis:       Tools for functor combinator-based program design description:    Tools for working with /functor combinators/: types that take functors (or                 other indexed types) and returns a new functor that "enhances" or "mixes"@@ -59,8 +59,9 @@       Data.Functor.Contravariant.Divise       Data.Functor.Contravariant.Divisible.Free       Data.Functor.Contravariant.Night-      Data.Functor.Invariant.Day+      Data.Functor.Invariant.Day.Chain       Data.Functor.Invariant.Night+      Data.Functor.Invariant.Night.Chain       Data.HBifunctor       Data.HBifunctor.Associative       Data.HBifunctor.Tensor@@ -68,8 +69,11 @@       Data.HFunctor.Chain       Data.HFunctor.Final       Data.HFunctor.Interpret+      Data.HFunctor.Route   other-modules:       Data.HFunctor.Internal+      Data.HFunctor.Chain.Internal+      Data.HBifunctor.Tensor.Internal   hs-source-dirs:       src   default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification ExplicitNamespaces FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings PatternSynonyms QuantifiedConstraints RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeInType TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns

@@ -13,11 +13,13 @@     type (~>)   , type (<~>)   , isoF+  , coercedF   , viewF, reviewF, overF   , fromF   ) where  import           Control.Natural+import           Data.Coerce import           Data.Kind import           Data.Profunctor import           Data.Tagged@@ -69,6 +71,9 @@     -> g ~> f     -> f <~> g isoF = dimap++coercedF :: (forall x. Coercible (f x) (g x), forall x. Coercible (g x) (f x)) => f <~> g+coercedF = isoF coerce coerce  -- | Use a '<~>' by retrieving the "forward" function: --

@@ -1,506 +0,0 @@---- |--- Module      : Data.Functor.Invariant.Day--- Copyright   : (c) Justin Le 2019--- License     : BSD3------ Maintainer  : justin@jle.im--- Stability   : experimental--- Portability : non-portable------ Provides an 'Invariant' version of the typical Haskell Day convolution--- over tuples.------ @since 0.3.0.0-module Data.Functor.Invariant.Day (-    Day(..)-  , day-  , runDayApply-  , runDayDivise-  , toCoDay-  , toContraDay-  , assoc, unassoc-  , intro1, intro2-  , elim1, elim2-  , swapped-  , trans1, trans2-  -- * Chain-  , DayChain-  , pattern Gather, pattern Knot-  , runCoDayChain-  , runContraDayChain-  , chainAp-  , chainDiv-  , assembleDayChain-  , assembleDayChainRec-  , concatDayChain-  , concatDayChainRec-  -- * Nonempty Chain-  , DayChain1-  , pattern DayChain1-  , runCoDayChain1-  , runContraDayChain1-  , chainAp1-  , chainDiv1-  , assembleDayChain1-  , assembleDayChain1Rec-  , concatDayChain1-  , concatDayChain1Rec-  ) where--import           Control.Applicative-import           Control.Applicative.Free                  (Ap)-import           Control.Natural-import           Control.Natural.IsoF-import           Data.Bifunctor-import           Data.Functor.Apply-import           Data.Functor.Apply.Free                   (Ap1)-import           Data.Functor.Contravariant.Divise-import           Data.Functor.Contravariant.Divisible-import           Data.Functor.Contravariant.Divisible.Free (Div, Div1)-import           Data.Functor.Identity-import           Data.Functor.Invariant-import           Data.HBifunctor-import           Data.HBifunctor.Associative hiding        (assoc)-import           Data.HBifunctor.Tensor hiding             (elim1, elim2, intro1, intro2)-import           Data.HFunctor-import           Data.HFunctor.Chain-import           Data.Kind-import           Data.SOP-import           GHC.Generics-import qualified Data.Bifunctor.Assoc                      as B-import qualified Data.Bifunctor.Swap                       as B-import qualified Data.Functor.Contravariant.Day            as CD-import qualified Data.Functor.Day                          as D-import qualified Data.HBifunctor.Tensor                    as T-import qualified Data.Vinyl                                as V-import qualified Data.Vinyl.Functor                        as V---- | A pairing of invariant functors to create a new invariant functor that--- represents the "combination" between the two.------ A @'Day' f g a@ is a invariant "consumer" and "producer" of @a@, and--- it does this by taking the @a@ and feeding it to both @f@ and @g@, and--- aggregating back the results.------ For example, if we have @x :: f a@ and @y :: g b@, then @'day' x y ::--- 'Day' f g (a, b)@.  This is a consumer/producer of @(a, b)@s, and it--- feeds the @a@ to @x@ and the @b@ to @y@, and tuples the results back--- together.------ Mathematically, this is a invariant day convolution along a tuple.-data Day :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) where-    Day :: f b-        -> g c-        -> (a -> (b, c))-        -> (b -> c -> a)-        -> Day f g a---- | Pair two invariant actions together in a way that tuples together--- their input/outputs.  The first one will take the 'fst' part of the--- tuple, and the second one will take the 'snd' part of the tuple.-day :: f a -> g b -> Day f g (a, b)-day x y = Day x y id (,)---- | Interpret the covariant part of a 'Day' into a target context @h@,--- as long as the context is an instance of 'Apply'.  The 'Apply' is used to--- combine results back together using '<*>'.-runDayApply-    :: forall f g h. Apply h-    => f ~> h-    -> g ~> h-    -> Day f g ~> h-runDayApply f g (Day x y _ j) = liftF2 j (f x) (g y)---- | Interpret the contravariant part of a 'Day' into a target context--- @h@, as long as the context is an instance of 'Divise'.  The 'Divise' is--- used to split up the input to pass to each of the actions.-runDayDivise-    :: forall f g h. Divise h-    => f ~> h-    -> g ~> h-    -> Day f g ~> h-runDayDivise f g (Day x y h _) = divise h (f x) (g y)---- | Convert an invariant 'Day' into the covariant version, dropping the--- contravariant part.-toCoDay :: Day f g ~> D.Day f g-toCoDay (Day x y _ g) = D.Day x y g---- | Convert an invariant 'Day' into the contravariant version, dropping--- the covariant part.-toContraDay :: Day f g ~> CD.Day f g-toContraDay (Day x y f _) = CD.Day x y f---- | 'Day' is associative.-assoc :: Day f (Day g h) ~> Day (Day f g) h-assoc (Day x (Day y z f g) h j) =-    Day (Day x y id (,)) z-      (B.unassoc . second f . h)-      (\(a,b) c -> j a (g b c))---- | 'Day' is associative.-unassoc :: Day (Day f g) h ~> Day f (Day g h)-unassoc (Day (Day x y f g) z h j) =-    Day x (Day y z id (,))-      (B.assoc . first f . h)-      (\a (b, c) -> j (g a b) c)---- | The left identity of 'Day' is 'Identity'; this is one side of that--- isomorphism.-intro1 :: g ~> Day Identity g-intro1 y = Day (Identity ()) y ((),) (const id)---- | The right identity of 'Day' is 'Identity'; this is one side of that--- isomorphism.-intro2 :: f ~> Day f Identity-intro2 x = Day x (Identity ()) (,()) const---- | The left identity of 'Day' is 'Identity'; this is one side of that--- isomorphism.-elim1 :: Invariant g => Day Identity g ~> g-elim1 (Day (Identity x) y f g) = invmap (g x) (snd . f) y---- | The right identity of 'Day' is 'Identity'; this is one side of that--- isomorphism.-elim2 :: Invariant f => Day f Identity ~> f-elim2 (Day x (Identity y) f g) = invmap (`g` y) (fst . f) x---- | The two sides of a 'Day' can be swapped.-swapped :: Day f g ~> Day g f-swapped (Day x y f g) = Day y x (B.swap . f) (flip g)---- | Hoist a function over the left side of a 'Day'.-trans1 :: f ~> h -> Day f g ~> Day h g-trans1 f (Day x y g h) = Day (f x) y g h---- | Hoist a function over the right side of a 'Day'.-trans2 :: g ~> h -> Day f g ~> Day f h-trans2 f (Day x y g h) = Day x (f y) g h---- | In the covariant direction, we can interpret out of a 'Chain1' of 'Day'--- into any 'Apply'.-runCoDayChain1-    :: forall f g. Apply g-    => f ~> g-    -> DayChain1 f ~> g-runCoDayChain1 f = foldChain1 f (runDayApply f id)---- | In the contravariant direction, we can interpret out of a 'Chain1' of--- 'Day' into any 'Divise'.-runContraDayChain1-    :: forall f g. Divise g-    => f ~> g-    -> DayChain1 f ~> g-runContraDayChain1 f = foldChain1 f (runDayDivise f id)---- | In the covariant direction, we can interpret out of a 'Chain' of 'Day'--- into any 'Applicative'.-runCoDayChain-    :: forall f g. Applicative g-    => f ~> g-    -> DayChain f ~> g-runCoDayChain f = foldChain (pure . runIdentity) $ \case-    Day x y _ h -> liftA2 h (f x) y---- | In the contravariant direction, we can interpret out of a 'Chain' of--- 'Day' into any 'Divisible'.-runContraDayChain-    :: forall f g. Divisible g-    => f ~> g-    -> DayChain f ~> g-runContraDayChain f = foldChain (const conquer) $ \case-    Day x y g _ -> divide g (f x) y---- | Extract the 'Ap' part out of a 'DayChain', shedding the--- contravariant bits.------ @since 0.3.2.0-chainAp :: DayChain f ~> Ap f-chainAp = runCoDayChain inject---- | Extract the 'Ap1' part out of a 'DayChain1', shedding the--- contravariant bits.------ @since 0.3.2.0-chainAp1 :: DayChain1 f ~> Ap1 f-chainAp1 = runCoDayChain1 inject---- | Extract the 'Div' part out of a 'DayChain', shedding the--- covariant bits.------ @since 0.3.2.0-chainDiv :: DayChain f ~> Div f-chainDiv = runContraDayChain inject---- | Extract the 'Div1' part out of a 'DayChain1', shedding the--- covariant bits.------ @since 0.3.2.0-chainDiv1 :: DayChain1 f ~> Div1 f-chainDiv1 = runContraDayChain1 inject---- | Instead of defining yet another separate free monoid like--- 'Control.Applicative.Free.Ap',--- 'Data.Functor.Contravariant.Divisible.Free.Div', or--- 'Data.Functor.Contravariant.Divisible.Free.Dec', we re-use 'Chain'.------ You can assemble values using the combinators in "Data.HFunctor.Chain",--- and then tear them down/interpret them using 'runCoDayChain' and--- 'runContraDayChain'.  There is no general invariant interpreter (and so no--- 'MonoidIn' instance for 'Day') because the typeclasses used to express--- the target contexts are probably not worth defining given how little the--- Haskell ecosystem uses invariant functors as an abstraction.-type DayChain  = Chain Day Identity---- | Match on a non-empty 'DayChain'; contains no @f@s, but only the--- terminal value.  Analogous to the 'Control.Applicative.Free.Ap'--- constructor.-pattern Gather :: (a -> (b, c)) -> (b -> c -> a) -> f b -> DayChain f c -> DayChain f a-pattern Gather f g x xs = More (Day x xs f g)---- | Match on an "empty" 'DayChain'; contains no @f@s, but only the--- terminal value.  Analogous to 'Control.Applicative.Free.Pure'.-pattern Knot :: a -> DayChain f a-pattern Knot x = Done (Identity x)-{-# COMPLETE Gather, Knot #-}---- | Match on a 'DayChain1' to get the head and the rest of the items.--- Analogous to the 'Data.Functor.Apply.Free.Ap1' constructor.-pattern DayChain1 :: Invariant f => (a -> (b, c)) -> (b -> c -> a) -> f b -> DayChain f c -> DayChain1 f a-pattern DayChain1 f g x xs <- (splitChain1->Day x xs f g)-  where-    DayChain1 f g x xs = unsplitNE $ Day x xs f g-{-# COMPLETE DayChain1 #-}---- | Instead of defining yet another separate free semigroup like--- 'Data.Functor.Apply.Free.Ap1',--- 'Data.Functor.Contravariant.Divisible.Free.Div1', or--- 'Data.Functor.Contravariant.Divisible.Free.Dec1', we re-use 'Chain1'.------ You can assemble values using the combinators in "Data.HFunctor.Chain",--- and then tear them down/interpret them using 'runCoDayChain1' and--- 'runContraDayChain1'.  There is no general invariant interpreter (and so no--- 'SemigroupIn' instance for 'Day') because the typeclasses used to--- express the target contexts are probably not worth defining given how--- little the Haskell ecosystem uses invariant functors as an abstraction.-type DayChain1 = Chain1 Day--instance Invariant (Day f g) where-    invmap f g (Day x y h j) = Day x y (h . g) (\q -> f . j q)--instance HFunctor (Day f) where-    hmap f = hbimap id f--instance HBifunctor Day where-    hbimap f g (Day x y h j) = Day (f x) (g y) h j--instance Associative Day where-    type NonEmptyBy Day = DayChain1-    type FunctorBy Day = Invariant-    associating = isoF assoc unassoc--    appendNE (Day xs ys f g) = case xs of-      Done1 x              -> More1 (Day x ys f g)-      More1 (Day z zs h j) -> More1 $-        Day z (appendNE (Day zs ys id (,)))-          (B.assoc . first h . f)-          (\a (b, c) -> g (j a b) c)-    matchNE = matchChain1--    consNE = More1-    toNonEmptyBy = toChain1--instance Tensor Day Identity where-    type ListBy Day = DayChain--    intro1 = intro2-    intro2 = intro1-    elim1 = elim2-    elim2 = elim1--    appendLB = appendChain-    splitNE = splitChain1-    splittingLB = splittingChain--    toListBy = toChain--instance Matchable Day Identity where-    unsplitNE (Day x xs f g) = case xs of-      Done (Identity r) -> Done1 $ invmap (`g` r) (fst . f) x-      More ys           -> More1 $ Day x (unsplitNE ys) f g-    matchLB = \case-      Done x  -> L1 x-      More xs -> R1 $ unsplitNE xs---- | Convenient wrapper to build up a 'DayChain' by providing each--- component of it.  This makes it much easier to build up longer chains--- because you would only need to write the splitting/joining functions in--- one place.------ For example, if you had a data type------ @--- data MyType = MT Int Bool String--- @------ and an invariant functor @Prim@ (representing, say, a bidirectional--- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@),--- then you could assemble a bidirectional parser for a @MyType@ using:------ @--- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil)---        (\(I x :* I y :* I z :* Nil) -> MyType x y z) $---   assembleDayChain $ intPrim---                   :* boolPrim---                   :* stringPrim---                   :* Nil--- @------ Some notes on usefulness depending on how many components you have:------ *    If you have 0 components, use 'Knot' directly.--- *    If you have 1 component, use 'inject' or 'injectChain' directly.--- *    If you have 2 components, use 'toListBy' or 'toChain'.--- *    If you have 3 or more components, these combinators may be useful;---      otherwise you'd need to manually peel off tuples one-by-one.-assembleDayChain-    :: NP f as-    -> DayChain f (NP I as)-assembleDayChain = \case-    Nil     -> Done $ Identity Nil-    x :* xs -> More $ Day-      x-      (assembleDayChain xs)-      unconsNPI-      consNPI---- | A version of 'assembleDayChain' where each component is itself--- a 'DayChain'.------ @--- assembleDayChain (x :* y :* z :* Nil)---   = concatDayChain (injectChain x :* injectChain y :* injectChain z :* Nil)--- @-concatDayChain-    :: NP (DayChain f) as-    -> DayChain f (NP I as)-concatDayChain = \case-    Nil     -> Done $ Identity Nil-    x :* xs -> appendChain $ Day-      x-      (concatDayChain xs)-      unconsNPI-      consNPI---- | A version of 'assembleDayChain' but for 'DayChain1' instead.  Can be--- useful if you intend on interpreting it into something with only--- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'.-assembleDayChain1-    :: Invariant f-    => NP f (a ': as)-    -> DayChain1 f (NP I (a ': as))-assembleDayChain1 = \case-    x :* xs -> case xs of-      Nil    -> Done1 $ invmap ((:* Nil) . I) (unI . hd) x-      _ :* _ -> More1 $ Day-        x-        (assembleDayChain1 xs)-        unconsNPI-        consNPI---- | A version of 'concatDayChain' but for 'DayChain1' instead.  Can be--- useful if you intend on interpreting it into something with only--- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'.-concatDayChain1-    :: Invariant f-    => NP (DayChain1 f) (a ': as)-    -> DayChain1 f (NP I (a ': as))-concatDayChain1 = \case-    x :* xs -> case xs of-      Nil    -> invmap ((:* Nil) . I) (unI . hd) x-      _ :* _ -> appendChain1 $ Day-        x-        (concatDayChain1 xs)-        unconsNPI-        consNPI--unconsNPI :: NP I (a ': as) -> (a, NP I as)-unconsNPI (I y :* ys) = (y, ys)--consNPI :: a -> NP I as -> NP I (a ': as)-consNPI y ys = I y :* ys---- | A version of 'assembleDayChain' using 'V.XRec' from /vinyl/ instead of--- 'NP' from /sop-core/.  This can be more convenient because it doesn't--- require manual unwrapping/wrapping of components.------ @--- data MyType = MT Int Bool String------ invmap (\(MyType x y z) -> x ::& y ::& z ::& RNil)---        (\(x ::& y ::& z ::& RNil) -> MyType x y z) $---   assembleDayChainRec $ intPrim---                      :& boolPrim---                      :& stringPrim---                      :& Nil--- @-assembleDayChainRec-    :: V.Rec f as-    -> DayChain f (V.XRec V.Identity as)-assembleDayChainRec = \case-    V.RNil    -> Done $ Identity V.RNil-    x V.:& xs -> More $ Day-      x-      (assembleDayChainRec xs)-      unconsRec-      (V.::&)---- | A version of 'concatDayChain' using 'V.XRec' from /vinyl/ instead of--- 'NP' from /sop-core/.  This can be more convenient because it doesn't--- require manual unwrapping/wrapping of components.-concatDayChainRec-    :: V.Rec (DayChain f) as-    -> DayChain f (V.XRec V.Identity as)-concatDayChainRec = \case-    V.RNil    -> Done $ Identity V.RNil-    x V.:& xs -> appendChain $ Day-      x-      (concatDayChainRec xs)-      unconsRec-      (V.::&)---- | A version of 'assembleDayChain1' using 'V.XRec' from /vinyl/ instead of--- 'NP' from /sop-core/.  This can be more convenient because it doesn't--- require manual unwrapping/wrapping of components.-assembleDayChain1Rec-    :: Invariant f-    => V.Rec f (a ': as)-    -> DayChain1 f (V.XRec V.Identity (a ': as))-assembleDayChain1Rec = \case-    x V.:& xs -> case xs of-      V.RNil   -> Done1 $ invmap (V.::& V.RNil) (\case z V.::& _ -> z) x-      _ V.:& _ -> More1 $ Day-        x-        (assembleDayChain1Rec xs)-        unconsRec-        (V.::&)---- | A version of 'concatDayChain1' using 'V.XRec' from /vinyl/ instead of--- 'NP' from /sop-core/.  This can be more convenient because it doesn't--- require manual unwrapping/wrapping of components.-concatDayChain1Rec-    :: Invariant f-    => V.Rec (DayChain1 f) (a ': as)-    -> DayChain1 f (V.XRec V.Identity (a ': as))-concatDayChain1Rec = \case-    x V.:& xs -> case xs of-      V.RNil   -> invmap (V.::& V.RNil) (\case z V.::& _ -> z) x-      _ V.:& _ -> appendChain1 $ Day-        x-        (concatDayChain1Rec xs)-        unconsRec-        (V.::&)--unconsRec :: V.XRec V.Identity (a ': as) -> (a, V.XRec V.Identity as)-unconsRec (y V.::& ys) = (y, ys)

@@ -0,0 +1,397 @@++-- |+-- Module      : Data.Functor.Invariant.Day+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- Provides an 'Invariant' version of the typical Haskell Day convolution+-- over tuples.+--+-- @since 0.3.0.0+module Data.Functor.Invariant.Day.Chain (+  -- * Chain+    DayChain(.., Gather, Knot)+  , runCoDayChain+  , runContraDayChain+  , chainAp+  , chainDiv+  , gather, gathered+  , assembleDayChain+  , assembleDayChainRec+  , concatDayChain+  , concatDayChainRec+  -- * Nonempty Chain+  , DayChain1(.., DayChain1)+  , runCoDayChain1+  , runContraDayChain1+  , chainAp1+  , chainDiv1+  , gather1, gathered1+  , assembleDayChain1+  , assembleDayChain1Rec+  , concatDayChain1+  , concatDayChain1Rec+  -- * Day Utility+  , runDayApply+  , runDayDivise+  ) where++import           Control.Applicative+import           Control.Applicative.Free                  (Ap(..))+import           Control.Applicative.ListF                 (MaybeF(..))+import           Control.Natural+import           Data.Coerce+import           Data.Functor.Apply+import           Data.Functor.Apply.Free (Ap1(..))+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Contravariant.Divisible.Free (Div(..), Div1)+import           Data.Functor.Identity+import           Data.Functor.Invariant+import           Data.Functor.Invariant.Day+import           Data.HBifunctor.Tensor hiding             (elim1, elim2, intro1, intro2)+import           Data.HFunctor+import           Data.HFunctor.Chain+import           Data.HFunctor.Chain.Internal+import           Data.SOP hiding                           (hmap)+import qualified Data.Vinyl                                as V+import qualified Data.Vinyl.Functor                        as V++-- | Interpret the covariant part of a 'Day' into a target context @h@,+-- as long as the context is an instance of 'Apply'.  The 'Apply' is used to+-- combine results back together using '<*>'.+runDayApply+    :: forall f g h. Apply h+    => f ~> h+    -> g ~> h+    -> Day f g ~> h+runDayApply f g (Day x y j _) = liftF2 j (f x) (g y)++-- | Interpret the contravariant part of a 'Day' into a target context+-- @h@, as long as the context is an instance of 'Divise'.  The 'Divise' is+-- used to split up the input to pass to each of the actions.+runDayDivise+    :: forall f g h. Divise h+    => f ~> h+    -> g ~> h+    -> Day f g ~> h+runDayDivise f g (Day x y _ h) = divise h (f x) (g y)++-- | In the covariant direction, we can interpret out of a 'Chain1' of 'Day'+-- into any 'Apply'.+runCoDayChain1+    :: forall f g. Apply g+    => f ~> g+    -> DayChain1 f ~> g+runCoDayChain1 f = foldChain1 f (runDayApply f id) . unDayChain1++-- | In the contravariant direction, we can interpret out of a 'Chain1' of+-- 'Day' into any 'Divise'.+runContraDayChain1+    :: forall f g. Divise g+    => f ~> g+    -> DayChain1 f ~> g+runContraDayChain1 f = foldChain1 f (runDayDivise f id) . unDayChain1++-- | In the covariant direction, we can interpret out of a 'Chain' of 'Day'+-- into any 'Applicative'.+runCoDayChain+    :: forall f g. Applicative g+    => f ~> g+    -> DayChain f ~> g+runCoDayChain f = foldChain (pure . runIdentity) (\case Day x y h _ -> liftA2 h (f x) y)+                . unDayChain++-- | In the contravariant direction, we can interpret out of a 'Chain' of+-- 'Day' into any 'Divisible'.+runContraDayChain+    :: forall f g. Divisible g+    => f ~> g+    -> DayChain f ~> g+runContraDayChain f = foldChain (const conquer) (\case Day x y _ g -> divide g (f x) y)+                    . unDayChain++-- | Extract the 'Ap' part out of a 'DayChain', shedding the+-- contravariant bits.+--+-- @since 0.3.2.0+chainAp :: DayChain f ~> Ap f+chainAp = runCoDayChain inject++-- | Extract the 'Ap1' part out of a 'DayChain1', shedding the+-- contravariant bits.+--+-- @since 0.3.2.0+chainAp1 :: DayChain1 f ~> Ap1 f+chainAp1 = runCoDayChain1 inject++-- | Extract the 'Div' part out of a 'DayChain', shedding the+-- covariant bits.+--+-- @since 0.3.2.0+chainDiv :: DayChain f ~> Div f+chainDiv = runContraDayChain inject++-- | Extract the 'Div1' part out of a 'DayChain1', shedding the+-- covariant bits.+--+-- @since 0.3.2.0+chainDiv1 :: DayChain1 f ~> Div1 f+chainDiv1 = runContraDayChain1 inject++-- | Match on a non-empty 'DayChain'; contains no @f@s, but only the+-- terminal value.  Analogous to the 'Control.Applicative.Free.Ap'+-- constructor.+pattern Gather :: (a -> (b, c)) -> (b -> c -> a) -> f b -> DayChain f c -> DayChain f a+pattern Gather f g x xs <- (unGather_->MaybeF (Just (Day x xs g f)))+  where+    Gather f g x xs = DayChain $ More $ Day x (unDayChain xs) g f++unGather_ :: DayChain f ~> MaybeF (Day f (DayChain f))+unGather_ = \case+  DayChain (More (Day x xs g f)) -> MaybeF . Just $ Day x (DayChain xs) g f+  DayChain (Done _             ) -> MaybeF Nothing++-- | Match on an "empty" 'DayChain'; contains no @f@s, but only the+-- terminal value.  Analogous to 'Control.Applicative.Free.Pure'.+pattern Knot :: a -> DayChain f a+pattern Knot x = DayChain (Done (Identity x))+{-# COMPLETE Gather, Knot #-}++-- | Match on a 'DayChain1' to get the head and the rest of the items.+-- Analogous to the 'Data.Functor.Apply.Free.Ap1' constructor.+pattern DayChain1 :: Invariant f => (a -> (b, c)) -> (b -> c -> a) -> f b -> DayChain f c -> DayChain1 f a+pattern DayChain1 f g x xs <- (coerce splitChain1->Day x xs g f)+  where+    DayChain1 f g x xs = unsplitNE $ Day x xs g f+{-# COMPLETE DayChain1 #-}++-- | Invariantly combine two 'DayChain's.+--+-- Analogous to 'liftA2' and 'divise'.  If there was some typeclass that+-- represented semigroups on invariant 'Day', this would be the method of+-- that typeclass.+--+-- The identity of this is 'Knot'.+--+-- @since 0.3.4.0+gather+    :: (a -> (b, c))+    -> (b -> c -> a)+    -> DayChain f b+    -> DayChain f c+    -> DayChain f a+gather f g x y = coerce appendChain (Day x y g f)++-- | Convenient wrapper over 'gather' that simply combines the two options+-- in a tuple.  Analogous to 'divised'.+--+-- @since 0.3.4.0+gathered+    :: DayChain f a+    -> DayChain f b+    -> DayChain f (a, b)+gathered = gather id (,)++-- | Invariantly combine two 'DayChain1's.+--+-- Analogous to 'liftA2' and 'divise'.  If there was some typeclass that+-- represented semigroups on invariant 'Day', this would be the method of+-- that typeclass.+--+-- @since 0.3.4.0+gather1+    :: Invariant f+    => (a -> (b, c))+    -> (b -> c -> a)+    -> DayChain1 f b+    -> DayChain1 f c+    -> DayChain1 f a+gather1 f g x y = coerce appendChain1 (Day x y g f)++-- | Convenient wrapper over 'gather1' that simply combines the two options+-- in a tuple.  Analogous to 'divised'.+--+-- @since 0.3.4.0+gathered1+    :: Invariant f+    => DayChain1 f a+    -> DayChain1 f b+    -> DayChain1 f (a, b)+gathered1 = gather1 id (,)++-- | Convenient wrapper to build up a 'DayChain' by providing each+-- component of it.  This makes it much easier to build up longer chains+-- because you would only need to write the splitting/joining functions in+-- one place.+--+-- For example, if you had a data type+--+-- @+-- data MyType = MT Int Bool String+-- @+--+-- and an invariant functor @Prim@ (representing, say, a bidirectional+-- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@),+-- then you could assemble a bidirectional parser for a @MyType@ using:+--+-- @+-- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil)+--        (\(I x :* I y :* I z :* Nil) -> MyType x y z) $+--   assembleDayChain $ intPrim+--                   :* boolPrim+--                   :* stringPrim+--                   :* Nil+-- @+--+-- Some notes on usefulness depending on how many components you have:+--+-- *    If you have 0 components, use 'Knot' directly.+-- *    If you have 1 component, use 'inject' or 'injectChain' directly.+-- *    If you have 2 components, use 'toListBy' or 'toChain'.+-- *    If you have 3 or more components, these combinators may be useful;+--      otherwise you'd need to manually peel off tuples one-by-one.+assembleDayChain+    :: NP f as+    -> DayChain f (NP I as)+assembleDayChain = \case+    Nil     -> DayChain $ Done $ Identity Nil+    x :* xs -> DayChain $ More $ Day+      x+      (unDayChain (assembleDayChain xs))+      consNPI+      unconsNPI++-- | A version of 'assembleDayChain' where each component is itself+-- a 'DayChain'.+--+-- @+-- assembleDayChain (x :* y :* z :* Nil)+--   = concatDayChain (injectChain x :* injectChain y :* injectChain z :* Nil)+-- @+concatDayChain+    :: NP (DayChain f) as+    -> DayChain f (NP I as)+concatDayChain = \case+    Nil     -> DayChain $ Done $ Identity Nil+    x :* xs -> coerce appendChain $ Day+      x+      (concatDayChain xs)+      consNPI+      unconsNPI++-- | A version of 'assembleDayChain' but for 'DayChain1' instead.  Can be+-- useful if you intend on interpreting it into something with only+-- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'.+assembleDayChain1+    :: Invariant f+    => NP f (a ': as)+    -> DayChain1 f (NP I (a ': as))+assembleDayChain1 = \case+    x :* xs -> DayChain1_ $ case xs of+      Nil    -> Done1 $ invmap ((:* Nil) . I) (unI . hd) x+      _ :* _ -> More1 $ Day+        x+        (unDayChain1 (assembleDayChain1 xs))+        consNPI+        unconsNPI++-- | A version of 'concatDayChain' but for 'DayChain1' instead.  Can be+-- useful if you intend on interpreting it into something with only+-- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'.+concatDayChain1+    :: Invariant f+    => NP (DayChain1 f) (a ': as)+    -> DayChain1 f (NP I (a ': as))+concatDayChain1 = \case+    x :* xs -> case xs of+      Nil    -> invmap ((:* Nil) . I) (unI . hd) x+      _ :* _ -> coerce appendChain1 $ Day+        x+        (concatDayChain1 xs)+        consNPI+        unconsNPI++unconsNPI :: NP I (a ': as) -> (a, NP I as)+unconsNPI (I y :* ys) = (y, ys)++consNPI :: a -> NP I as -> NP I (a ': as)+consNPI y ys = I y :* ys++-- | A version of 'assembleDayChain' using 'V.XRec' from /vinyl/ instead of+-- 'NP' from /sop-core/.  This can be more convenient because it doesn't+-- require manual unwrapping/wrapping of components.+--+-- @+-- data MyType = MT Int Bool String+--+-- invmap (\(MyType x y z) -> x ::& y ::& z ::& RNil)+--        (\(x ::& y ::& z ::& RNil) -> MyType x y z) $+--   assembleDayChainRec $ intPrim+--                      :& boolPrim+--                      :& stringPrim+--                      :& Nil+-- @+assembleDayChainRec+    :: V.Rec f as+    -> DayChain f (V.XRec V.Identity as)+assembleDayChainRec = \case+    V.RNil    -> DayChain $ Done $ Identity V.RNil+    x V.:& xs -> DayChain $ More $ Day+      x+      (unDayChain (assembleDayChainRec xs))+      (V.::&)+      unconsRec++-- | A version of 'concatDayChain' using 'V.XRec' from /vinyl/ instead of+-- 'NP' from /sop-core/.  This can be more convenient because it doesn't+-- require manual unwrapping/wrapping of components.+concatDayChainRec+    :: V.Rec (DayChain f) as+    -> DayChain f (V.XRec V.Identity as)+concatDayChainRec = \case+    V.RNil    -> DayChain $ Done $ Identity V.RNil+    x V.:& xs -> coerce appendChain $ Day+      x+      (concatDayChainRec xs)+      (V.::&)+      unconsRec++-- | A version of 'assembleDayChain1' using 'V.XRec' from /vinyl/ instead of+-- 'NP' from /sop-core/.  This can be more convenient because it doesn't+-- require manual unwrapping/wrapping of components.+assembleDayChain1Rec+    :: Invariant f+    => V.Rec f (a ': as)+    -> DayChain1 f (V.XRec V.Identity (a ': as))+assembleDayChain1Rec = \case+    x V.:& xs -> case xs of+      V.RNil   -> DayChain1_ $ Done1 $ invmap (V.::& V.RNil) (\case z V.::& _ -> z) x+      _ V.:& _ -> DayChain1_ $ More1 $ Day+        x+        (unDayChain1 (assembleDayChain1Rec xs))+        (V.::&)+        unconsRec++-- | A version of 'concatDayChain1' using 'V.XRec' from /vinyl/ instead of+-- 'NP' from /sop-core/.  This can be more convenient because it doesn't+-- require manual unwrapping/wrapping of components.+concatDayChain1Rec+    :: Invariant f+    => V.Rec (DayChain1 f) (a ': as)+    -> DayChain1 f (V.XRec V.Identity (a ': as))+concatDayChain1Rec = \case+    x V.:& xs -> case xs of+      V.RNil   -> invmap (V.::& V.RNil) (\case z V.::& _ -> z) x+      _ V.:& _ -> coerce appendChain1 $ Day+        x+        (concatDayChain1Rec xs)+        (V.::&)+        unconsRec++unconsRec :: V.XRec V.Identity (a ': as) -> (a, V.XRec V.Identity as)+unconsRec (y V.::& ys) = (y, ys)

@@ -25,55 +25,21 @@   , elim1, elim2   , swapped   , trans1, trans2-  -- * Chain-  , NightChain-  , pattern Swerve, pattern Reject-  , runCoNightChain-  , runContraNightChain-  , chainListF-  , chainListF_-  , chainDec-  , assembleNightChain-  , concatNightChain-  -- * Nonempty Chain-  , NightChain1-  , pattern NightChain1-  , runCoNightChain1-  , runContraNightChain1-  , chainNonEmptyF-  , chainNonEmptyF_-  , chainDec1-  , assembleNightChain1-  , concatNightChain1   ) where -import           Control.Applicative.ListF import           Control.Natural-import           Control.Natural.IsoF import           Data.Bifunctor import           Data.Functor.Alt-import           Data.Functor.Contravariant.Conclude import           Data.Functor.Contravariant.Decide-import           Data.Functor.Contravariant.Divisible.Free-import           Data.Functor.Contravariant.Night          (Not(..), refuted)+import           Data.Functor.Contravariant.Night  (Not(..), refuted) import           Data.Functor.Invariant-import           Data.Functor.Plus-import           Data.HBifunctor-import           Data.HBifunctor.Associative hiding        (assoc)-import           Data.HBifunctor.Tensor hiding             (elim1, elim2, intro1, intro2)-import           Data.HFunctor-import           Data.HFunctor.Chain import           Data.Kind-import           Data.SOP import           Data.Void import           GHC.Generics-import qualified Control.Monad.Trans.Compose               as CT-import qualified Data.Bifunctor.Assoc                      as B-import qualified Data.Bifunctor.Swap                       as B-import qualified Data.Functor.Contravariant.Night          as CN-import qualified Data.Functor.Coyoneda                     as CY-import qualified Data.HBifunctor.Tensor                    as T-import qualified Data.List.NonEmpty                        as NE+import qualified Data.Bifunctor.Assoc              as B+import qualified Data.Bifunctor.Swap               as B+import qualified Data.Functor.Contravariant.Night  as CN+import qualified Data.Functor.Coyoneda             as CY  -- | A pairing of invariant functors to create a new invariant functor that -- represents the "choice" between the two.@@ -102,6 +68,9 @@           -> (c -> a)           -> Night f g a +instance Invariant (Night f g) where+    invmap f g (Night x y h j k) = Night x y (h . g) (f . j) (f . k)+ -- | Pair two invariant actions together into a 'Night'; assigns the first -- one to 'Left' inputs and outputs and the second one to 'Right' inputs -- and outputs.@@ -202,287 +171,3 @@ trans2 :: g ~> h -> Night f g ~> Night f h trans2 f (Night x y g h j) = Night x (f y) g h j --- | In the covariant direction, we can interpret out of a 'Chain1' of 'Night'--- into any 'Alt'.-runCoNightChain1-    :: forall f g. Alt g-    => f ~> g-    -> NightChain1 f ~> g-runCoNightChain1 f = foldChain1 f (runNightAlt f id)---- | In the contravariant direction, we can interpret out of a 'Chain1' of--- 'Night' into any 'Decide'.-runContraNightChain1-    :: forall f g. Decide g-    => f ~> g-    -> NightChain1 f ~> g-runContraNightChain1 f = foldChain1 f (runNightDecide f id)---- | Extract the 'Dec' part out of a 'NightChain', shedding the--- covariant bits.-chainDec :: NightChain f ~> Dec f-chainDec = runContraNightChain inject---- | Extract the 'Dec1' part out of a 'NightChain1', shedding the--- covariant bits.-chainDec1 :: NightChain1 f ~> Dec1 f-chainDec1 = runContraNightChain1 inject---- | In the covariant direction, we can interpret out of a 'Chain' of 'Night'--- into any 'Plus'.-runCoNightChain-    :: forall f g. Plus g-    => f ~> g-    -> NightChain f ~> g-runCoNightChain f = foldChain (const zero) (runNightAlt f id)---- | In the contravariant direction, we can interpret out of a 'Chain' of--- 'Night' into any 'Conclude'.-runContraNightChain-    :: forall f g. Conclude g-    => f ~> g-    -> NightChain f ~> g-runContraNightChain f = foldChain (conclude . refute) (runNightDecide f id)---- | Extract the 'ListF' part out of a 'NightChain', shedding the--- contravariant bits.------ @since 0.3.2.0-chainListF :: Functor f => NightChain f ~> ListF f-chainListF = runCoNightChain inject---- | Extract the 'ListF' part out of a 'NightChain', shedding the--- contravariant bits.------ This version does not require a 'Functor' constraint because it converts--- to the coyoneda-wrapped product, which is more accurately the true--- conversion to a covariant chain.------ @since 0.3.2.0-chainListF_ :: NightChain f ~> CT.ComposeT ListF CY.Coyoneda f-chainListF_ = foldChain (const (CT.ComposeT (ListF []))) $ \case-    Night x (CT.ComposeT (ListF xs)) _ f g -> CT.ComposeT . ListF $-      CY.Coyoneda f x : (map . fmap) g xs---- | Extract the 'NonEmptyF' part out of a 'NightChain1', shedding the--- contravariant bits.------ @since 0.3.2.0-chainNonEmptyF :: Functor f => NightChain1 f ~> NonEmptyF f-chainNonEmptyF = runCoNightChain1 inject---- | Extract the 'NonEmptyF' part out of a 'NightChain1', shedding the--- contravariant bits.------ This version does not require a 'Functor' constraint because it converts--- to the coyoneda-wrapped product, which is more accurately the true--- conversion to a covariant chain.------ @since 0.3.2.0-chainNonEmptyF_ :: NightChain1 f ~> CT.ComposeT NonEmptyF CY.Coyoneda f-chainNonEmptyF_ = foldChain1 inject $ \case-    Night x (CT.ComposeT (NonEmptyF xs)) _ f g -> CT.ComposeT . NonEmptyF $-      CY.Coyoneda f x NE.<| (fmap . fmap) g xs----- | Instead of defining yet another separate free monoid like--- 'Control.Applicative.Free.Ap',--- 'Data.Functor.Contravariant.Divisible.Free.Div', or--- 'Data.Functor.Contravariant.Divisible.Free.Dec', we re-use 'Chain'.------ You can assemble values using the combinators in "Data.HFunctor.Chain",--- and then tear them down/interpret them using 'runCoNightChain' and--- 'runContraNightChain'.  There is no general invariant interpreter (and so no--- 'MonoidIn' instance for 'Night') because the typeclasses used to express--- the target contexts are probably not worth defining given how little the--- Haskell ecosystem uses invariant functors as an abstraction.-type NightChain  = Chain Night Not---- | Instead of defining yet another separate free semigroup like--- 'Data.Functor.Apply.Free.Ap1',--- 'Data.Functor.Contravariant.Divisible.Free.Div1', or--- 'Data.Functor.Contravariant.Divisible.Free.Dec1', we re-use 'Chain1'.------ You can assemble values using the combinators in "Data.HFunctor.Chain",--- and then tear them down/interpret them using 'runCoNightChain1' and--- 'runContraNightChain1'.  There is no general invariant interpreter (and so no--- 'SemigroupIn' instance for 'Night') because the typeclasses used to--- express the target contexts are probably not worth defining given how--- little the Haskell ecosystem uses invariant functors as an abstraction.-type NightChain1 = Chain1 Night---- | Match on a non-empty 'NightChain'; contains the splitting function,--- the two rejoining functions, the first @f@, and the rest of the chain.--- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Choose'--- constructor.-pattern Swerve :: (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> NightChain f c -> NightChain f a-pattern Swerve f g h x xs = More (Night x xs f g h)---- | Match on an "empty" 'NightChain'; contains no @f@s, but only the--- terminal value.  Analogous to the--- 'Data.Functor.Contravariant.Divisible.Free.Lose' constructor.-pattern Reject :: (a -> Void) -> NightChain f a-pattern Reject x = Done (Not x)-{-# COMPLETE Swerve, Reject #-}---- | Match on a 'NightChain1' to get the head and the rest of the items.--- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Dec1'--- constructor.-pattern NightChain1 :: Invariant f => (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> NightChain f c -> NightChain1 f a-pattern NightChain1 f g h x xs <- (splitChain1->Night x xs f g h)-  where-    NightChain1 f g h x xs = unsplitNE $ Night x xs f g h-{-# COMPLETE NightChain1 #-}--instance Invariant (Night f g) where-    invmap f g (Night x y h j k) = Night x y (h . g) (f . j) (f . k)--instance HFunctor (Night f) where-    hmap f = hbimap id f--instance HBifunctor Night where-    hbimap f g (Night x y h j k) = Night (f x) (g y) h j k--instance Associative Night where-    type NonEmptyBy Night = NightChain1-    type FunctorBy Night = Invariant-    associating = isoF assoc unassoc--    appendNE (Night xs ys f g h) = case xs of-      Done1 x                  -> More1 (Night x ys f g h)-      More1 (Night z zs j k l) -> More1 $-        Night z (appendNE (Night zs ys id Left Right))-          (B.assoc . first j . f)-          (g . k)-          (either (g . l) h)-    matchNE = matchChain1--    consNE = More1-    toNonEmptyBy = toChain1--instance Tensor Night Not where-    type ListBy Night = NightChain--    intro1 = intro2-    intro2 = intro1-    elim1 = elim2-    elim2 = elim1--    appendLB = appendChain-    splitNE = splitChain1-    splittingLB = splittingChain--    toListBy = toChain--instance Matchable Night Not where-    unsplitNE (Night x xs f g h) = case xs of-      Done r  -> Done1 $ invmap g (either id (absurd . refute r) . f) x-      More ys -> More1 $ Night x (unsplitNE ys) f g h-    matchLB = \case-      Done x  -> L1 x-      More xs -> R1 $ unsplitNE xs---- | Convenient wrapper to build up a 'NightChain' on by providing each--- component of it.  This makes it much easier to build up longer chains--- because you would only need to write the splitting/joining functions in--- one place.------ For example, if you had a data type------ @--- data MyType = MTI Int | MTB Bool | MTS String--- @------ and an invariant functor @Prim@ (representing, say, a bidirectional--- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@),--- then you could assemble a bidirectional parser for a @MyType@ using:------ @--- invmap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z))))---        (\case Z (I x) -> MTI x; S (Z (I y)) -> MTB y; S (S (Z (I z))) -> MTS z) $---   assembleNightChain $ intPrim---                     :* boolPrim---                     :* stringPrim---                     :* Nil--- @------ Some notes on usefulness depending on how many components you have:------ *    If you have 0 components, use 'Reject' directly.--- *    If you have 1 component, use 'inject' or 'injectChain' directly.--- *    If you have 2 components, use 'toListBy' or 'toChain'.--- *    If you have 3 or more components, these combinators may be useful;---      otherwise you'd need to manually peel off eithers one-by-one.-assembleNightChain-    :: NP f as-    -> NightChain f (NS I as)-assembleNightChain = \case-    Nil     -> Done $ Not (\case {})-    x :* xs -> More $ Night-      x-      (assembleNightChain xs)-      unconsNSI-      (Z . I)-      S---- | A version of 'assembleNightChain' where each component is itself--- a 'NightChain'.------ @--- assembleNightChain (x :* y :* z :* Nil)---   = concatNightChain (injectChain x :* injectChain y :* injectChain z :* Nil)--- @-concatNightChain-    :: NP (NightChain f) as-    -> NightChain f (NS I as)-concatNightChain = \case-    Nil     -> Done $ Not (\case {})-    x :* xs -> appendChain $ Night-      x-      (concatNightChain xs)-      unconsNSI-      (Z . I)-      S---- | A version of 'assembleNightChain' but for 'NightChain1' instead.  Can--- be useful if you intend on interpreting it into something with only--- a 'Decide' or 'Alt' instance, but no--- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or--- 'Control.Applicative.Alternative'.-assembleNightChain1-    :: Invariant f-    => NP f (a ': as)-    -> NightChain1 f (NS I (a ': as))-assembleNightChain1 = \case-    x :* xs -> case xs of-      Nil    -> Done1 $ invmap (Z . I) (unI . unZ) x-      _ :* _ -> More1 $ Night-        x-        (assembleNightChain1 xs)-        unconsNSI-        (Z . I)-        S---- | A version of 'concatNightChain' but for 'NightChain1' instead.  Can be--- useful if you intend on interpreting it into something with only--- a 'Decide' or 'Alt' instance, but no--- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or--- 'Control.Applicative.Alternative'.-concatNightChain1-    :: Invariant f-    => NP (NightChain1 f) (a ': as)-    -> NightChain1 f (NS I (a ': as))-concatNightChain1 = \case-    x :* xs -> case xs of-      Nil    -> invmap (Z . I) (unI . unZ) x-      _ :* _ -> appendChain1 $ Night-        x-        (concatNightChain1 xs)-        unconsNSI-        (Z . I)-        S--unconsNSI :: NS I (a ': as) -> Either a (NS I as)-unconsNSI = \case-  Z (I x) -> Left x-  S xs    -> Right xs

@@ -0,0 +1,327 @@++module Data.Functor.Invariant.Night.Chain (+  -- * Chain+    NightChain+  , pattern Swerve, pattern Reject+  , runCoNightChain+  , runContraNightChain+  , chainListF+  , chainListF_+  , chainDec+  , swerve, swerved+  , assembleNightChain+  , concatNightChain+  -- * Nonempty Chain+  , NightChain1+  , pattern NightChain1+  , runCoNightChain1+  , runContraNightChain1+  , chainNonEmptyF+  , chainNonEmptyF_+  , chainDec1+  , swerve1, swerved1+  , assembleNightChain1+  , concatNightChain1+  ) where++import           Control.Applicative.ListF+import           Control.Natural+import           Data.Coerce+import           Data.Functor.Alt+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divisible.Free+import           Data.Functor.Invariant+import           Data.Functor.Invariant.Night+import           Data.Functor.Plus+import           Data.HBifunctor.Tensor hiding             (elim1, elim2, intro1, intro2)+import           Data.HFunctor+import           Data.HFunctor.Chain+import           Data.HFunctor.Chain.Internal+import           Data.SOP+import           Data.Void+import qualified Control.Monad.Trans.Compose               as CT+import qualified Data.Functor.Coyoneda                     as CY+import qualified Data.List.NonEmpty                        as NE+++-- | In the covariant direction, we can interpret out of a 'Chain1' of 'Night'+-- into any 'Alt'.+runCoNightChain1+    :: forall f g. Alt g+    => f ~> g+    -> NightChain1 f ~> g+runCoNightChain1 f = foldChain1 f (runNightAlt f id)+                   . unNightChain1++-- | In the contravariant direction, we can interpret out of a 'Chain1' of+-- 'Night' into any 'Decide'.+runContraNightChain1+    :: forall f g. Decide g+    => f ~> g+    -> NightChain1 f ~> g+runContraNightChain1 f = foldChain1 f (runNightDecide f id)+                       . unNightChain1++-- | Extract the 'Dec' part out of a 'NightChain', shedding the+-- covariant bits.+chainDec :: NightChain f ~> Dec f+chainDec = runContraNightChain inject++-- | Extract the 'Dec1' part out of a 'NightChain1', shedding the+-- covariant bits.+chainDec1 :: NightChain1 f ~> Dec1 f+chainDec1 = runContraNightChain1 inject++-- | In the covariant direction, we can interpret out of a 'Chain' of 'Night'+-- into any 'Plus'.+runCoNightChain+    :: forall f g. Plus g+    => f ~> g+    -> NightChain f ~> g+runCoNightChain f = foldChain (const zero) (runNightAlt f id)+                  . unNightChain++-- | In the contravariant direction, we can interpret out of a 'Chain' of+-- 'Night' into any 'Conclude'.+runContraNightChain+    :: forall f g. Conclude g+    => f ~> g+    -> NightChain f ~> g+runContraNightChain f = foldChain (conclude . refute) (runNightDecide f id)+                      . unNightChain++-- | Extract the 'ListF' part out of a 'NightChain', shedding the+-- contravariant bits.+--+-- @since 0.3.2.0+chainListF :: Functor f => NightChain f ~> ListF f+chainListF = runCoNightChain inject++-- | Extract the 'ListF' part out of a 'NightChain', shedding the+-- contravariant bits.+--+-- This version does not require a 'Functor' constraint because it converts+-- to the coyoneda-wrapped product, which is more accurately the true+-- conversion to a covariant chain.+--+-- @since 0.3.2.0+chainListF_ :: NightChain f ~> CT.ComposeT ListF CY.Coyoneda f+chainListF_ = foldChain (const (CT.ComposeT (ListF []))) (\case+    Night x (CT.ComposeT (ListF xs)) _ f g -> CT.ComposeT . ListF $+      CY.Coyoneda f x : (map . fmap) g xs+    ) . unNightChain++-- | Extract the 'NonEmptyF' part out of a 'NightChain1', shedding the+-- contravariant bits.+--+-- @since 0.3.2.0+chainNonEmptyF :: Functor f => NightChain1 f ~> NonEmptyF f+chainNonEmptyF = runCoNightChain1 inject++-- | Extract the 'NonEmptyF' part out of a 'NightChain1', shedding the+-- contravariant bits.+--+-- This version does not require a 'Functor' constraint because it converts+-- to the coyoneda-wrapped product, which is more accurately the true+-- conversion to a covariant chain.+--+-- @since 0.3.2.0+chainNonEmptyF_ :: NightChain1 f ~> CT.ComposeT NonEmptyF CY.Coyoneda f+chainNonEmptyF_ = foldChain1 inject (\case+    Night x (CT.ComposeT (NonEmptyF xs)) _ f g -> CT.ComposeT . NonEmptyF $+      CY.Coyoneda f x NE.<| (fmap . fmap) g xs+    ) . unNightChain1+++-- | Match on a non-empty 'NightChain'; contains the splitting function,+-- the two rejoining functions, the first @f@, and the rest of the chain.+-- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Choose'+-- constructor.+pattern Swerve :: (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> NightChain f c -> NightChain f a+pattern Swerve f g h x xs <- (unSwerve_->MaybeF (Just (Night x xs f g h)))+  where+    Swerve f g h x xs = NightChain $ More $ Night x (unNightChain xs) f g h++unSwerve_ :: NightChain f ~> MaybeF (Night f (NightChain f))+unSwerve_ = \case+  NightChain (More (Night x xs g f h)) -> MaybeF . Just $ Night x (NightChain xs) g f h+  NightChain (Done _                 ) -> MaybeF Nothing+++-- | Match on an "empty" 'NightChain'; contains no @f@s, but only the+-- terminal value.  Analogous to the+-- 'Data.Functor.Contravariant.Divisible.Free.Lose' constructor.+pattern Reject :: (a -> Void) -> NightChain f a+pattern Reject x = NightChain (Done (Not x))+{-# COMPLETE Swerve, Reject #-}++-- | Match on a 'NightChain1' to get the head and the rest of the items.+-- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Dec1'+-- constructor.+pattern NightChain1 :: Invariant f => (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> NightChain f c -> NightChain1 f a+pattern NightChain1 f g h x xs <- (coerce splitChain1->Night x xs f g h)+  where+    NightChain1 f g h x xs = unsplitNE $ Night x xs f g h+{-# COMPLETE NightChain1 #-}++-- | Invariantly combine two 'NightChain's.+--+-- Analogous to '<|>' and 'decide'.  If there was some typeclass that+-- represented semigroups on invariant 'Night', this would be the method of that+-- typeclass.+--+-- The identity of this is 'Reject'.+--+-- @since 0.3.4.0+swerve+    :: (a -> Either b c)+    -> (b -> a)+    -> (c -> a)+    -> NightChain f b+    -> NightChain f c+    -> NightChain f a+swerve f g h x y = coerce appendChain (Night x y f g h)++-- | Convenient wrapper over 'swerve' that simply combines the two options+-- in an 'Either'.  Analogous to '<|>' and 'decided'.+--+-- @since 0.3.4.0+swerved+    :: NightChain f a+    -> NightChain f b+    -> NightChain f (Either a b)+swerved = swerve id Left Right++-- | Invariantly combine two 'NightChain1's.+--+-- Analogous to '<|>' and 'decide'.  If there was some typeclass that+-- represented semigroups on invariant 'Night', this would be the method of that+-- typeclass.+--+-- @since 0.3.4.0+swerve1+    :: Invariant f+    => (a -> Either b c)+    -> (b -> a)+    -> (c -> a)+    -> NightChain1 f b+    -> NightChain1 f c+    -> NightChain1 f a+swerve1 f g h x y = coerce appendChain1 (Night x y f g h)++-- | Convenient wrapper over 'swerve1' that simply combines the two options+-- in an 'Either'.  Analogous to '<|>' and 'decided'.+--+-- @since 0.3.4.0+swerved1+    :: Invariant f+    => NightChain1 f a+    -> NightChain1 f b+    -> NightChain1 f (Either a b)+swerved1 = swerve1 id Left Right++-- | Convenient wrapper to build up a 'NightChain' on by providing each+-- component of it.  This makes it much easier to build up longer chains+-- because you would only need to write the splitting/joining functions in+-- one place.+--+-- For example, if you had a data type+--+-- @+-- data MyType = MTI Int | MTB Bool | MTS String+-- @+--+-- and an invariant functor @Prim@ (representing, say, a bidirectional+-- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@),+-- then you could assemble a bidirectional parser for a @MyType@ using:+--+-- @+-- invmap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z))))+--        (\case Z (I x) -> MTI x; S (Z (I y)) -> MTB y; S (S (Z (I z))) -> MTS z) $+--   assembleNightChain $ intPrim+--                     :* boolPrim+--                     :* stringPrim+--                     :* Nil+-- @+--+-- Some notes on usefulness depending on how many components you have:+--+-- *    If you have 0 components, use 'Reject' directly.+-- *    If you have 1 component, use 'inject' or 'injectChain' directly.+-- *    If you have 2 components, use 'toListBy' or 'toChain'.+-- *    If you have 3 or more components, these combinators may be useful;+--      otherwise you'd need to manually peel off eithers one-by-one.+assembleNightChain+    :: NP f as+    -> NightChain f (NS I as)+assembleNightChain = \case+    Nil     -> NightChain $ Done $ Not (\case {})+    x :* xs -> NightChain $ More $ Night+      x+      (unNightChain $ assembleNightChain xs)+      unconsNSI+      (Z . I)+      S++-- | A version of 'assembleNightChain' where each component is itself+-- a 'NightChain'.+--+-- @+-- assembleNightChain (x :* y :* z :* Nil)+--   = concatNightChain (injectChain x :* injectChain y :* injectChain z :* Nil)+-- @+concatNightChain+    :: NP (NightChain f) as+    -> NightChain f (NS I as)+concatNightChain = \case+    Nil     -> NightChain $ Done $ Not (\case {})+    x :* xs -> coerce appendChain $ Night+      x+      (unNightChain $ concatNightChain xs)+      unconsNSI+      (Z . I)+      S++-- | A version of 'assembleNightChain' but for 'NightChain1' instead.  Can+-- be useful if you intend on interpreting it into something with only+-- a 'Decide' or 'Alt' instance, but no+-- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or+-- 'Control.Applicative.Alternative'.+assembleNightChain1+    :: Invariant f+    => NP f (a ': as)+    -> NightChain1 f (NS I (a ': as))+assembleNightChain1 = \case+    x :* xs -> NightChain1_ $ case xs of+      Nil    -> Done1 $ invmap (Z . I) (unI . unZ) x+      _ :* _ -> More1 $ Night+        x+        (unNightChain1 $ assembleNightChain1 xs)+        unconsNSI+        (Z . I)+        S++-- | A version of 'concatNightChain' but for 'NightChain1' instead.  Can be+-- useful if you intend on interpreting it into something with only+-- a 'Decide' or 'Alt' instance, but no+-- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or+-- 'Control.Applicative.Alternative'.+concatNightChain1+    :: Invariant f+    => NP (NightChain1 f) (a ': as)+    -> NightChain1 f (NS I (a ': as))+concatNightChain1 = \case+    x :* xs -> case xs of+      Nil    -> invmap (Z . I) (unI . unZ) x+      _ :* _ -> coerce appendChain1 $ Night+        x+        (unNightChain1 $ concatNightChain1 xs)+        unconsNSI+        (Z . I)+        S++unconsNSI :: NS I (a ': as) -> Either a (NS I as)+unconsNSI = \case+  Z (I x) -> Left x+  S xs    -> Right xs

@@ -59,6 +59,7 @@ import           Control.Monad.Trans.Identity import           Control.Natural import           Control.Natural.IsoF+import           Data.Bifunctor import           Data.Bifunctor.Joker import           Data.Coerce import           Data.Constraint.Trivial@@ -81,16 +82,20 @@ import           Data.Functor.These import           Data.HBifunctor import           Data.HFunctor+import           Data.HFunctor.Chain.Internal import           Data.HFunctor.Internal import           Data.HFunctor.Interpret import           Data.Kind import           Data.List.NonEmpty                        (NonEmpty(..)) import           Data.Void import           GHC.Generics+import qualified Data.Bifunctor.Assoc                      as B import qualified Data.Functor.Contravariant.Coyoneda       as CCY import qualified Data.Functor.Contravariant.Day            as CD import qualified Data.Functor.Contravariant.Night          as N import qualified Data.Functor.Day                          as D+import qualified Data.Functor.Invariant.Day                as ID+import qualified Data.Functor.Invariant.Night              as IN import qualified Data.Map.NonEmpty                         as NEM  -- | An 'HBifunctor' where it doesn't matter which binds first is@@ -496,6 +501,45 @@ instance Divise f => SemigroupIn CD.Day f where     biretract      (CD.Day x y f) = divise f x y     binterpret f g (CD.Day x y h) = divise h (f x) (g y)++instance Associative ID.Day where+    type NonEmptyBy ID.Day = DayChain1+    type FunctorBy ID.Day = Invariant+    associating = isoF assoc disassoc++    appendNE = coerce appendNEIDay_+    matchNE = coerce matchChain1++    consNE = coerce More1+    toNonEmptyBy = coerce toChain1++appendNEIDay_ :: ID.Day (Chain1 ID.Day f) (Chain1 ID.Day f) ~> Chain1 ID.Day f+appendNEIDay_ (ID.Day xs ys g f) = case xs of+  Done1 x              -> More1 (ID.Day x ys g f)+  More1 (ID.Day z zs j h) -> More1 $+    ID.Day z (appendNEIDay_ (ID.Day zs ys (,) id))+      (\a (b, c) -> g (j a b) c)+      (B.assoc . first h . f)++instance Associative IN.Night where+    type NonEmptyBy IN.Night = NightChain1+    type FunctorBy IN.Night = Invariant+    associating = isoF IN.assoc IN.unassoc++    appendNE = coerce appendNEINight_+    matchNE = coerce matchChain1++    consNE = coerce More1+    toNonEmptyBy = coerce toChain1++appendNEINight_ :: IN.Night (Chain1 IN.Night f) (Chain1 IN.Night f) ~> Chain1 IN.Night f+appendNEINight_ (IN.Night xs ys f g h) = case xs of+  Done1 x                  -> More1 (IN.Night x ys f g h)+  More1 (IN.Night z zs j k l) -> More1 $+    IN.Night z (appendNEINight_ (IN.Night zs ys id Left Right))+      (B.assoc . first j . f)+      (g . k)+      (either (g . l) h)  -- | @since 0.3.0.0 instance Associative Night where

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ -- | -- Module      : Data.HBifunctor.Tensor -- Copyright   : (c) Justin Le 2019@@ -76,6 +78,7 @@ import           Control.Monad.Trans.Compose import           Control.Natural import           Control.Natural.IsoF+import           Data.Coerce import           Data.Data import           Data.Function import           Data.Functor.Apply.Free@@ -97,136 +100,22 @@ import           Data.Functor.These import           Data.HBifunctor import           Data.HBifunctor.Associative+import           Data.HBifunctor.Tensor.Internal import           Data.HFunctor+import           Data.HFunctor.Chain.Internal import           Data.HFunctor.Internal import           Data.HFunctor.Interpret-import           Data.Kind import           Data.List.NonEmpty                        (NonEmpty(..))+import           Data.Void import           GHC.Generics import qualified Data.Functor.Contravariant.Coyoneda       as CCY import qualified Data.Functor.Contravariant.Day            as CD import qualified Data.Functor.Contravariant.Night          as N import qualified Data.Functor.Day                          as D+import qualified Data.Functor.Invariant.Day                as ID+import qualified Data.Functor.Invariant.Night              as IN import qualified Data.Map.NonEmpty                         as NEM --- | An 'Associative' 'HBifunctor' can be a 'Tensor' if there is some--- identity @i@ where @t i f@ and @t f i@ are equivalent to just @f@.------ That is, "enhancing" @f@ with @t i@ does nothing.------ The methods in this class provide us useful ways of navigating--- a @'Tensor' t@ with respect to this property.------ The 'Tensor' is essentially the 'HBifunctor' equivalent of 'Inject',--- with 'intro1' and 'intro2' taking the place of 'inject'.------ Formally, we can say that @t@ enriches a the category of--- endofunctors with monoid strcture: it turns our endofunctor category--- into a "monoidal category".------ Different instances of @t@ each enrich the endofunctor category in--- different ways, giving a different monoidal category.-class (Associative t, Inject (ListBy t)) => Tensor t i | t -> i where-    -- | The "monoidal functor combinator" induced by @t@.-    ---    -- A value of type @ListBy t f a@ is /equivalent/ to one of:-    ---    -- *  @I a@                         -- zero fs-    -- *  @f a@                         -- one f-    -- *  @t f f a@                     -- two fs-    -- *  @t f (t f f) a@               -- three fs-    -- *  @t f (t f (t f f)) a@-    -- *  @t f (t f (t f (t f f))) a@-    -- *  .. etc-    ---    -- For example, for ':*:', we have 'ListF'.  This is because:-    ---    -- @-    -- 'Proxy'         ~ 'ListF' []         ~ 'nilLB' \@(':*:')-    -- x             ~ ListF [x]        ~ 'inject' x-    -- x :*: y       ~ ListF [x,y]      ~ 'toListBy' (x :*: y)-    -- x :*: y :*: z ~ ListF [x,y,z]-    -- -- etc.-    -- @-    ---    -- You can create an "empty" one with 'nilLB', a "singleton" one with-    -- 'inject', or else one from a single @t f f@ with 'toListBy'.-    ---    -- See 'Data.HBifunctor.Associative.NonEmptyBy' for a "non-empty"-    -- version of this type.-    type ListBy t :: (Type -> Type) -> Type -> Type--    -- | Because @t f (I t)@ is equivalent to @f@, we can always "insert"-    -- @f@ into @t f (I t)@.-    ---    -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's.-    intro1 :: f ~> t f i--    -- | Because @t (I t) g@ is equivalent to @f@, we can always "insert"-    -- @g@ into @t (I t) g@.-    ---    -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's.-    intro2 :: g ~> t i g--    -- | Witnesses the property that @i@ is the identity of @t@: @t-    -- f i@ always leaves @f@ unchanged, so we can always just drop the-    -- @i@.-    elim1 :: FunctorBy t f => t f i ~> f--    -- | Witnesses the property that @i@ is the identity of @t@: @t i g@-    -- always leaves @g@ unchanged, so we can always just drop the @i t@.-    elim2 :: FunctorBy t g => t i g ~> g--    -- | If a @'ListBy' t f@ represents multiple applications of @t f@ to-    -- itself, then we can also "append" two @'ListBy' t f@s applied to-    -- themselves into one giant @'ListBy' t f@ containing all of the @t f@s.-    ---    -- Note that this essentially gives an instance for @'SemigroupIn'-    -- t (ListBy t f)@, for any functor @f@; this is witnessed by-    -- 'WrapLB'.-    appendLB    :: t (ListBy t f) (ListBy t f) ~> ListBy t f--    -- | Lets you convert an @'NonEmptyBy' t f@ into a single application of @f@ to-    -- @'ListBy' t f@.-    ---    -- Analogous to a function @'Data.List.NonEmpty.NonEmpty' a -> (a,-    -- [a])@-    ---    -- Note that this is not reversible in general unless we have-    -- @'Matchable' t@.-    splitNE     :: NonEmptyBy t f ~> t f (ListBy t f)--    -- | An @'ListBy' t f@ is either empty, or a single application of @t@ to @f@-    -- and @ListBy t f@ (the "head" and "tail").  This witnesses that-    -- isomorphism.-    ---    -- To /use/ this property, see 'nilLB', 'consLB', and 'unconsLB'.-    splittingLB :: ListBy t f <~> i :+: t f (ListBy t f)--    -- | Embed a direct application of @f@ to itself into a @'ListBy' t f@.-    toListBy   :: t f f ~> ListBy t f-    toListBy   = reviewF (splittingLB @t)-           . R1-           . hright (inject @(ListBy t))--    -- | @'NonEmptyBy' t f@ is "one or more @f@s", and @'ListBy t f@ is "zero or more-    -- @f@s".  This function lets us convert from one to the other.-    ---    -- This is analogous to a function @'Data.List.NonEmpty.NonEmpty' a ->-    -- [a]@.-    ---    -- Note that because @t@ is not inferrable from the input or output-    -- type, you should call this using /-XTypeApplications/:-    ---    -- @-    -- 'fromNE' \@(':*:') :: 'NonEmptyF' f a -> 'ListF' f a-    -- fromNE \@'Comp'  :: 'Free1' f a -> 'Free' f a-    -- @-    fromNE :: NonEmptyBy t f ~> ListBy t f-    fromNE = reviewF (splittingLB @t) . R1 . splitNE @t--    {-# MINIMAL intro1, intro2, elim1, elim2, appendLB, splitNE, splittingLB #-}- -- | @f@ is isomorphic to @t f i@: that is, @i@ is the identity of @t@, and -- leaves @f@ unchanged. rightIdentity :: (Tensor t i, FunctorBy t f) => f <~> t f i@@ -375,39 +264,6 @@ interpretLB :: forall t i g f. MonoidIn t i f => (g ~> f) -> ListBy t g ~> f interpretLB f = retractLB @t . hmap f --- | Create the "empty 'ListBy'".------ If @'ListBy' t f@ represents multiple applications of @t f@ with--- itself, then @nilLB@ gives us "zero applications of @f@".------ Note that @t@ cannot be inferred from the input or output type of--- 'nilLB', so this function must always be called with -XTypeApplications:------ @--- 'nilLB' \@'Day' :: 'Identity' '~>' 'Ap' f--- nilLB \@'Comp' :: Identity ~> 'Free' f--- nilLB \@(':*:') :: 'Proxy' ~> 'ListF' f--- @------ Note that this essentially gives an instance for @'MonoidIn' t i (ListBy--- t f)@, for any functor @f@; this is witnessed by 'WrapLB'.-nilLB    :: forall t i f. Tensor t i => i ~> ListBy t f-nilLB    = reviewF (splittingLB @t) . L1---- | Lets us "cons" an application of @f@ to the front of an @'ListBy' t f@.-consLB   :: Tensor t i => t f (ListBy t f) ~> ListBy t f-consLB   = reviewF splittingLB . R1---- | "Pattern match" on an @'ListBy' t@------ An @'ListBy' t f@ is either empty, or a single application of @t@ to @f@--- and @ListBy t f@ (the "head" and "tail")------ This is analogous to the function @'Data.List.uncons' :: [a] -> Maybe--- (a, [a])@.-unconsLB :: Tensor t i => ListBy t f ~> i :+: t f (ListBy t f)-unconsLB = viewF splittingLB- -- | Convenient wrapper over 'intro1' that lets us introduce an arbitrary -- functor @g@ to the right of an @f@. --@@ -603,6 +459,62 @@ -- @since 0.3.0.0 instance (Divise f, Divisible f) => MonoidIn CD.Day Proxy f where     pureT _ = conquer++instance Tensor ID.Day Identity where+    type ListBy ID.Day = DayChain++    intro1 = ID.intro2+    intro2 = ID.intro1+    elim1 = ID.elim2+    elim2 = ID.elim1++    appendLB = coerce appendChain+    splitNE = coerce splitChain1+    splittingLB = coercedF . splittingChain . coercedF++    toListBy = DayChain . More . hright (unDayChain . inject)++instance Matchable ID.Day Identity where+    unsplitNE = coerce unsplitNEIDay_+    matchLB = coerce matchLBIDay_++unsplitNEIDay_ :: Invariant f => ID.Day f (Chain ID.Day Identity f) ~> Chain1 ID.Day f+unsplitNEIDay_ (ID.Day x xs g f) = case xs of+  Done (Identity r) -> Done1 $ invmap (`g` r) (fst . f) x+  More ys           -> More1 $ ID.Day x (unsplitNEIDay_ ys) g f++matchLBIDay_ :: Invariant f => Chain ID.Day Identity f ~> (Identity :+: Chain1 ID.Day f)+matchLBIDay_ = \case+  Done x  -> L1 x+  More xs -> R1 $ unsplitNEIDay_ xs++instance Tensor IN.Night IN.Not where+    type ListBy IN.Night = NightChain++    intro1 = IN.intro2+    intro2 = IN.intro1+    elim1 = IN.elim2+    elim2 = IN.elim1++    appendLB = coerce appendChain+    splitNE = coerce splitChain1+    splittingLB = coercedF . splittingChain . coercedF++    toListBy = NightChain . More . hright (unNightChain . inject)++instance Matchable IN.Night Not where+    unsplitNE = coerce unsplitNEINight_+    matchLB = coerce matchLBINight_++unsplitNEINight_ :: Invariant f => IN.Night f (Chain IN.Night Not f) ~> Chain1 IN.Night f+unsplitNEINight_ (IN.Night x xs f g h) = case xs of+  Done r  -> Done1 $ invmap g (either id (absurd . refute r) . f) x+  More ys -> More1 $ IN.Night x (unsplitNEINight_ ys) f g h++matchLBINight_ :: Invariant f => Chain IN.Night Not f ~> (Not :+: Chain1 IN.Night f)+matchLBINight_ = \case+  Done x  -> L1 x+  More xs -> R1 $ unsplitNEINight_ xs  -- | @since 0.3.0.0 instance Tensor Night Not where

@@ -0,0 +1,241 @@++module Data.HBifunctor.Tensor.Internal (+    Tensor(..)+  , unconsLB+  , nilLB+  , consLB+  , appendChain+  , unroll+  , reroll+  , rerollNE+  , splitChain1+  ) where++import           Control.Natural+import           Control.Natural.IsoF+import           Data.HBifunctor+import           Data.HBifunctor.Associative+import           Data.HFunctor+import           Data.HFunctor.Chain.Internal+import           Data.Kind+import           GHC.Generics+++-- | An 'Associative' 'HBifunctor' can be a 'Tensor' if there is some+-- identity @i@ where @t i f@ and @t f i@ are equivalent to just @f@.+--+-- That is, "enhancing" @f@ with @t i@ does nothing.+--+-- The methods in this class provide us useful ways of navigating+-- a @'Tensor' t@ with respect to this property.+--+-- The 'Tensor' is essentially the 'HBifunctor' equivalent of 'Inject',+-- with 'intro1' and 'intro2' taking the place of 'inject'.+--+-- Formally, we can say that @t@ enriches a the category of+-- endofunctors with monoid strcture: it turns our endofunctor category+-- into a "monoidal category".+--+-- Different instances of @t@ each enrich the endofunctor category in+-- different ways, giving a different monoidal category.+class (Associative t, Inject (ListBy t)) => Tensor t i | t -> i where+    -- | The "monoidal functor combinator" induced by @t@.+    --+    -- A value of type @ListBy t f a@ is /equivalent/ to one of:+    --+    -- *  @I a@                         -- zero fs+    -- *  @f a@                         -- one f+    -- *  @t f f a@                     -- two fs+    -- *  @t f (t f f) a@               -- three fs+    -- *  @t f (t f (t f f)) a@+    -- *  @t f (t f (t f (t f f))) a@+    -- *  .. etc+    --+    -- For example, for ':*:', we have 'ListF'.  This is because:+    --+    -- @+    -- 'Proxy'         ~ 'ListF' []         ~ 'nilLB' \@(':*:')+    -- x             ~ ListF [x]        ~ 'inject' x+    -- x :*: y       ~ ListF [x,y]      ~ 'toListBy' (x :*: y)+    -- x :*: y :*: z ~ ListF [x,y,z]+    -- -- etc.+    -- @+    --+    -- You can create an "empty" one with 'nilLB', a "singleton" one with+    -- 'inject', or else one from a single @t f f@ with 'toListBy'.+    --+    -- See 'Data.HBifunctor.Associative.NonEmptyBy' for a "non-empty"+    -- version of this type.+    type ListBy t :: (Type -> Type) -> Type -> Type++    -- | Because @t f (I t)@ is equivalent to @f@, we can always "insert"+    -- @f@ into @t f (I t)@.+    --+    -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's.+    intro1 :: f ~> t f i++    -- | Because @t (I t) g@ is equivalent to @f@, we can always "insert"+    -- @g@ into @t (I t) g@.+    --+    -- This is analogous to 'inject' from 'Inject', but for 'HBifunctor's.+    intro2 :: g ~> t i g++    -- | Witnesses the property that @i@ is the identity of @t@: @t+    -- f i@ always leaves @f@ unchanged, so we can always just drop the+    -- @i@.+    elim1 :: FunctorBy t f => t f i ~> f++    -- | Witnesses the property that @i@ is the identity of @t@: @t i g@+    -- always leaves @g@ unchanged, so we can always just drop the @i t@.+    elim2 :: FunctorBy t g => t i g ~> g++    -- | If a @'ListBy' t f@ represents multiple applications of @t f@ to+    -- itself, then we can also "append" two @'ListBy' t f@s applied to+    -- themselves into one giant @'ListBy' t f@ containing all of the @t f@s.+    --+    -- Note that this essentially gives an instance for @'SemigroupIn'+    -- t (ListBy t f)@, for any functor @f@; this is witnessed by+    -- 'WrapLB'.+    appendLB    :: t (ListBy t f) (ListBy t f) ~> ListBy t f++    -- | Lets you convert an @'NonEmptyBy' t f@ into a single application of @f@ to+    -- @'ListBy' t f@.+    --+    -- Analogous to a function @'Data.List.NonEmpty.NonEmpty' a -> (a,+    -- [a])@+    --+    -- Note that this is not reversible in general unless we have+    -- @'Matchable' t@.+    splitNE     :: NonEmptyBy t f ~> t f (ListBy t f)++    -- | An @'ListBy' t f@ is either empty, or a single application of @t@ to @f@+    -- and @ListBy t f@ (the "head" and "tail").  This witnesses that+    -- isomorphism.+    --+    -- To /use/ this property, see 'nilLB', 'consLB', and 'unconsLB'.+    splittingLB :: ListBy t f <~> i :+: t f (ListBy t f)++    -- | Embed a direct application of @f@ to itself into a @'ListBy' t f@.+    toListBy   :: t f f ~> ListBy t f+    toListBy   = reviewF (splittingLB @t)+           . R1+           . hright (inject @(ListBy t))++    -- | @'NonEmptyBy' t f@ is "one or more @f@s", and @'ListBy t f@ is "zero or more+    -- @f@s".  This function lets us convert from one to the other.+    --+    -- This is analogous to a function @'Data.List.NonEmpty.NonEmpty' a ->+    -- [a]@.+    --+    -- Note that because @t@ is not inferrable from the input or output+    -- type, you should call this using /-XTypeApplications/:+    --+    -- @+    -- 'fromNE' \@(':*:') :: 'NonEmptyF' f a -> 'ListF' f a+    -- fromNE \@'Comp'  :: 'Free1' f a -> 'Free' f a+    -- @+    fromNE :: NonEmptyBy t f ~> ListBy t f+    fromNE = reviewF (splittingLB @t) . R1 . splitNE @t++    {-# MINIMAL intro1, intro2, elim1, elim2, appendLB, splitNE, splittingLB #-}++-- | Create the "empty 'ListBy'".+--+-- If @'ListBy' t f@ represents multiple applications of @t f@ with+-- itself, then @nilLB@ gives us "zero applications of @f@".+--+-- Note that @t@ cannot be inferred from the input or output type of+-- 'nilLB', so this function must always be called with -XTypeApplications:+--+-- @+-- 'nilLB' \@'Day' :: 'Identity' '~>' 'Ap' f+-- nilLB \@'Comp' :: Identity ~> 'Free' f+-- nilLB \@(':*:') :: 'Proxy' ~> 'ListF' f+-- @+--+-- Note that this essentially gives an instance for @'MonoidIn' t i (ListBy+-- t f)@, for any functor @f@; this is witnessed by 'WrapLB'.+nilLB    :: forall t i f. Tensor t i => i ~> ListBy t f+nilLB    = reviewF (splittingLB @t) . L1++-- | Lets us "cons" an application of @f@ to the front of an @'ListBy' t f@.+consLB   :: Tensor t i => t f (ListBy t f) ~> ListBy t f+consLB   = reviewF splittingLB . R1++-- | "Pattern match" on an @'ListBy' t@+--+-- An @'ListBy' t f@ is either empty, or a single application of @t@ to @f@+-- and @ListBy t f@ (the "head" and "tail")+--+-- This is analogous to the function @'Data.List.uncons' :: [a] -> Maybe+-- (a, [a])@.+unconsLB :: Tensor t i => ListBy t f ~> i :+: t f (ListBy t f)+unconsLB = viewF splittingLB+++-- | '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 = unroll+            . appendLB+            . hbimap reroll 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 = unfoldChain 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 = foldChain (nilLB @t) consLB++-- | 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 = foldChain1 inject consNE++-- | 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 = hright (unroll @t) . splitNE @t . rerollNE+

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ -- | -- Module      : Data.HFunctor.Chain -- Copyright   : (c) Justin Le 2019@@ -60,7 +62,6 @@ 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@@ -68,166 +69,20 @@ 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.HBifunctor.Tensor.Internal import           Data.HFunctor+import           Data.HFunctor.Chain.Internal 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, 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 eq = \case-      Done1 x -> \case-        Done1 y -> liftEq eq x y-        More1 _ -> False-      More1 x -> \case-        Done1 _ -> False-        More1 y -> liftEq eq x y--instance (Ord1 f, Ord1 (t f (Chain1 t f))) => Ord1 (Chain1 t f) where-    liftCompare c = \case-      Done1 x -> \case-        Done1 y -> liftCompare c x y-        More1 _ -> LT-      More1 x -> \case-        Done1 _ -> GT-        More1 y -> liftCompare c x y--instance (Show1 (t f (Chain1 t f)), Show1 f) => Show1 (Chain1 t f) where-    liftShowsPrec sp sl d = \case-        Done1 x  -> showsUnaryWith (liftShowsPrec sp sl) "Done1" d x-        More1 xs -> showsUnaryWith (liftShowsPrec sp sl) "More1" d xs--instance (Functor f, Read1 (t f (Chain1 t f)), Read1 f) => Read1 (Chain1 t f) where-    liftReadsPrec rp rl = readsData $-            readsUnaryWith (liftReadsPrec rp rl) "Done1" Done1-         <> readsUnaryWith (liftReadsPrec rp rl) "More1" More1---- | @since 0.3.0.0-instance (Contravariant f, Contravariant (t f (Chain1 t f))) => Contravariant (Chain1 t f) where-    contramap f = \case-      Done1 x  -> Done1 (contramap f x )-      More1 xs -> More1 (contramap f xs)---- | @since 0.3.0.0-instance (Invariant f, Invariant (t f (Chain1 t f))) => Invariant (Chain1 t f) where-    invmap f g = \case-      Done1 x  -> Done1 (invmap f g x )-      More1 xs -> More1 (invmap f g 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 = go-  where-    go :: Chain1 t f ~> g-    go = \case-      Done1 x  -> f x-      More1 xs -> g (hright go 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 f = go-  where-    go :: g ~> Chain1 t f-    go = (Done1 !*! More1 . hright go) . f--instance HBifunctor t => HFunctor (Chain1 t) where-    hmap f = foldChain1 (Done1 . f) (More1 . hleft f)--instance HBifunctor t => Inject (Chain1 t) where-    inject  = injectChain1- instance (HBifunctor t, SemigroupIn t f) => Interpret (Chain1 t) f where     retract = \case       Done1 x  -> x@@ -240,19 +95,6 @@           Done1 x  -> f x           More1 xs -> binterpret f go 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 = More1 . hright Done1---- | Create a singleton 'Chain1'.------ @since 0.3.0.0-injectChain1 :: f ~> Chain1 t f-injectChain1 = 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@@ -274,16 +116,6 @@ unrollNE :: (Associative t, FunctorBy t f) => NonEmptyBy t f ~> Chain1 t f unrollNE = unfoldChain1 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 = foldChain1 inject consNE- -- | 'Chain1' is a semigroup with respect to @t@: we can "combine" them in -- an associative way. --@@ -343,134 +175,6 @@ instance Contravariant f => Decide (Chain1 N.Night f) where     decide f x y = appendChain1 $ N.Night x y 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 eq = \case-      Done x -> \case-        Done y -> liftEq eq x y-        More _ -> False-      More x -> \case-        Done _ -> False-        More y -> liftEq eq x y--instance (Ord1 i, Ord1 (t f (Chain t i f))) => Ord1 (Chain t i f) where-    liftCompare c = \case-      Done x -> \case-        Done y -> liftCompare c x y-        More _ -> LT-      More x -> \case-        Done _ -> GT-        More y -> liftCompare c x y--instance (Show1 (t f (Chain t i f)), Show1 i) => Show1 (Chain t i f) where-    liftShowsPrec sp sl d = \case-        Done x  -> showsUnaryWith (liftShowsPrec sp sl) "Done" d x-        More xs -> showsUnaryWith (liftShowsPrec sp sl) "More" d xs--instance (Functor i, Read1 (t f (Chain t i f)), Read1 i) => Read1 (Chain t i f) where-    liftReadsPrec rp rl = readsData $-            readsUnaryWith (liftReadsPrec rp rl) "Done" Done-         <> readsUnaryWith (liftReadsPrec rp rl) "More" More--instance (Contravariant i, Contravariant (t f (Chain t i f))) => Contravariant (Chain t i f) where-    contramap f = \case-      Done x  -> Done (contramap f x )-      More xs -> More (contramap f xs)--instance (Invariant i, Invariant (t f (Chain t i f))) => Invariant (Chain t i f) where-    invmap f g = \case-      Done x  -> Done (invmap f g x )-      More xs -> More (invmap f g 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 f g = go-  where-    go :: Chain t i f ~> g-    go = \case-      Done x  -> f x-      More xs -> g (hright go 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 f = go-  where-    go :: g a -> Chain t i f a-    go = (Done !*! More . hright go) . f--instance HBifunctor t => HFunctor (Chain t i) where-    hmap f = foldChain Done (More . hleft f)- instance Tensor t i => Inject (Chain t i) where     inject = injectChain @@ -522,82 +226,6 @@     => ListBy t f <~> Chain t i f unrolling = isoF unroll 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 = unfoldChain 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 = foldChain (nilLB @t) 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 = unroll-            . appendLB-            . hbimap reroll 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 = \case-    Done1 x  -> L1 x-    More1 xs -> R1 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 = isoF unconsChain $ \case-      L1 x  -> Done x-      R1 xs -> More 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 = \case-    Done x  -> L1 x-    More xs -> R1 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@@ -608,13 +236,6 @@ splittingChain1 = fromF unrollingNE                 . splittingNE @t                 . overHBifunctor id 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 = hright (unroll @t) . splitNE @t . 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

@@ -0,0 +1,406 @@++module Data.HFunctor.Chain.Internal (+    Chain1(..)+  , foldChain1, unfoldChain1+  , toChain1, injectChain1+  , matchChain1+  , Chain(..)+  , foldChain, unfoldChain+  , splittingChain, unconsChain+  , DayChain1(..)+  , DayChain(..)+  , NightChain(..)+  , NightChain1(..)+  ) where++import           Control.Natural+import           Control.Natural.IsoF+import           Data.Functor.Classes+import           Data.Functor.Contravariant+import           Data.Functor.Identity+import           Data.Functor.Invariant+import           Data.HBifunctor+import           Data.HFunctor+import           Data.Kind+import           Data.Typeable+import           Data.Void+import           GHC.Generics+import qualified Data.Functor.Invariant.Day   as ID+import qualified Data.Functor.Invariant.Night as IN+++-- | 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, 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 eq = \case+      Done1 x -> \case+        Done1 y -> liftEq eq x y+        More1 _ -> False+      More1 x -> \case+        Done1 _ -> False+        More1 y -> liftEq eq x y++instance (Ord1 f, Ord1 (t f (Chain1 t f))) => Ord1 (Chain1 t f) where+    liftCompare c = \case+      Done1 x -> \case+        Done1 y -> liftCompare c x y+        More1 _ -> LT+      More1 x -> \case+        Done1 _ -> GT+        More1 y -> liftCompare c x y++instance (Show1 (t f (Chain1 t f)), Show1 f) => Show1 (Chain1 t f) where+    liftShowsPrec sp sl d = \case+        Done1 x  -> showsUnaryWith (liftShowsPrec sp sl) "Done1" d x+        More1 xs -> showsUnaryWith (liftShowsPrec sp sl) "More1" d xs++instance (Functor f, Read1 (t f (Chain1 t f)), Read1 f) => Read1 (Chain1 t f) where+    liftReadsPrec rp rl = readsData $+            readsUnaryWith (liftReadsPrec rp rl) "Done1" Done1+         <> readsUnaryWith (liftReadsPrec rp rl) "More1" More1++-- | @since 0.3.0.0+instance (Contravariant f, Contravariant (t f (Chain1 t f))) => Contravariant (Chain1 t f) where+    contramap f = \case+      Done1 x  -> Done1 (contramap f x )+      More1 xs -> More1 (contramap f xs)++-- | @since 0.3.0.0+instance (Invariant f, Invariant (t f (Chain1 t f))) => Invariant (Chain1 t f) where+    invmap f g = \case+      Done1 x  -> Done1 (invmap f g x )+      More1 xs -> More1 (invmap f g xs)++instance HBifunctor t => HFunctor (Chain1 t) where+    hmap f = foldChain1 (Done1 . f) (More1 . hleft f)++instance HBifunctor t => Inject (Chain1 t) where+    inject  = injectChain1++-- | 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 = go+  where+    go :: Chain1 t f ~> g+    go = \case+      Done1 x  -> f x+      More1 xs -> g (hright go 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 f = go+  where+    go :: g ~> Chain1 t f+    go = (\case L1 x -> Done1 x; R1 y -> More1 (hright go y)) . f++-- | 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 = More1 . hright Done1++-- | Create a singleton 'Chain1'.+--+-- @since 0.3.0.0+injectChain1 :: f ~> Chain1 t f+injectChain1 = Done1++-- | 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 = \case+    Done1 x  -> L1 x+    More1 xs -> R1 xs++-- | 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 eq = \case+      Done x -> \case+        Done y -> liftEq eq x y+        More _ -> False+      More x -> \case+        Done _ -> False+        More y -> liftEq eq x y++instance (Ord1 i, Ord1 (t f (Chain t i f))) => Ord1 (Chain t i f) where+    liftCompare c = \case+      Done x -> \case+        Done y -> liftCompare c x y+        More _ -> LT+      More x -> \case+        Done _ -> GT+        More y -> liftCompare c x y++instance (Show1 (t f (Chain t i f)), Show1 i) => Show1 (Chain t i f) where+    liftShowsPrec sp sl d = \case+        Done x  -> showsUnaryWith (liftShowsPrec sp sl) "Done" d x+        More xs -> showsUnaryWith (liftShowsPrec sp sl) "More" d xs++instance (Functor i, Read1 (t f (Chain t i f)), Read1 i) => Read1 (Chain t i f) where+    liftReadsPrec rp rl = readsData $+            readsUnaryWith (liftReadsPrec rp rl) "Done" Done+         <> readsUnaryWith (liftReadsPrec rp rl) "More" More++instance (Contravariant i, Contravariant (t f (Chain t i f))) => Contravariant (Chain t i f) where+    contramap f = \case+      Done x  -> Done (contramap f x )+      More xs -> More (contramap f xs)++instance (Invariant i, Invariant (t f (Chain t i f))) => Invariant (Chain t i f) where+    invmap f g = \case+      Done x  -> Done (invmap f g x )+      More xs -> More (invmap f g xs)++instance HBifunctor t => HFunctor (Chain t i) where+    hmap f = foldChain Done (More . hleft f)++-- | 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 f g = go+  where+    go :: Chain t i f ~> g+    go = \case+      Done x  -> f x+      More xs -> g (hright go 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 f = go+  where+    go :: g a -> Chain t i f a+    go = (\case L1 x -> Done x; R1 y ->  More (hright go y)) . f++-- | 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 = isoF unconsChain $ \case+      L1 x  -> Done x+      R1 xs -> More 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 = \case+    Done x  -> L1 x+    More xs -> R1 xs++-- | Instead of defining yet another separate free semigroup like+-- 'Data.Functor.Apply.Free.Ap1',+-- 'Data.Functor.Contravariant.Divisible.Free.Div1', or+-- 'Data.Functor.Contravariant.Divisible.Free.Dec1', we re-use 'Chain1'.+--+-- You can assemble values using the combinators in "Data.HFunctor.Chain",+-- and then tear them down/interpret them using 'runCoDayChain1' and+-- 'runContraDayChain1'.  There is no general invariant interpreter (and so no+-- 'SemigroupIn' instance for 'Day') because the typeclasses used to+-- express the target contexts are probably not worth defining given how+-- little the Haskell ecosystem uses invariant functors as an abstraction.+newtype DayChain1 f a = DayChain1_ { unDayChain1 :: Chain1 ID.Day f a }+  deriving (Invariant, HFunctor, Inject)++-- | Instead of defining yet another separate free monoid like+-- 'Control.Applicative.Free.Ap',+-- 'Data.Functor.Contravariant.Divisible.Free.Div', or+-- 'Data.Functor.Contravariant.Divisible.Free.Dec', we re-use 'Chain'.+--+-- You can assemble values using the combinators in "Data.HFunctor.Chain",+-- and then tear them down/interpret them using 'runCoDayChain' and+-- 'runContraDayChain'.  There is no general invariant interpreter (and so no+-- 'MonoidIn' instance for 'Day') because the typeclasses used to express+-- the target contexts are probably not worth defining given how little the+-- Haskell ecosystem uses invariant functors as an abstraction.+newtype DayChain f a = DayChain { unDayChain :: Chain ID.Day Identity f a }+  deriving (Invariant, HFunctor)++instance Inject DayChain where+    inject x = DayChain $ More (ID.Day x (Done (Identity ())) const (,()))++-- | Instead of defining yet another separate free semigroup like+-- 'Data.Functor.Apply.Free.Ap1',+-- 'Data.Functor.Contravariant.Divisible.Free.Div1', or+-- 'Data.Functor.Contravariant.Divisible.Free.Dec1', we re-use 'Chain1'.+--+-- You can assemble values using the combinators in "Data.HFunctor.Chain",+-- and then tear them down/interpret them using 'runCoNightChain1' and+-- 'runContraNightChain1'.  There is no general invariant interpreter (and so no+-- 'SemigroupIn' instance for 'Night') because the typeclasses used to+-- express the target contexts are probably not worth defining given how+-- little the Haskell ecosystem uses invariant functors as an abstraction.+newtype NightChain1 f a = NightChain1_ { unNightChain1 :: Chain1 IN.Night f a }+  deriving (Invariant, HFunctor, Inject)++-- | Instead of defining yet another separate free monoid like+-- 'Control.Applicative.Free.Ap',+-- 'Data.Functor.Contravariant.Divisible.Free.Div', or+-- 'Data.Functor.Contravariant.Divisible.Free.Dec', we re-use 'Chain'.+--+-- You can assemble values using the combinators in "Data.HFunctor.Chain",+-- and then tear them down/interpret them using 'runCoNightChain' and+-- 'runContraNightChain'.  There is no general invariant interpreter (and so no+-- 'MonoidIn' instance for 'Night') because the typeclasses used to express+-- the target contexts are probably not worth defining given how little the+-- Haskell ecosystem uses invariant functors as an abstraction.+newtype NightChain f a = NightChain { unNightChain :: Chain IN.Night IN.Not f a }+  deriving (Invariant, HFunctor)++instance Inject NightChain where+    inject x = NightChain $ More (IN.Night x (Done IN.refuted) Left id absurd)+

@@ -52,6 +52,8 @@ import qualified Data.Functor.Contravariant.Day      as CD import qualified Data.Functor.Contravariant.Night    as N import qualified Data.Functor.Day                    as D+import qualified Data.Functor.Invariant.Day          as ID+import qualified Data.Functor.Invariant.Night        as IN import qualified Data.SOP                            as SOP import qualified Data.SOP.NP                         as SOP import qualified Data.SOP.NS                         as SOP@@ -341,6 +343,13 @@     hright = CD.trans2     hbimap f g (CD.Day x y z) = CD.Day (f x) (g y) z +-- | @since 0.3.4.0+instance HBifunctor ID.Day where+    hbimap f g (ID.Day x y h j) = ID.Day (f x) (g y) h j++instance HBifunctor IN.Night where+    hbimap f g (IN.Night x y h j k) = IN.Night (f x) (g y) h j k+ -- | @since 0.3.0.0 instance HBifunctor Night where     hleft  = N.trans1@@ -397,12 +406,14 @@ instance HBifunctor t => HFunctor (WrappedHBifunctor t f) where     hmap f = WrapHBifunctor . hright f . unwrapHBifunctor -deriving via (WrappedHBifunctor Day f)     instance HFunctor (Day f)-deriving via (WrappedHBifunctor (:*:) f)   instance HFunctor ((:*:) f)-deriving via (WrappedHBifunctor (:+:) f)   instance HFunctor ((:+:) f)-deriving via (WrappedHBifunctor Product f) instance HFunctor (Product f)-deriving via (WrappedHBifunctor Sum f)     instance HFunctor (Sum f)-deriving via (WrappedHBifunctor Joker f)   instance HFunctor (Joker f)-deriving via (WrappedHBifunctor These1 f)  instance HFunctor (These1 f)-deriving via (WrappedHBifunctor Void3 f)   instance HFunctor (Void3 f)-deriving via (WrappedHBifunctor Comp f)    instance HFunctor (Comp f)+deriving via (WrappedHBifunctor Day f)      instance HFunctor (Day f)+deriving via (WrappedHBifunctor ID.Day f)   instance HFunctor (ID.Day f)+deriving via (WrappedHBifunctor IN.Night f) instance HFunctor (IN.Night f)+deriving via (WrappedHBifunctor (:*:) f)    instance HFunctor ((:*:) f)+deriving via (WrappedHBifunctor (:+:) f)    instance HFunctor ((:+:) f)+deriving via (WrappedHBifunctor Product f)  instance HFunctor (Product f)+deriving via (WrappedHBifunctor Sum f)      instance HFunctor (Sum f)+deriving via (WrappedHBifunctor Joker f)    instance HFunctor (Joker f)+deriving via (WrappedHBifunctor These1 f)   instance HFunctor (These1 f)+deriving via (WrappedHBifunctor Void3 f)    instance HFunctor (Void3 f)+deriving via (WrappedHBifunctor Comp f)     instance HFunctor (Comp f)

@@ -0,0 +1,481 @@+-- |+-- Module      : Data.HFunctor.Route+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- This module contains the useful combinators 'Pre' and 'Post', which+-- enhances a functor with a "route" to and from the outside world; even if+-- the functor itself is existentially closed in a functor combinator, the+-- route will provide line to the outside world for extraction or+-- injection.+--+-- See 'Pre' and 'Post' for more information.+--+-- @since 0.3.4.0+module Data.HFunctor.Route (+  -- * Routing Combinators+  -- ** Contravariant+    Pre(..)+  , interpretPre, getPre, retractPre+  , injectPre, mapPre+  , preDivisible, preDivise, preContravariant+  -- ** Covariant+  , Post(..)+  , interpretPost, getPost, retractPost+  , injectPost, mapPost+  , postPlus, postAlt, postFunctor+  -- * Wrapped Invariant+  -- ** Contravariant+  , PreT(..)+  , preDivisibleT, preDiviseT, preContravariantT+  -- ** Covariant+  , PostT(..)+  , postPlusT, postAltT, postFunctorT+  ) where++import           Control.Natural+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Invariant+import           Data.Functor.Plus+import           Data.HFunctor+import           Data.HFunctor.Interpret+import           Data.Profunctor+import           Data.Void++-- | A useful helper type to use with a covariant functor combinator that+-- allows you to tag along contravariant access to all @f@s inside the+-- combinator.+--+-- Maybe most usefully, it can be used with 'Ap'.  Remember that @'Ap' f a@+-- is a collection of @f x@s, with each x existentially wrapped.  Now, for+-- a @'Ap' (Pre a f) a@, it will be a collection of @f x@ and @a -> x@s:+-- not only each individual part, but a way to "select" that individual+-- part from the overal @a@.+--+-- So, you can imagine @'Ap' ('Pre' a f) b@ as a collection of @f x@ that+-- consumes @a@ and produces @b@.+--+-- When @a@ and @b@ are the same, @'Ap' ('Pre' a f) a@ is like the free+-- invariant sequencer.  That is, in a sense, @'Ap' ('Pre' a f) a@ contains+-- both contravariant and covariant sequences side-by-side, /consuming/+-- @a@s and also /producing/ @a@s.+--+-- You can build up these values with 'injectPre', and then use whatever+-- typeclasses your @t@ normally supports to build it up, like+-- 'Applicative' (for 'Ap').  You can then interpret it into both its+-- contravariant and covariant contexts:+--+-- @+-- -- interpret the covariant part+-- runCovariant :: 'Applicative' g => (f ~> g) -> Ap (Pre a f) a -> g a+-- runCovariant f = interpret (f . getPre)+--+-- -- interpret the contravariant part+-- runContravariant :: 'Divisible' g => (f ~> g) -> Ap (Pre a f) a -> g a+-- runContravariant = preDivisible+-- @+--+-- The 'PreT' type wraps up @'Ap' ('Pre' a f) a@ into a type @'PreT' 'Ap'+-- f a@, with nice instances/helpers.+--+-- An example of a usage of this in the real world is the /unjson/+-- library's record type constructor, to implement bidrectional+-- serializers for product types.+data Pre  a f b = (a -> b) :>$<: f b+  deriving Functor+++-- | A useful helper type to use with a contravariant functor combinator that+-- allows you to tag along covariant access to all @f@s inside the+-- combinator.+--+-- Maybe most usefully, it can be used with 'Dec'.  Remember that @'Dec' f a@+-- is a collection of @f x@s, with each x existentially wrapped.  Now, for+-- a @'Dec' (Post a f) a@, it will be a collection of @f x@ and @x -> a@s:+-- not only each individual part, but a way to "re-embed" that individual+-- part into overal @a@.+--+-- So, you can imagine @'Dec' ('Post' a f) b@ as a collection of @f x@ that+-- consumes @b@ and produces @a@.+--+-- When @a@ and @b@ are the same, @'Dec' ('Post' a f) a@ is like the free+-- invariant sequencer.  That is, in a sense, @'Dec' ('Post' a f) a@ contains+-- both contravariant and covariant sequences side-by-side, /consuming/+-- @a@s and also /producing/ @a@s.+--+-- You can build up these values with 'injectPre', and then use whatever+-- typeclasses your @t@ normally supports to build it up, like+-- 'Conclude' (for 'Div').  You can then interpret it into both its+-- contravariant and covariant contexts:+--+-- @+-- -- interpret the covariant part+-- runCovariant :: 'Plus' g => (f ~> g) -> Div (Post a f) a -> g a+-- runCovariant f = interpret (f . getPost)+--+-- -- interpret the contravariant part+-- runContravariant :: 'Conclude' g => (f ~> g) -> Div (Post a f) a -> g a+-- runContravariant = preDivisible+-- @+--+-- The 'PostT' type wraps up @'Dec' ('Post' a f) a@ into a type @'PostT'+-- 'Dec'+-- f a@, with nice instances/helpers.+--+-- An example of a usage of this in the real world is a possible+-- implementation of the /unjson/ library's sum type constructor, to+-- implement bidrectional serializers for sum types.+data Post a f b = (b -> a) :<$>: f b++instance Contravariant f => Contravariant (Post a f) where+    contramap f (g :<$>: x) = g . f :<$>: contramap f x++infixl 4 :>$<:+infixl 4 :<$>:++-- | Turn the covariant functor combinator @t@ into an 'Invariant'+-- functor combinator; if @t f a@ "produces" @a@s, then @'PreT' t f a@ will+-- both consume and produce @a@s.+--+-- You can run this normally as if it were a @t f a@ by using 'interpret';+-- however, you can also interpret into covariant contexts with+-- 'preDivisibleT', 'preDiviseT', and 'preContravariantT'.+--+-- See 'Pre' for more information.+newtype PreT t f a = PreT { unPreT :: t (Pre a f) a }++instance (HFunctor t, forall x. Functor (t (Pre x f))) => Invariant (PreT t f) where+    invmap f g = PreT+               . hmap (mapPre g)+               . fmap f+               . unPreT++instance HFunctor t => HFunctor (PreT t) where+    hmap f = PreT . hmap (hmap f) . unPreT++instance Inject t => Inject (PreT t) where+    inject = PreT . inject . (id :>$<:)++instance Interpret t f => Interpret (PreT t) f where+    interpret f = interpret f . hmap getPre . unPreT++-- | Turn the contravariant functor combinator @t@ into an 'Invariant'+-- functor combinator; if @t f a@ "consumes" @a@s, then @'PostT' t f a@ will+-- both consume and produce @a@s.+--+-- You can run this normally as if it were a @t f a@ by using 'interpret';+-- however, you can also interpret into covariant contexts with+-- 'postPlusT', 'postAltT', and 'postFunctorT'.+--+-- See 'Post' for more information.+newtype PostT t f a = PostT { unPostT :: t (Post a f) a }++instance (HFunctor t, forall x. Contravariant (t (Post x f))) => Invariant (PostT t f) where+    invmap f g = PostT+               . hmap (mapPost f)+               . contramap g+               . unPostT++-- | Run a @'PreT' t@ into a contravariant 'Divisible' context.  To run it+-- in @t@s normal covariant context, use 'interpret'.+--+-- This will work for types where there are a possibly-empty collection of+-- @f@s, like:+--+-- @+-- preDivisibleT :: Divisible g => (f ~> g) -> PreT 'Ap'    f ~> g+-- preDivisibleT :: Divisible g => (f ~> g) -> PreT 'ListF' f ~> g+-- @+preDivisibleT+    :: (forall m. Monoid m => Interpret t (AltConst m), Divisible g)+    => (f ~> g)+    -> PreT t f ~> g+preDivisibleT f = preDivisible f . unPreT++-- | Run a @'PreT' t@ into a contravariant 'Divise' context.  To run it in+-- @t@s normal covariant context, use 'interpret'.+--+-- This will work for types where there is a non-empty collection of+-- @f@s, like:+--+-- @+-- preDiviseT :: Divise g => (f ~> g) -> PreT 'Ap1'       f ~> g+-- preDiviseT :: Divise g => (f ~> g) -> PreT 'NonEmptyF' f ~> g+-- @+preDiviseT+    :: (forall m. Semigroup m => Interpret t (AltConst m), Divise g)+    => (f ~> g)+    -> PreT t f ~> g+preDiviseT f = preDivise f . unPreT++-- | Run a @'PreT' t@ into a 'Contravariant'.  To run it in+-- @t@s normal covariant context, use 'interpret'.+--+-- This will work for types where there is exactly one @f@ inside:+--+-- @+-- preContravariantT :: Contravariant g => (f ~> g) -> PreT 'Step'     f ~> g+-- preContravariantT :: Contravariant g => (f ~> g) -> PreT 'Coyoneda' f ~> g+-- @+preContravariantT+    :: (forall m. Interpret t (AltConst m), Contravariant g)+    => (f ~> g)+    -> PreT t f ~> g+preContravariantT f = preContravariant f . unPreT++-- | Run a "pre-routed" @t@ into a contravariant 'Divisible' context.  To+-- run it in @t@s normal covariant context, use 'interpret' with 'getPre'.+--+-- This will work for types where there are a possibly-empty collection of+-- @f@s, like:+--+-- @+-- preDivisible :: Divisible g => (f ~> g) -> 'Ap'    ('Pre' a f) b -> g a+-- preDivisible :: Divisible g => (f ~> g) -> 'ListF' ('Pre' a f) b -> g a+-- @+preDivisible+    :: (forall m. Monoid m => Interpret t (AltConst m), Divisible g)+    => (f ~> g)+    -> t (Pre a f) b+    -> g a+preDivisible f = foldr (divide (\x -> (x,x))) conquer+               . icollect (interpretPre f)++-- | Run a "pre-routed" @t@ into a contravariant 'Divise' context.  To+-- run it in @t@s normal covariant context, use 'interpret' with 'getPre'.+--+-- This will work for types where there are is a non-empty collection of+-- @f@s, like:+--+-- @+-- preDivise :: Divise g => (f ~> g) -> 'Ap1'       ('Pre' a f) b -> g a+-- preDivise :: Divise g => (f ~> g) -> 'NonEmptyF' ('Pre' a f) b -> g a+-- @+preDivise+    :: (forall m. Semigroup m => Interpret t (AltConst m), Divise g)+    => (f ~> g)+    -> t (Pre a f) b+    -> g a+preDivise f = foldr1 (<:>) . icollect1 (interpretPre f)++-- | Run a "pre-routed" @t@ into a 'Contravariant'.  To run it in @t@s+-- normal covariant context, use 'interpret' with 'getPre'.+--+-- This will work for types where there is exactly one @f@ inside:+--+-- @+-- preContravariant :: Contravariant g => (f ~> g) -> 'Step'     ('Pre' a f) b -> g a+-- preContravariant :: Contravariant g => (f ~> g) -> 'Coyoneda' ('Pre' a f) b -> g a+-- @+preContravariant+    :: (forall m. Interpret t (AltConst m), Contravariant g)+    => (f ~> g)+    -> t (Pre a f) b+    -> g a+preContravariant f = iget (interpretPre f)++-- | Run a @'PostT' t@ into a covariant 'Plus' context.  To run it+-- in @t@s normal contravariant context, use 'interpret'.+--+-- This will work for types where there are a possibly-empty collection of+-- @f@s, like:+--+-- @+-- postPlusT :: Plus g => (f ~> g) -> PreT 'Dec' f ~> g+-- postPlusT :: Plus g => (f ~> g) -> PreT 'Div' f ~> g+-- @+postPlusT+    :: (forall m. Monoid m => Interpret t (AltConst m), Plus g)+    => (f ~> g)+    -> PostT t f ~> g+postPlusT f = postPlus f . unPostT++-- | Run a @'PostT' t@ into a covariant 'Alt' context.  To run it+-- in @t@s normal contravariant context, use 'interpret'.+--+-- This will work for types where there is a non-empty collection of+-- @f@s, like:+--+-- @+-- postAltT :: Alt g => (f ~> g) -> PreT 'Dec1' f ~> g+-- postAltT :: Alt g => (f ~> g) -> PreT 'Div1' f ~> g+-- @+postAltT+    :: (forall m. Semigroup m => Interpret t (AltConst m), Alt g)+    => (f ~> g)+    -> PostT t f ~> g+postAltT f = postAlt f . unPostT++-- | Run a @'PostT' t@ into a covariant 'Functor' context.  To run it+-- in @t@s normal contravariant context, use 'interpret'.+--+-- This will work for types where there is exactly one @f@ inside:+--+-- @+-- postFunctorT :: Functor g => (f ~> g) -> PreT 'Step' f ~> g+-- postFunctorT :: Functor g => (f ~> g) -> PreT 'CCY.Coyoneda' f ~> g+-- @+postFunctorT+    :: (forall m. Interpret t (AltConst m), Functor g)+    => (f ~> g)+    -> PostT t f ~> g+postFunctorT f = postFunctor f . unPostT++-- | Run a "post-routed" @t@ into a covariant 'Plus' context.  To run it+-- in @t@s normal contravariant context, use 'interpret'.+--+-- This will work for types where there are a possibly-empty collection of+-- @f@s, like:+--+-- @+-- postPlus :: Plus g => (f ~> g) -> 'Dec' (Post a f) b -> g a+-- postPlus :: Plus g => (f ~> g) -> 'Div' (Post a f) b -> g a+-- @+postPlus+    :: (forall m. Monoid m => Interpret t (AltConst m), Plus g)+    => (f ~> g)+    -> t (Post a f) b+    -> g a+postPlus f = foldr (<!>) zero . icollect (interpretPost f)++-- | Run a "post-routed" @t@ into a covariant 'Alt' context.  To run it+-- in @t@s normal contravariant context, use 'interpret'.+--+-- This will work for types where there are is a non-empty collection of+-- @f@s, like:+--+-- @+-- postAlt :: Alt g => (f ~> g) -> 'Dec1' (Post a f) b -> g a+-- postAlt :: Alt g => (f ~> g) -> 'Div1' (Post a f) b -> g a+-- @+postAlt+    :: (forall m. Semigroup m => Interpret t (AltConst m), Alt g)+    => (f ~> g)+    -> t (Post a f) b+    -> g a+postAlt f = foldr1 (<!>) . icollect1 (interpretPost f)++-- | Run a "post-routed" @t@ into a covariant 'Functor' context.  To run it+-- in @t@s normal contravariant context, use 'interpret'.+--+-- This will work for types where there is exactly one @f@ inside:+--+-- @+-- postFunctor :: Functor g => (f ~> g) -> 'Step'         (Post a f) b -> g a+-- postFunctor :: Functor g => (f ~> g) -> 'CCY.Coyoneda' (Post a f) b -> g a+-- @+postFunctor+    :: (forall m. Interpret t (AltConst m), Functor g)+    => (f ~> g)+    -> t (Post a f) b+    -> g a+postFunctor f = iget (interpretPost f)++-- | Contravariantly retract the @f@ out of a 'Pre', applying the+-- pre-routing function.  Not usually that useful because 'Pre' is meant to+-- be used with covariant 'Functor's.+retractPre :: Contravariant f => Pre a f b -> f a+retractPre (f :>$<: x) = contramap f x++-- | Interpret a 'Pre' into a contravariant context, applying the+-- pre-routing function.+interpretPre :: Contravariant g => (f ~> g) -> Pre a f b -> g a+interpretPre f (g :>$<: x) = contramap g (f x)++-- | Drop the pre-routing function and just give the original wrapped+-- value.+getPre :: Pre a f b -> f b+getPre (_ :>$<: x) = x++-- | Pre-compose on the pre-routing function.+mapPre :: (c -> a) -> Pre a f b -> Pre c f b+mapPre f (g :>$<: x) = g . f :>$<: x++-- | Like 'inject', but allowing you to provide a pre-routing function.+injectPre :: Inject t => (a -> b) -> f b -> t (Pre a f) b+injectPre f x = inject (f :>$<: x)++-- | Covariantly retract the @f@ out of a 'Post', applying the+-- post-routing function.  Not usually that useful because 'Post' is meant to+-- be used with contravariant 'Functor's.+retractPost :: Functor f => Post a f b -> f a+retractPost (f :<$>: x) = fmap f x++-- | Interpret a 'Post' into a covariant context, applying the+-- post-routing function.+interpretPost :: Functor g => (f ~> g) -> Post a f b -> g a+interpretPost f (g :<$>: x) = fmap g (f x)++-- | Drop the post-routing function and just give the original wrapped+-- value.+getPost :: Post a f b -> f b+getPost (_ :<$>: x) = x++-- | Post-compose on the post-routing function.+mapPost :: (a -> c) -> Post a f b -> Post c f b+mapPost f (g :<$>: x) = f  . g :<$>: x++-- | Like 'inject', but allowing you to provide a post-routing function.+injectPost :: Inject t => (b -> a) -> f b -> t (Post a f) b+injectPost f x = inject (f :<$>: x)++instance Functor f => Invariant (Post a f) where+    invmap f g (h :<$>: x) = h . g :<$>: fmap f x++instance Contravariant f => Invariant (Pre a f) where+    invmap f g (h :>$<: x) = f . h :>$<: contramap g x++instance HFunctor (Post a) where+    hmap g (f :<$>: x) = f :<$>: g x++instance HFunctor (Pre a) where+    hmap g (f :>$<: x) = f :>$<: g x++instance Monoid a => Inject (Post a) where+    inject x = const mempty :<$>: x++instance Monoid a => HBind (Post a) where+    hjoin (f :<$>: (g :<$>: x)) = (f <> g) :<$>: x++instance Monoid a => Interpret (Post a) f where+    retract (_ :<$>: x) = x++-- | This instance is over-contrained (@a@ only needs to be uninhabited),+-- but there is no commonly used "uninhabited" typeclass+instance (a ~ Void) => Inject (Pre a) where+    inject x = absurd :>$<: x++-- | This instance is over-contrained (@a@ only needs to be uninhabited),+-- but there is no commonly used "uninhabited" typeclass+instance (a ~ Void) => HBind (Pre a) where+    hjoin (_ :>$<: (_ :>$<: x)) = absurd :>$<: x++instance (a ~ Void) => Interpret (Pre a) f where+    retract (_ :>$<: x) = x++-- | If @t@ is a covariant functor combinator, then you applying it to+-- @'Pre' a f@ gives you a profunctor.+newtype ProPre t f a b = ProPre { unProPre :: t (Pre a f) b }++instance (HFunctor t, forall x. Functor (t (Pre x f))) => Profunctor (ProPre t f) where+    dimap f g = ProPre+              . hmap (mapPre f)+              . fmap g+              . unProPre++-- | If @t@ is a contravariant functor combinator, then you applying it to+-- @'Post' a f@ gives you a profunctor.+newtype ProPost t f a b = ProPost { unProPost :: t (Post b f) a }++instance (HFunctor t, forall x. Contravariant (t (Post x f))) => Profunctor (ProPost t f) where+    dimap f g = ProPost+              . hmap (mapPost g)+              . contramap f+              . unProPost+