functor-combinators 0.2.0.0 → 0.3.0.0

raw patch · 24 files changed

+2954/−94 lines, 24 filesdep +assocdep +contravariantdep +invariantdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: assoc, contravariant, invariant, sop-core

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +44/−0
• functor-combinators.cabal +16/−4
• src/Control/Applicative/ListF.hs +66/−4
• src/Control/Applicative/Step.hs +65/−2
• src/Data/Functor/Apply/Free.hs +5/−0
• src/Data/Functor/Combinator.hs +161/−0
• src/Data/Functor/Combinator/Unsafe.hs +42/−0
• src/Data/Functor/Contravariant/Conclude.hs +191/−0
• src/Data/Functor/Contravariant/Decide.hs +202/−0
• src/Data/Functor/Contravariant/Divise.hs +239/−0
• src/Data/Functor/Contravariant/Divisible/Free.hs +293/−0
• src/Data/Functor/Contravariant/Night.hs +132/−0
• src/Data/Functor/Invariant/Day.hs +468/−0
• src/Data/Functor/Invariant/Night.hs +407/−0
• src/Data/HBifunctor/Associative.hs +84/−13
• src/Data/HBifunctor/Tensor.hs +113/−18
• src/Data/HFunctor.hs +77/−6
• src/Data/HFunctor/Chain.hs +140/−11
• src/Data/HFunctor/Final.hs +112/−7
• src/Data/HFunctor/Internal.hs +38/−7
• src/Data/HFunctor/Interpret.hs +15/−6
• test/Tests/HBifunctor.hs +20/−12
• test/Tests/HFunctor.hs +12/−0
• test/Tests/Util.hs +12/−4

@@ -1,6 +1,47 @@ Changelog ========= +Version 0.3.0.0+---------------++*August 5, 2020*++<https://github.com/mstksg/functor-combinators/releases/tag/v0.3.0.0>++*   *Data.HBifunctor.Associative*, *Data.HBifunctor.Tensor*: Support for+    `Contravariant` and `Invariant` functor combinators. Main change to the+    infrastructure: add a `FunctorBy` associated constraint to `Associative` to+    signal what "sort of functor" the tensor supports: it should either be+    `Unconstrained`, `Functor`, `Contravariant`, or `Invariant`.+*   *Data.Functor.Contravariant.Divise*, *Data.Functor.Contravariant.Decide*,+    and *Data.Functor.Contravariant.Conclude*: Temporarily add in the+    semigroupoidal contravariant typeclasses. These should only be needed until+    they get merged into *semigroupoids*.+*   *Data.Functor.Contravariant.Divisible*: Add free structures for+    contravariant typeclass hierarchy.+*   Added in some new day convolutions:++    *   *Data.Functor.Contravariant.Night*: `Night`, a contravariant day+        convolution using `Either`, which is the tensor that generates+        `Conclude` (and `Decidable` kinda).+    *   *Data.Functor.Invariant.Day*: `Day`, an *invariant* day convolution+        using tuples.+    *   *Data.Functor.Invariant.Night*: `Night`, an *invariant* day convolution+        using either.++    For the invariant day convolutions, we *could* write free monoids on them+    (like `Ap`/`Div`/`Dec`).  But instead we just outsource our free structures+    to `Chain`, providing useful pattern synonyms and folding functions to+    pretend like we had an actual free structure.+*   *Data.Functor.Combinator*: Useful functions in for working with divisible+    and decidable contravariant functors: `divideN`, `diviseN`, `concludeN`,+    `decideN`, `divideNRec`, and `diviseNRec`.+*   `Contravariant` and `Invariant` instances for many types.+*   *Data.HFunctor.Final*: `FreeOf` adjusted to allow for contravariant free+    types.+*   *Data.Functor.Combinator.Unsafe*: Add `unsafeDivise` and `unsafeConclude`,+    to mirror the situation with `unsafeApply` and `unsafePlus`.+ Version 0.2.0.0 --------------- @@ -22,6 +63,9 @@     *   `SF`, `MF` are now `NonEmptyBy` and `ListBy`, respectively.     *   `-SF` and `-MF` as suffixes for function names now become `-NE` and         `-LB`.++*   `upgradeC` no longer exists; use unsafe functions from+    *Data.Functor.Combinator.Unsafe* instead, on a per-tensor basis.  *   Restructuring of `Interpret`: It now takes an extra type parameter, the     type to interpret into.  This makes it more consistent with the new `MonoidIn`

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack ----- hash: 6adc855dec7f54345b5714740988109de58bf4e1fc0b788594bb77e11f29974e+-- hash: f15c50b5510d900bedb796a057cf16600ffce2bd338dba4daa4015f54400bc18  name:           functor-combinators-version:        0.2.0.0+version:        0.3.0.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"@@ -54,6 +54,13 @@       Data.Functor.Apply.Free       Data.Functor.Combinator       Data.Functor.Combinator.Unsafe+      Data.Functor.Contravariant.Conclude+      Data.Functor.Contravariant.Decide+      Data.Functor.Contravariant.Divise+      Data.Functor.Contravariant.Divisible.Free+      Data.Functor.Contravariant.Night+      Data.Functor.Invariant.Day+      Data.Functor.Invariant.Night       Data.HBifunctor       Data.HBifunctor.Associative       Data.HBifunctor.Tensor@@ -68,13 +75,16 @@   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   ghc-options: -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns   build-depends:-      base >=4.12 && <5+      assoc+    , base >=4.12 && <5     , bifunctors     , comonad     , constraints     , containers+    , contravariant     , deriving-compat     , free+    , invariant     , kan-extensions     , mmorph     , mtl@@ -83,6 +93,7 @@     , pointed     , profunctors     , semigroupoids+    , sop-core     , tagged     , these     , transformers@@ -114,4 +125,5 @@     , tasty     , tasty-hedgehog     , transformers+    , trivial-constraint >=0.5   default-language: Haskell2010

@@ -36,20 +36,29 @@ import           Data.Foldable import           Data.Functor.Bind import           Data.Functor.Classes+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Invariant import           Data.Functor.Plus-import           Data.List.NonEmpty         (NonEmpty(..))+import           Data.List.NonEmpty                   (NonEmpty(..)) import           Data.Maybe import           Data.Pointed import           Data.Semigroup.Foldable import           Data.Semigroup.Traversable import           GHC.Generics-import qualified Data.Map                   as M-import qualified Data.Map.NonEmpty          as NEM+import qualified Data.Map                             as M+import qualified Data.Map.NonEmpty                    as NEM  -- | A list of @f a@s.  Can be used to describe a product of many different -- values of type @f a@. -- -- This is the Free 'Plus'.+--+-- Incidentally, if used with a 'Contravariant' @f@, this is instead the+-- free 'Divisible'. newtype ListF f a = ListF { runListF :: [f a] }   deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) @@ -83,6 +92,40 @@ instance Pointed f => Pointed (ListF f) where     point = ListF . (: []) . point +-- | @since 0.3.0.0+instance Contravariant f => Contravariant (ListF f) where+    contramap f (ListF xs) = ListF ((map . contramap) f xs)++-- | @since 0.3.0.0+instance Invariant f => Invariant (ListF f) where+    invmap f g (ListF xs) = ListF (map (invmap f g) xs)++-- | @since 0.3.0.0+instance Contravariant f => Divise (ListF f) where+    divise f (ListF xs) (ListF ys) = ListF $+         (map . contramap) (fst . f) xs+      <> (map . contramap) (snd . f) ys++-- | @since 0.3.0.0+instance Contravariant f => Divisible (ListF f) where+    divide  = divise+    conquer = ListF []++-- | @since 0.3.0.0+instance Decide f => Decide (ListF f) where+    decide f (ListF xs) (ListF ys) = ListF $+        liftA2 (decide f) xs ys++-- | @since 0.3.0.0+instance Conclude f => Conclude (ListF f) where+    conclude f = ListF [conclude f]++-- | @since 0.3.0.0+instance Decidable f => Decidable (ListF f) where+    lose f = ListF [lose f]+    choose f (ListF xs) (ListF ys) = ListF $+        liftA2 (choose f) xs ys+ -- | Map a function over the inside of a 'ListF'. mapListF     :: ([f a] -> [g b])@@ -104,7 +147,10 @@ --   :+: ...                        -- etc. -- @ ----- This is the Free 'Plus'.+-- This is the Free 'Plus' on any 'Functor' @f@.+--+-- Incidentally, if used with a 'Contravariant' @f@, this is instead the+-- free 'Divise'. newtype NonEmptyF f a = NonEmptyF { runNonEmptyF :: NonEmpty (f a) }   deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Typeable, Generic, Data) @@ -119,6 +165,22 @@  instance Functor f => Alt (NonEmptyF f) where     (<!>) = (<>)++-- | @since 0.3.0.0+instance Contravariant f => Contravariant (NonEmptyF f) where+    contramap f (NonEmptyF xs) = NonEmptyF (fmap (contramap f) xs)+-- | @since 0.3.0.0+instance Invariant f => Invariant (NonEmptyF f) where+    invmap f g (NonEmptyF xs) = NonEmptyF (fmap (invmap f g) xs)+-- | @since 0.3.0.0+instance Contravariant f => Divise (NonEmptyF f) where+    divise f (NonEmptyF xs) (NonEmptyF ys) = NonEmptyF $+         (fmap . contramap) (fst . f) xs+      <> (fmap . contramap) (snd . f) ys+-- | @since 0.3.0.0+instance Decide f => Decide (NonEmptyF f) where+    decide f (NonEmptyF xs) (NonEmptyF ys) = NonEmptyF $+      decide f <$> xs <*> ys  instance Semigroup (NonEmptyF f a) where     NonEmptyF xs <> NonEmptyF ys = NonEmptyF (xs <> ys)

@@ -41,8 +41,14 @@ import           Data.Deriving import           Data.Functor.Alt import           Data.Functor.Bind+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Invariant import           Data.Functor.These-import           Data.Map.NonEmpty          (NEMap)+import           Data.Map.NonEmpty                    (NEMap) import           Data.Pointed import           Data.Semigroup import           Data.Semigroup.Foldable@@ -50,7 +56,7 @@ import           Data.These import           GHC.Generics import           GHC.Natural-import qualified Data.Map.NonEmpty          as NEM+import qualified Data.Map.NonEmpty                    as NEM  -- | An @f a@, along with a 'Natural' index. --@@ -81,10 +87,41 @@ deriveEq1 ''Step deriveOrd1 ''Step +-- | @since 0.3.0.0+instance Apply f => Apply (Step f) where+    Step n f <.> Step m x = Step (n + m) (f <.> x)+ instance Applicative f => Applicative (Step f) where     pure = Step 0 . pure     Step n f <*> Step m x = Step (n + m) (f <*> x) +-- | @since 0.3.0.0+instance Contravariant f => Contravariant (Step f) where+    contramap f (Step x y) = Step x (contramap f y)++-- | @since 0.3.0.0+instance Divisible f => Divisible (Step f) where+    divide f (Step n x) (Step m y) = Step (n + m) (divide f x y)+    conquer = Step 0 conquer+-- | @since 0.3.0.0+instance Divise f => Divise (Step f) where+    divise f (Step n x) (Step m y) = Step (n + m) (divise f x y)++-- | @since 0.3.0.0+instance Decide f => Decide (Step f) where+    decide f (Step n x) (Step m y) = Step (n + m) (decide f x y)+-- | @since 0.3.0.0+instance Conclude f => Conclude (Step f) where+    conclude = Step 0 . conclude+-- | @since 0.3.0.0+instance Decidable f => Decidable (Step f) where+    choose f (Step n x) (Step m y) = Step (n + m) (choose f x y)+    lose = Step 0 . lose++-- | @since 0.3.0.0+instance Invariant f => Invariant (Step f) where+    invmap f g (Step x y) = Step x (invmap f g y)+ instance Pointed f => Pointed (Step f) where     point = Step 0 . point @@ -217,6 +254,18 @@       let (k, _) = NEM.findMax xs       in  xs <> NEM.mapKeysMonotonic (+ (k + 1)) ys +-- | @since 0.3.0.0+instance Contravariant f => Contravariant (Steps f) where+    contramap f (Steps xs) = Steps ((fmap . contramap) f xs)++-- TODO: consider what Divisible/Decidable should be.  Maybe no need to+-- rush into this.++-- | @since 0.3.0.0+instance Invariant f => Invariant (Steps f) where+    invmap f g (Steps xs) = Steps (fmap (invmap f g) xs)++ -- | Left-biased untion instance Functor f => Alt (Steps f) where     Steps xs <!> Steps ys = Steps $ NEM.union xs ys@@ -379,6 +428,13 @@ instance Apply (Void2 a) where     x <.> _ = case x of {} +-- | @since 0.3.0.0+instance Contravariant (Void2 a) where+    contramap _ = \case {}+-- | @since 0.3.0.0+instance Invariant (Void2 a) where+    invmap _ _ = \case {}+ -- | If you treat a @'Void2' f a@ as a functor combinator, then 'absurd2' -- lets you convert from a @'Void2' f a@ into a @t f a@ for any functor -- combinator @t@.@@ -405,6 +461,13 @@  instance Apply (Void3 a b) where     x <.> _ = case x of {}++-- | @since 0.3.0.0+instance Contravariant (Void3 a b) where+    contramap _ = \case {}+-- | @since 0.3.0.0+instance Invariant (Void3 a b) where+    invmap _ _ = \case {}  -- | If you treat a @'Void3' f a@ as a binary functor combinator, then -- 'absurd3' lets you convert from a @'Void3' f a@ into a @t f a@ for any

@@ -26,6 +26,7 @@ import           Data.Functor.Apply import           Data.Functor.Day import           Data.Functor.Identity+import           Data.Functor.Invariant import           Data.HFunctor import           Data.HFunctor.Interpret import           Data.Kind@@ -68,6 +69,10 @@ fromAp = \case     Pure x  -> L1 $ Identity x     Ap x xs -> R1 $ Ap1 x xs++-- | @since 0.3.0.0+instance Invariant (Ap1 f) where+    invmap f _ = fmap f  -- | An @'Ap1' f@ is just a @'Day' f ('Ap' f)@.  This bidirectional pattern -- synonym lets you treat it as such.

@@ -104,6 +104,13 @@   -- ** Natural Transformations   , generalize   , absorb+  -- ** Divisible+  , divideN+  , diviseN+  , concludeN+  , decideN+  , divideNRec+  , diviseNRec   ) where  import           Control.Alternative.Free@@ -119,6 +126,11 @@ import           Control.Natural import           Control.Natural.IsoF import           Data.Functor.Apply.Free+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible import           Data.Functor.Coyoneda import           Data.Functor.Day import           Data.Functor.These@@ -130,3 +142,152 @@ import           Data.HFunctor.Internal import           Data.HFunctor.Interpret import           GHC.Generics++import qualified Data.SOP           as SOP+import qualified Data.Vinyl         as V+import qualified Data.Vinyl.Functor as V+++-- | Convenient helper function to build up a 'Divisible' by providing+-- each component of it.  This makes it much easier to build up longer+-- chains as opposed to nested calls to 'divide' and manually peeling off+-- tuples one-by-one.+--+-- For example, if you had a data type+--+-- @+-- data MyType = MT Int Bool String+-- @+--+-- and a contravariant consumer @Builder@ (representing, say, a way to+-- serialize an item, where @intBuilder :: Builder Int@ is a serializer of+-- 'Int's), then you could assemble a serializer a @MyType@ using:+--+-- @+-- contramap (\(MyType x y z) -> I x :* I y :* I z :* Nil) $+--   divideN $ intBuilderj+--          :* boolBuilder+--          :* stringBuilder+--          :* Nil+-- @+--+-- @since 0.3.0.0+divideN+    :: Divisible f+    => SOP.NP f as+    -> f (SOP.NP SOP.I as)+divideN = \case+    SOP.Nil     -> conquer+    x SOP.:* xs -> divide+      (\case SOP.I y SOP.:* ys -> (y, ys))+      x+      (divideN xs)++-- | A version of 'divideN' defined to work with 'V.XRec', which can+-- syntactically cleaner because you don't have to manually wrap/unwrap+-- 'SOP.I's.+--+-- Using the example for 'divideN':+--+-- @+-- data MyType = MT Int Bool String+--+-- contramap (\(MyType x y z) -> x ::& y ::& z ::& Nil) $+--   divideNRec $ intBuilderj+--             :& boolBuilder+--             :& stringBuilder+--             :& RNil+-- @+--+-- @since 0.3.0.0+divideNRec+    :: Divisible f+    => V.Rec f as+    -> f (V.XRec V.Identity as)+divideNRec = \case+    V.RNil    -> conquer+    x V.:& xs -> divide+      (\case z V.::& zs -> (z, zs))+      x+      (divideNRec xs)++-- | A version of 'divideNRec' that works for non-empty records, and so only+-- requires a 'Divise' constraint.+--+-- @since 0.3.0.0+diviseNRec+    :: Divise f+    => V.Rec f (a ': as)+    -> f (V.XRec V.Identity (a ': as))+diviseNRec = \case+    x V.:& xs -> case xs of+      V.RNil   -> contramap (\case z V.::& _ -> z) x+      _ V.:& _ -> divise+        (\case z V.::& zs -> (z,zs))+        x+        (diviseNRec xs)++-- | A version of 'divideN' that works for non-empty 'SOP.NP', and so only+-- requires a 'Divise' constraint.+diviseN+    :: Divise f+    => SOP.NP f (a ': as)+    -> f (SOP.NP SOP.I (a ': as))+diviseN = \case+    x SOP.:* xs -> case xs of+      SOP.Nil    -> contramap (SOP.unI . SOP.hd) x+      _ SOP.:* _ -> divise+        (\case SOP.I z SOP.:* zs -> (z, zs))+        x+        (diviseN xs)++-- | Convenient helper function to build up a 'Conclude' by providing+-- each component of it.  This makes it much easier to build up longer+-- chains as opposed to nested calls to 'decide' and manually peeling off+-- eithers one-by-one.+--+-- For example, if you had a data type+--+-- @+-- data MyType = MTI Int | MTB Bool | MTS String+-- @+--+-- and a contravariant consumer @Builder@ (representing, say, a way to+-- serialize an item, where @intBuilder :: Builder Int@ is a serializer of+-- 'Int's), then you could assemble a serializer a @MyType@ using:+--+-- @+-- contramap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z)))) $+--   concludeN $ intBuilder+--            :* boolBuilder+--            :* stringBuilder+--            :* Nil+-- @+--+-- @since 0.3.0.0+concludeN+    :: Conclude f+    => SOP.NP f as+    -> f (SOP.NS SOP.I as)+concludeN = \case+    SOP.Nil     -> conclude (\case {})+    x SOP.:* xs -> decide+      (\case SOP.Z y  -> Left (SOP.unI y); SOP.S ys -> Right ys)+      x+      (concludeN xs)++-- | A version of 'concludeN' that works for non-empty 'SOP.NP'/'SOP.NS',+-- and so only requires a 'Decide' constraint.+--+-- @since 0.3.0.0+decideN+    :: Decide f+    => SOP.NP f (a ': as)+    -> f (SOP.NS SOP.I (a ': as))+decideN = \case+    x SOP.:* xs -> case xs of+      SOP.Nil    -> contramap (SOP.unI . SOP.unZ) x+      _ SOP.:* _ -> decide+        (\case SOP.Z z -> Left (SOP.unI z); SOP.S zs -> Right zs)+        x+        (decideN xs)

@@ -24,12 +24,17 @@   , unsafeApply   , unsafeBind   , unsafePointed+  , unsafeConclude+  , unsafeDivise   ) where  import           Control.Applicative import           Data.Constraint import           Data.Constraint.Unsafe import           Data.Functor.Bind+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible import           Data.Functor.Plus import           Data.Pointed @@ -100,5 +105,42 @@ -- \@MyFunctor@. unsafePointed :: forall f proxy r. Applicative f => proxy f -> (Pointed f => r) -> r unsafePointed _ x = case unsafeCoerceConstraint @(Pointed (PointMe f)) @(Pointed f) of+    Sub Dict -> x++-- | For any @'Decidable' f@, produce a value that would require @'Conclude'+-- f@.+--+-- Always use with concrete and specific @f@ only, and never use with any+-- @f@ that already has a 'Conclude' instance.+--+-- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example+-- usages.+--+-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@+-- you want to enhance.  You can pass in something like @'Data.Proxy.Proxy'+-- \@MyFunctor@.+--+-- @since 0.3.0.0+unsafeConclude :: forall f proxy r. Decidable f => proxy f -> (Conclude f => r) -> r+unsafeConclude _ x = case unsafeCoerceConstraint @(Conclude (WrappedDivisible f)) @(Conclude f) of+    Sub Dict -> x+++-- | For any @'Divisible' f@, produce a value that would require @'Divise'+-- f@.+--+-- Always use with concrete and specific @f@ only, and never use with any+-- @f@ that already has a 'Divise' instance.+--+-- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example+-- usages.+--+-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@+-- you want to enhance.  You can pass in something like @'Data.Proxy.Proxy'+-- \@MyFunctor@.+--+-- @since 0.3.0.0+unsafeDivise :: forall f proxy r. Divisible f => proxy f -> (Divise f => r) -> r+unsafeDivise _ x = case unsafeCoerceConstraint @(Divise (WrappedDivisible f)) @(Divise f) of     Sub Dict -> x 

@@ -0,0 +1,191 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE TypeOperators        #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++-- |+-- Module      : Data.Functor.Contravariant.Conclude+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- The contravariant counterpart of 'Data.Functor.Plus': like 'Decidable',+-- but without needing a 'Divisible' constraint.  This is only a part of+-- this library currently for compatibility, until it is (hopefully) merged+-- into /semigroupoids/.+--+-- @since 0.3.0.0+module Data.Functor.Contravariant.Conclude (+    Conclude(..)+  , concluded+  ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Decide+import Data.Functor.Contravariant.Divise+import Data.Functor.Contravariant.Divisible+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Void++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#else+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++-- | The contravariant analogue of 'Plus'.  Adds on to 'Decide' the ability+-- to express a combinator that rejects all input, to act as the dead-end.+-- Essentially 'Decidable' without a superclass constraint on 'Divisible'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'conclude' defines+-- a consumer that cannot ever receive /any/ input.+--+-- Conclude acts as an identity with 'decide', because any decision that+-- involves 'conclude' must necessarily /always/ pick the other option.+--+-- That is, for, say,+--+-- @+-- 'decide' f x 'concluded'+-- @+--+-- @f@ is the deciding function that picks which of the inputs of @decide@+-- to direct input to; in the situation above, @f@ must /always/ direct all+-- input to @x@, and never 'concluded'.+--+-- Mathematically, a functor being an instance of 'Decide' means that it is+-- "monoidal" with respect to the contravariant "either-based" Day+-- convolution described in the documentation of 'Decide'.  On top of+-- 'Decide', it adds a way to construct an "identity" @conclude@ where+-- @decide f x (conclude q) == x@, and @decide g (conclude r) y == y@.+class Decide f => Conclude f where+    -- | The consumer that cannot ever receive /any/ input.+    conclude :: (a -> Void) -> f a++-- | A potentially more meaningful form of 'conclude', the consumer that cannot+-- ever receive /any/ input.  That is because it expects only input of type+-- 'Void', but such a type has no values.+--+-- @+-- 'concluded' = 'conclude' 'id'+-- @+concluded :: Conclude f => f Void+concluded = conclude id++instance Decidable f => Conclude (WrappedDivisible f) where+    conclude f = WrapDivisible (lose f)++instance Conclude Comparison where conclude = lose+instance Conclude Equivalence where conclude = lose+instance Conclude Predicate where conclude = lose+instance Conclude (Op r) where+  conclude f = Op $ absurd . f++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+instance Conclude Proxy where conclude = lose+#endif++#ifdef MIN_VERSION_StateVar+instance Conclude SettableStateVar where conclude = lose+#endif++#if MIN_VERSION_base(4,8,0)+instance Conclude f => Conclude (Alt f) where+  conclude = Alt . conclude+#endif++#ifdef GHC_GENERICS+instance Conclude U1 where conclude = lose++instance Conclude f => Conclude (Rec1 f) where+  conclude = Rec1 . conclude++instance Conclude f => Conclude (M1 i c f) where+  conclude = M1 . conclude++instance (Conclude f, Conclude g) => Conclude (f :*: g) where+  conclude f = conclude f :*: conclude f++instance (Apply f, Applicative f, Conclude g) => Conclude (f :.: g) where+  conclude = Comp1 . pure . conclude+#endif++instance Conclude f => Conclude (Backwards f) where+  conclude = Backwards . conclude++instance Conclude f => Conclude (IdentityT f) where+  conclude = IdentityT . conclude++instance Conclude m => Conclude (ReaderT r m) where+  conclude f = ReaderT $ \_ -> conclude f++instance Conclude m => Conclude (Lazy.RWST r w s m) where+  conclude f = Lazy.RWST $ \_ _ -> contramap (\ ~(a, _, _) -> a) (conclude f)++instance Conclude m => Conclude (Strict.RWST r w s m) where+  conclude f = Strict.RWST $ \_ _ -> contramap (\(a, _, _) -> a) (conclude f)++instance (Divisible m, Divise m) => Conclude (ListT m) where+  conclude _ = ListT conquer++instance (Divisible m, Divise m) => Conclude (MaybeT m) where+  conclude _ = MaybeT conquer++instance Conclude m => Conclude (Lazy.StateT s m) where+  conclude f = Lazy.StateT $ \_ -> contramap lazyFst (conclude f)++instance Conclude m => Conclude (Strict.StateT s m) where+  conclude f = Strict.StateT $ \_ -> contramap fst (conclude f)++instance Conclude m => Conclude (Lazy.WriterT w m) where+  conclude f = Lazy.WriterT $ contramap lazyFst (conclude f)++instance Conclude m => Conclude (Strict.WriterT w m) where+  conclude f = Strict.WriterT $ contramap fst (conclude f)++instance (Apply f, Applicative f, Conclude g) => Conclude (Compose f g) where+  conclude = Compose . pure . conclude++instance (Conclude f, Conclude g) => Conclude (Product f g) where+  conclude f = Pair (conclude f) (conclude f)++instance Conclude f => Conclude (Reverse f) where+  conclude = Reverse . conclude++lazyFst :: (a, b) -> a+lazyFst ~(a, _) = a+

@@ -0,0 +1,202 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE TypeOperators        #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++-- |+-- Module      : Data.Functor.Contravariant.Decide+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- The contravariant counterpart of 'Alt': like 'Decidable', but without+-- 'Data.Functor.Contravariant.Divisible.loss' or a superclass constraint+-- on 'Divisible'.  This is only a part of this library currently for+-- compatibility, until it is (hopefully) merged into /semigroupoids/.+--+-- @since 0.3.0.0+module Data.Functor.Contravariant.Decide (+    Decide(..)+  , decided+  ) where++import Control.Applicative.Backwards+import Control.Arrow+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Either+import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divise+import Data.Functor.Contravariant.Divisible+import Data.Functor.Product+import Data.Functor.Reverse++#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#else+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++-- | The contravariant analogue of 'Alt'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'decide' allows one+-- to handle the consumption of a value by choosing to handle it via+-- exactly one of two independent consumers.  It redirects the input+-- completely into one of two consumers.+--+-- 'decide' takes the "decision" method and the two potential consumers,+-- and returns the wrapped/combined consumer.+--+-- Mathematically, a functor being an instance of 'Decide' means that it is+-- "semgroupoidal" with respect to the contravariant "either-based" Day+-- convolution (@data EitherDay f g a = forall b c. EitherDay (f b) (g c) (a -> Either b c)@).+-- That is, it is possible to define a function @(f `EitherDay` f) a ->+-- f a@ in a way that is associative.+class Contravariant f => Decide f where+    -- | Takes the "decision" method and the two potential consumers, and+    -- returns the wrapped/combined consumer.+    decide :: (a -> Either b c) -> f b -> f c -> f a++-- | For @'decided' x y@, the resulting @f ('Either' b c)@ will direct+-- 'Left's to be consumed by @x@, and 'Right's to be consumed by y.+decided :: Decide f => f b -> f c -> f (Either b c)+decided = decide id++instance Decidable f => Decide (WrappedDivisible f) where+    decide f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (choose f x y)++instance Decide Comparison where decide = choose+instance Decide Equivalence where decide = choose+instance Decide Predicate where decide = choose++-- | Unlike 'Decidable', requires no constraint on @r@+instance Decide (Op r) where+  decide f (Op g) (Op h) = Op $ either g h . f++#if MIN_VERSION_base(4,8,0)+instance Decide f => Decide (Alt f) where+  decide f (Alt l) (Alt r) = Alt $ decide f l r+#endif++#ifdef GHC_GENERICS+instance Decide U1 where decide = choose+instance Decide V1 where decide _ = \case {}++instance Decide f => Decide (Rec1 f) where+  decide f (Rec1 l) (Rec1 r) = Rec1 $ decide f l r++instance Decide f => Decide (M1 i c f) where+  decide f (M1 l) (M1 r) = M1 $ decide f l r++instance (Decide f, Decide g) => Decide (f :*: g) where+  decide f (l1 :*: r1) (l2 :*: r2) = decide f l1 l2 :*: decide f r1 r2++-- | Unlike 'Decidable', requires only 'Apply' on @f@.+instance (Apply f, Decide g) => Decide (f :.: g) where+  decide f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (decide f) l r)+#endif++instance Decide f => Decide (Backwards f) where+  decide f (Backwards l) (Backwards r) = Backwards $ decide f l r++instance Decide f => Decide (IdentityT f) where+  decide f (IdentityT l) (IdentityT r) = IdentityT $ decide f l r++instance Decide m => Decide (ReaderT r m) where+  decide abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> decide abc (rmb r) (rmc r)++instance Decide m => Decide (Lazy.RWST r w s m) where+  decide abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+    decide (\ ~(a, s', w) -> either (Left  . betuple3 s' w)+                                    (Right . betuple3 s' w)+                                    (abc a))+           (rsmb r s) (rsmc r s)++instance Decide m => Decide (Strict.RWST r w s m) where+  decide abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+    decide (\(a, s', w) -> either (Left  . betuple3 s' w)+                                  (Right . betuple3 s' w)+                                  (abc a))+           (rsmb r s) (rsmc r s)++instance Divise m => Decide (ListT m) where+  decide f (ListT l) (ListT r) = ListT $ divise ((lefts &&& rights) . map f) l r++instance Divise m => Decide (MaybeT m) where+  decide f (MaybeT l) (MaybeT r) = MaybeT $+    divise ( maybe (Nothing, Nothing)+                   (either (\b -> (Just b, Nothing))+                           (\c -> (Nothing, Just c)) . f)+           ) l r++instance Decide m => Decide (Lazy.StateT s m) where+  decide f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+    decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+           (l s) (r s)++instance Decide m => Decide (Strict.StateT s m) where+  decide f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+    decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a))+           (l s) (r s)++instance Decide m => Decide (Lazy.WriterT w m) where+  decide f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+    decide (\ ~(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++instance Decide m => Decide (Strict.WriterT w m) where+  decide f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+    decide (\(a, s') -> either (Left . betuple s') (Right . betuple s') (f a)) l r++-- | Unlike 'Decidable', requires only 'Apply' on @f@.+instance (Apply f, Decide g) => Decide (Compose f g) where+  decide f (Compose l) (Compose r) = Compose (liftF2 (decide f) l r)++instance (Decide f, Decide g) => Decide (Product f g) where+  decide f (Pair l1 r1) (Pair l2 r2) = Pair (decide f l1 l2) (decide f r1 r2)++instance Decide f => Decide (Reverse f) where+  decide f (Reverse l) (Reverse r) = Reverse $ decide f l r++betuple :: s -> a -> (a, s)+betuple s a = (a, s)++betuple3 :: s -> w -> a -> (a, s, w)+betuple3 s w a = (a, s, w)++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+instance Decide Proxy where+  decide _ Proxy Proxy = Proxy+#endif++#ifdef MIN_VERSION_StateVar+instance Decide SettableStateVar where+  decide k (SettableStateVar l) (SettableStateVar r) = SettableStateVar $ \ a -> case k a of+    Left b -> l b+    Right c -> r c+#endif

@@ -0,0 +1,239 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE TypeOperators        #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++-- |+-- Module      : Data.Functor.Contravariant.Divise+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- The contravariant counterpart of 'Apply': like 'Divisible', but without+-- 'conquer'.  This is only a part of this library currently for+-- compatibility, until it is (hopefully) merged into /semigroupoids/.+--+-- @since 0.3.0.0+module Data.Functor.Contravariant.Divise (+    Divise(..)+  , divised+  , WrappedDivisible(..)+  ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Arrow+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict++import Data.Functor.Apply+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Data.Functor.Product+import Data.Functor.Reverse++#if MIN_VERSION_base(4,8,0)+import Data.Monoid (Alt(..))+#else+import Data.Monoid (Monoid(..))+#endif++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,12,0)+import Data.Semigroup (Semigroup(..))+#endif++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+import Data.Proxy+#endif++#ifdef MIN_VERSION_StateVar+import Data.StateVar+#endif++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++-- | The contravariant analogue of 'Apply'; it is+-- 'Divisible' without 'conquer'.+--+-- If one thinks of @f a@ as a consumer of @a@s, then 'divise' allows one+-- to handle the consumption of a value by splitting it between two+-- consumers that consume separate parts of @a@.+--+-- 'divise' takes the "splitting" method and the two sub-consumers, and+-- returns the wrapped/combined consumer.+--+-- All instances of 'Divisible' should be instances of 'Divise' with+-- @'divise' = 'divide'@.+--+-- The guarantee that a function polymorphic over of @'Divise' f@ provides+-- that @'Divisible' f@ doesn't that any input consumed will be passed to at+-- least one sub-consumer; it won't potentially disappear into the void, as+-- is possible if 'conquer' is available.+--+-- Mathematically, a functor being an instance of 'Divise' means that it is+-- "semgroupoidal" with respect to the contravariant (tupling) Day+-- convolution.  That is, it is possible to define a function @(f `Day` f)+-- a -> f a@ in a way that is associative.+class Contravariant f => Divise f where+    -- | Takes a "splitting" method and the two sub-consumers, and+    -- returns the wrapped/combined consumer.+    divise :: (a -> (b, c)) -> f b -> f c -> f a++-- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of+-- @(a, b)@.+--+-- @+-- 'divised' = 'divise' 'id'+-- @+divised :: Divise f => f a -> f b -> f (a, b)+divised = divise id++-- | Wrap a 'Divisible' to be used as a member of 'Divise'+newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a }++instance Contravariant f => Contravariant (WrappedDivisible f) where+  contramap f (WrapDivisible a) = WrapDivisible (contramap f a)++instance Divisible f => Divise (WrappedDivisible f) where+  divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y)++#if MIN_VERSION_base(4,9,0)+-- | Unlike 'Divisible', requires only 'Semigroup' on @r@.+instance Semigroup r => Divise (Op r) where+    divise f (Op g) (Op h) = Op $ \a -> case f a of+      (b, c) -> g b <> h c++-- | Unlike 'Divisible', requires only 'Semigroup' on @m@.+instance Semigroup m => Divise (Const m) where+    divise _ (Const a) (Const b) = Const (a <> b)++-- | Unlike 'Divisible', requires only 'Semigroup' on @m@.+instance Semigroup m => Divise (Constant m) where+    divise _ (Constant a) (Constant b) = Constant (a <> b)+#else+instance Monoid r => Divise (Op r) where divise = divide+instance Monoid m => Divise (Const m) where divise = divide+instance Monoid m => Divise (Constant m) where divise = divide+#endif++instance Divise Comparison where divise = divide+instance Divise Equivalence where divise = divide+instance Divise Predicate where divise = divide++#if MIN_VERSION_base(4,7,0) || defined(MIN_VERSION_tagged)+instance Divise Proxy where divise = divide+#endif++#ifdef MIN_VERSION_StateVar+instance Divise SettableStateVar where divise = divide+#endif++#if MIN_VERSION_base(4,8,0)+instance Divise f => Divise (Alt f) where+  divise f (Alt l) (Alt r) = Alt $ divise f l r+#endif++#ifdef GHC_GENERICS+instance Divise U1 where divise = divide+instance Divise V1 where divise _ = \case {}++instance Divise f => Divise (Rec1 f) where+  divise f (Rec1 l) (Rec1 r) = Rec1 $ divise f l r++instance Divise f => Divise (M1 i c f) where+  divise f (M1 l) (M1 r) = M1 $ divise f l r++instance (Divise f, Divise g) => Divise (f :*: g) where+  divise f (l1 :*: r1) (l2 :*: r2) = divise f l1 l2 :*: divise f r1 r2++-- | Unlike 'Divisible', requires only 'Apply' on @f@.+instance (Apply f, Divise g) => Divise (f :.: g) where+  divise f (Comp1 l) (Comp1 r) = Comp1 (liftF2 (divise f) l r)+#endif++instance Divise f => Divise (Backwards f) where+  divise f (Backwards l) (Backwards r) = Backwards $ divise f l r++instance Divise m => Divise (ErrorT e m) where+  divise f (ErrorT l) (ErrorT r) = ErrorT $ divise (funzip . fmap f) l r++instance Divise m => Divise (ExceptT e m) where+  divise f (ExceptT l) (ExceptT r) = ExceptT $ divise (funzip . fmap f) l r++instance Divise f => Divise (IdentityT f) where+  divise f (IdentityT l) (IdentityT r) = IdentityT $ divise f l r++instance Divise m => Divise (ListT m) where+  divise f (ListT l) (ListT r) = ListT $ divise (funzip . map f) l r++instance Divise m => Divise (MaybeT m) where+  divise f (MaybeT l) (MaybeT r) = MaybeT $ divise (funzip . fmap f) l r++instance Divise m => Divise (ReaderT r m) where+  divise abc (ReaderT rmb) (ReaderT rmc) = ReaderT $ \r -> divise abc (rmb r) (rmc r)++instance Divise m => Divise (Lazy.RWST r w s m) where+  divise abc (Lazy.RWST rsmb) (Lazy.RWST rsmc) = Lazy.RWST $ \r s ->+    divise (\ ~(a, s', w) -> case abc a of+                                  ~(b, c) -> ((b, s', w), (c, s', w)))+           (rsmb r s) (rsmc r s)++instance Divise m => Divise (Strict.RWST r w s m) where+  divise abc (Strict.RWST rsmb) (Strict.RWST rsmc) = Strict.RWST $ \r s ->+    divise (\(a, s', w) -> case abc a of+                                (b, c) -> ((b, s', w), (c, s', w)))+           (rsmb r s) (rsmc r s)++instance Divise m => Divise (Lazy.StateT s m) where+  divise f (Lazy.StateT l) (Lazy.StateT r) = Lazy.StateT $ \s ->+    divise (lazyFanout f) (l s) (r s)++instance Divise m => Divise (Strict.StateT s m) where+  divise f (Strict.StateT l) (Strict.StateT r) = Strict.StateT $ \s ->+    divise (strictFanout f) (l s) (r s)++instance Divise m => Divise (Lazy.WriterT w m) where+  divise f (Lazy.WriterT l) (Lazy.WriterT r) = Lazy.WriterT $+    divise (lazyFanout f) l r++instance Divise m => Divise (Strict.WriterT w m) where+  divise f (Strict.WriterT l) (Strict.WriterT r) = Strict.WriterT $+    divise (strictFanout f) l r++-- | Unlike 'Divisible', requires only 'Apply' on @f@.+instance (Apply f, Divise g) => Divise (Compose f g) where+  divise f (Compose l) (Compose r) = Compose (liftF2 (divise f) l r)++instance (Divise f, Divise g) => Divise (Product f g) where+  divise f (Pair l1 r1) (Pair l2 r2) = Pair (divise f l1 l2) (divise f r1 r2)++instance Divise f => Divise (Reverse f) where+  divise f (Reverse l) (Reverse r) = Reverse $ divise f l r++lazyFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+lazyFanout f ~(a, s) = case f a of+  ~(b, c) -> ((b, s), (c, s))++strictFanout :: (a -> (b, c)) -> (a, s) -> ((b, s), (c, s))+strictFanout f (a, s) = case f a of+  (b, c) -> ((b, s), (c, s))++funzip :: Functor f => f (a, b) -> (f a, f b)+funzip = fmap fst &&& fmap snd

@@ -0,0 +1,293 @@+-- |+-- Module      : Data.Functor.Contravariant.Divisible.Free+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- Provides free structures for the various typeclasses of the 'Divisible'+-- hierarchy.+--+-- @since 0.3.0.0+module Data.Functor.Contravariant.Divisible.Free (+    Div(..)+  , hoistDiv, liftDiv, runDiv+  , divListF, listFDiv+  , Div1(..)+  , hoistDiv1, liftDiv1, toDiv, runDiv1+  , div1NonEmptyF, nonEmptyFDiv1+  , Dec(..)+  , hoistDec, liftDec, runDec+  , Dec1(..)+  , hoistDec1, liftDec1, toDec, runDec1+  ) where++import           Control.Applicative.ListF+import           Control.Natural+import           Data.Bifunctor+import           Data.Bifunctor.Assoc+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Invariant+import           Data.HFunctor+import           Data.HFunctor.Interpret+import           Data.Kind+import           Data.List+import           Data.List.NonEmpty                   (NonEmpty(..))+import           Data.Void++-- | The free 'Divisible'.  Used to sequence multiple contravariant+-- consumers, splitting out the input across all consumers.+--+-- Note that @'Div' f@ is essentially @'ListF'+-- ('Data.Functor.Contravariant.Coyoneda' f)@, or just @'ListF' f@ in the+-- case that @f@ is already contravariant.  However, this is left in here+-- because it can be more convenient to use if you are working with an+-- intermediate @f@ that isn't 'Contravariant'.+data Div :: (Type -> Type) -> Type -> Type where+    Conquer :: Div f a+    Divide  :: (a -> (b, c)) -> f b -> Div f c -> Div f a++instance Contravariant (Div f) where+    contramap :: forall a b. (a -> b) -> Div f b -> Div f a+    contramap f = \case+      Conquer       -> Conquer+      Divide g x xs -> Divide (g . f) x xs+instance Invariant (Div f) where+    invmap _ = contramap++instance Divise (Div f) where+    divise f = \case+      Conquer       -> contramap (snd . f)+      Divide g x xs -> Divide (assoc . first g . f) x+                     . divise id xs+instance Divisible (Div f) where+    conquer  = Conquer+    divide   = divise++-- | 'Div' is isomorphic to 'ListF' for contravariant @f@.  This witnesses+-- one way of that isomorphism.+--+-- Be aware that this is essentially O(n^2).+divListF :: forall f. Contravariant f => Div f ~> ListF f+divListF = ListF . unfoldr go+  where+    go = \case+      Conquer       -> Nothing+      Divide f x xs -> Just ( contramap (fst . f) x+                            , contramap (snd . f) xs+                            )++-- | 'Div' is isomorphic to 'ListF' for contravariant @f@.  This witnesses+-- one way of that isomorphism.+--+-- This direction is O(n), unlike 'divListF'.+listFDiv :: ListF f ~> Div f+listFDiv = foldr (Divide (\y -> (y,y))) Conquer . runListF++-- | Map over the undering context in a 'Div'.+hoistDiv :: forall f g. (f ~> g) -> Div f ~> Div g+hoistDiv f = go+  where+    go :: Div f ~> Div g+    go = \case+      Conquer       -> Conquer+      Divide g x xs -> Divide g (f x) (go xs)++-- | Inject a single action in @f@ into a @'Div' f@.+liftDiv :: f ~> Div f+liftDiv x = Divide (,()) x Conquer++-- | Interpret a 'Div' into a context @g@, provided @g@ is 'Divisible'.+runDiv :: forall f g. Divisible g => (f ~> g) -> Div f ~> g+runDiv f = go+  where+    go :: Div f ~> g+    go = \case+      Conquer       -> conquer+      Divide g x xs -> divide g (f x) (go xs)++instance HFunctor Div where+    hmap = hoistDiv+instance Inject Div where+    inject = liftDiv+instance Divisible f => Interpret Div f where+    interpret = runDiv++-- | The free 'Divise': a non-empty version of 'Div'.+--+-- Note that @'Div1' f@ is essentially @'NonEmptyF'+-- ('Data.Functor.Contravariant.Coyoneda' f)@, or just @'NonEmptyF' f@ in the+-- case that @f@ is already contravariant.  However, it can be more+-- convenient to use if you are working with an intermediate @f@ that isn't+-- 'Contravariant'.+data Div1 :: (Type -> Type) -> Type -> Type where+    Div1 :: (a -> (b, c)) -> f b -> Div f c -> Div1 f a++instance Contravariant (Div1 f) where+    contramap f (Div1 g x xs) = Div1 (g . f) x xs+instance Invariant (Div1 f) where+    invmap _ = contramap+instance Divise (Div1 f) where+    divise f (Div1 g x xs) = Div1 (assoc . first g . f) x+                           . divise id xs+                           . toDiv++instance HFunctor Div1 where+    hmap = hoistDiv1+instance Inject Div1 where+    inject = liftDiv1+instance Divise f => Interpret Div1 f where+    interpret = runDiv1++-- | A 'Div1' is a "non-empty" 'Div'; this function "forgets" the non-empty+-- property and turns it back into a normal 'Div'.+toDiv :: Div1 f a -> Div f a+toDiv (Div1 f x xs) = Divide f x xs++-- | Map over the undering context in a 'Div1'.+hoistDiv1 :: (f ~> g) -> Div1 f ~> Div1 g+hoistDiv1 f (Div1 g x xs) = Div1 g (f x) (hoistDiv f xs)++-- | Inject a single action in @f@ into a @'Div' f@.+liftDiv1 :: f ~> Div1 f+liftDiv1 f = Div1 (,()) f Conquer++-- | Interpret a 'Div1' into a context @g@, provided @g@ is 'Divise'.+runDiv1 :: Divise g => (f ~> g) -> Div1 f ~> g+runDiv1 f (Div1 g x xs) = runDiv1_ f g x xs++runDiv1_+    :: forall f g a b c. Divise g+    => (f ~> g)+    -> (a -> (b, c))+    -> f b+    -> Div f c+    -> g a+runDiv1_ f = go+  where+    go :: (x -> (y, z)) -> f y -> Div f z -> g x+    go g x = \case+      Conquer       -> contramap (fst . g) (f x)+      Divide h y ys -> divise g (f x) (go h y ys)++-- | 'Div1' is isomorphic to 'NonEmptyF' for contravariant @f@.  This+-- witnesses one way of that isomorphism.+--+-- Be aware that this is essentially O(n^2).+div1NonEmptyF :: Contravariant f => Div1 f ~> NonEmptyF f+div1NonEmptyF (Div1 f x xs) = NonEmptyF $+       contramap (fst . f) x+    :| runListF (divListF (contramap (snd . f) xs))++-- | 'Div1' is isomorphic to 'NonEmptyF' for contravariant @f@.  This+-- witnesses one way of that isomorphism.+--+-- This direction is O(n), unlike 'div1NonEmptyF'.+nonEmptyFDiv1 :: NonEmptyF f ~> Div1 f+nonEmptyFDiv1 (NonEmptyF (x :| xs)) =+    Div1 (\y -> (y,y)) x (listFDiv (ListF xs))++-- | The free 'Decide'.  Used to aggregate multiple possible consumers,+-- directing the input into an appropriate consumer.+data Dec :: (Type -> Type) -> Type -> Type where+    Lose   :: (a -> Void) -> Dec f a+    Choose :: (a -> Either b c) -> f b -> Dec f c -> Dec f a++instance Contravariant (Dec f) where+    contramap f = \case+      Lose   g      -> Lose   (g . f)+      Choose g x xs -> Choose (g . f) x xs+instance Invariant (Dec f) where+    invmap _ = contramap+instance Decide (Dec f) where+    decide f = \case+      Lose   g      -> contramap (either (absurd . g) id . f)+      Choose g x xs -> Choose (assoc . first g . f) x+                     . decide id xs+instance Conclude (Dec f) where+    conclude = Lose+instance HFunctor Dec where+    hmap = hoistDec+instance Inject Dec where+    inject = liftDec+instance Conclude f => Interpret Dec f where+    interpret = runDec++-- | Map over the undering context in a 'Dec'.+hoistDec :: forall f g. (f ~> g) -> Dec f ~> Dec g+hoistDec f = go+  where+    go :: Dec f ~> Dec g+    go = \case+      Lose g -> Lose g+      Choose g x xs -> Choose g (f x) (go xs)++-- | Inject a single action in @f@ into a @'Dec' f@.+liftDec :: f ~> Dec f+liftDec x = Choose Left x (Lose id)++-- | Interpret a 'Dec' into a context @g@, provided @g@ is 'Conclude'.+runDec :: forall f g. Conclude g => (f ~> g) -> Dec f ~> g+runDec f = go+  where+    go :: Dec f ~> g+    go = \case+      Lose g -> conclude g+      Choose g x xs -> decide g (f x) (go xs)+++-- | The free 'Decide': a non-empty version of 'Dec'.+data Dec1 :: (Type -> Type) -> Type -> Type where+    Dec1 :: (a -> Either b c) -> f b -> Dec f c -> Dec1 f a++-- | A 'Dec1' is a "non-empty" 'Dec'; this function "forgets" the non-empty+-- property and turns it back into a normal 'Dec'.+toDec :: Dec1 f a -> Dec f a+toDec (Dec1 f x xs) = Choose f x xs++instance Contravariant (Dec1 f) where+    contramap f (Dec1 g x xs) = Dec1 (g . f) x xs+instance Invariant (Dec1 f) where+    invmap _ = contramap+instance Decide (Dec1 f) where+    decide f (Dec1 g x xs) = Dec1 (assoc . first g . f) x+                           . decide id xs+                           . toDec+instance HFunctor Dec1 where+    hmap = hoistDec1+instance Inject Dec1 where+    inject = liftDec1+instance Decide f => Interpret Dec1 f where+    interpret = runDec1++-- | Map over the undering context in a 'Dec1'.+hoistDec1 :: forall f g. (f ~> g) -> Dec1 f ~> Dec1 g+hoistDec1 f (Dec1 g x xs) = Dec1 g (f x) (hoistDec f xs)++-- | Inject a single action in @f@ into a @'Dec1' f@.+liftDec1 :: f ~> Dec1 f+liftDec1 x = Dec1 Left x (Lose id)++-- | Interpret a 'Dec1' into a context @g@, provided @g@ is 'Decide'.+runDec1 :: Decide g => (f ~> g) -> Dec1 f ~> g+runDec1 f (Dec1 g x xs) = runDec1_ f g x xs++runDec1_+    :: forall f g a b c. Decide g+    => (f ~> g)+    -> (a -> Either b c)+    -> f b+    -> Dec f c+    -> g a+runDec1_ f = go+  where+    go :: (x -> Either y z) -> f y -> Dec f z -> g x+    go g x = \case+      Lose h        -> contramap (either id (absurd . h) . g) (f x)+      Choose h y ys -> decide g (f x) (go h y ys)

@@ -0,0 +1,132 @@++-- |+-- Module      : Data.Functor.Contravariant.Night+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- Provides 'Night', a form of the day convolution that is contravariant+-- and splits on 'Either'.+--+-- @since 0.3.0.0+module Data.Functor.Contravariant.Night (+    Night(..)+  , night+  , runNight+  , assoc, unassoc+  , swapped+  , trans1, trans2+  , intro1, intro2+  , elim1, elim2+  , Not(..)+  ) where++import           Control.Natural+import           Data.Bifunctor+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Invariant+import           Data.Kind+import           Data.Void+import qualified Data.Bifunctor.Assoc              as B+import qualified Data.Bifunctor.Swap               as B++-- | A pairing of contravariant functors to create a new contravariant+-- functor that represents the "choice" between the two.+--+-- A @'Night' f g a@ is a contravariant "consumer" of @a@, and it does this+-- by either feeding the @a@ to @f@, or feeding the @a@ to @g@.  Which one+-- it gives it to happens at runtime depending /what/ @a@ is actually+-- given.+--+-- For example, if we have @x :: f a@ (a consumer of @a@s) and @y :: g b@+-- (a consumer of @b@s), then @'night' x y :: 'Night' f g ('Either' a b)@.+-- This is a consumer of @'Either' a b@s, and it consumes 'Left' branches+-- by feeding it to @x@, and 'Right' branches by feeding it to @y@.+--+-- Mathematically, this is a contravariant day convolution, except with+-- a different choice of bifunctor ('Either') than the typical one we talk+-- about in Haskell (which uses @(,)@).  Therefore, it is an alternative to+-- the typical 'Data.Functor.Day' convolution --- hence, the name 'Night'.+data Night :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) where+    Night :: f b+          -> g c+          -> (a -> Either b c)+          -> Night f g a++instance Contravariant (Night f g) where+    contramap f (Night x y g) = Night x y (g . f)++instance Invariant (Night f g) where+    invmap _ f (Night x y g) = Night x y (g . f)++-- | Inject into a 'Night'.+--+-- @'night' x y@ is a consumer of @'Either' a b@; 'Left' will be passed+-- to @x@, and 'Right' will be passed to @y@.+night+    :: f a+    -> g b+    -> Night f g (Either a b)+night x y = Night x y id++-- | Interpret out of a 'Night' into any instance of 'Decide' by providing+-- two interpreting functions.+runNight+    :: Decide h+    => (f ~> h)+    -> (g ~> h)+    -> Night f g ~> h+runNight f g (Night x y z) = decide z (f x) (g y)++-- | 'Night' is associative.+assoc :: Night f (Night g h) ~> Night (Night f g) h+assoc (Night x (Night y z f) g) = Night (Night x y id) z (B.unassoc . second f . g)++-- | 'Night' is associative.+unassoc :: Night (Night f g) h ~> Night f (Night g h)+unassoc (Night (Night x y f) z g) = Night x (Night y z id) (B.assoc . first f . g)++-- | The two sides of a 'Night' can be swapped.+swapped :: Night f g ~> Night g f+swapped (Night x y f) = Night y x (B.swap . f)++-- | Hoist a function over the left side of a 'Night'.+trans1 :: f ~> h -> Night f g ~> Night h g+trans1 f (Night x y z) = Night (f x) y z++-- | Hoist a function over the right side of a 'Night'.+trans2 :: g ~> h -> Night f g ~> Night f h+trans2 f (Night x y z) = Night x (f y) z++-- | A value of type @'Not' a@ is "proof" that @a@ is uninhabited.+newtype Not a = Not { refute :: a -> Void }++instance Contravariant Not where+    contramap f (Not g) = Not (g . f)++instance Semigroup (Not a) where+    Not f <> Not g = Not (f <> g)++-- | The left identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+intro1 :: g ~> Night Not g+intro1 x = Night (Not id) x Right++-- | The right identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+intro2 :: f ~> Night f Not+intro2 x = Night x (Not id) Left++-- | The left identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+elim1 :: Contravariant g => Night Not g ~> g+elim1 (Night x y z) = contramap (either (absurd . refute x) id . z) y++-- | The right identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+elim2 :: Contravariant f => Night f Not ~> f+elim2 (Night x y z) = contramap (either id (absurd . refute y) . z) x

@@ -0,0 +1,468 @@++-- |+-- 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+  , assembleDayChain+  , assembleDayChainRec+  , concatDayChain+  , concatDayChainRec+  -- * Nonempty Chain+  , DayChain1+  , pattern DayChain1+  , runCoDayChain1+  , runContraDayChain1+  , assembleDayChain1+  , assembleDayChain1Rec+  , concatDayChain1+  , concatDayChain1Rec+  ) where++import           Control.Natural+import           Control.Natural.IsoF+import           Data.Bifunctor+import           Data.Functor.Apply+import           Data.Functor.Combinator.Unsafe+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+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.Proxy+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 = unsafeApply (Proxy @g) $+    foldChain (pure . runIdentity) (runDayApply f id)++-- | 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 = unsafeDivise (Proxy @g) $+    foldChain (const conquer) (runDayDivise f id)++-- | 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 = More1 . hright Done1++instance Tensor Day Identity where+    type ListBy Day = DayChain++    intro1 = intro2+    intro2 = intro1+    elim1 = elim2+    elim2 = elim1++    appendLB = appendChain+    splitNE = splitChain1+    splittingLB = splittingChain++    toListBy = More . hright inject++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+-- @+--+-- This is much more convenient than doing it using manual applications of+-- 'divide' or 'divise' or 'Day', which would require manually peeling 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,407 @@++-- |+-- Module      : Data.Functor.Invariant.Night+-- Copyright   : (c) Justin Le 2019+-- License     : BSD3+--+-- Maintainer  : justin@jle.im+-- Stability   : experimental+-- Portability : non-portable+--+-- Provides an 'Invariant' version of a Day convolution over 'Either'.+--+-- @since 0.3.0.0+module Data.Functor.Invariant.Night (+    Night(..)+  , Not(..)+  , night+  , runNightAlt+  , runNightDecide+  , toCoNight+  , toContraNight+  , assoc, unassoc+  , intro1, intro2+  , elim1, elim2+  , swapped+  , trans1, trans2+  -- * Chain+  , NightChain+  , pattern Share, pattern Reject+  , runCoNightChain+  , runContraNightChain+  , assembleNightChain+  , concatNightChain+  -- * Nonempty Chain+  , NightChain1+  , pattern NightChain1+  , runCoNightChain1+  , runContraNightChain1+  , assembleNightChain1+  , concatNightChain1+  ) where++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.Night    (Not(..))+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 Data.Bifunctor.Assoc                as B+import qualified Data.Bifunctor.Swap                 as B+import qualified Data.Functor.Contravariant.Night    as CN+import qualified Data.HBifunctor.Tensor              as T++-- | A pairing of invariant functors to create a new invariant functor that+-- represents the "choice" between the two.+--+-- A @'Night' f g a@ is a invariant "consumer" and "producer" of @a@, and+-- it does this by either feeding the @a@ to @f@, or feeding the @a@ to+-- @g@, and then collecting the result from whichever one it was fed to.+-- Which decision of which path to takes happens at runtime depending+-- /what/ @a@ is actually given.+--+-- For example, if we have @x :: f a@ and @y :: g b@, then @'night' x y ::+-- 'Night' f g ('Either' a b)@.  This is a consumer/producer of @'Either' a b@s, and+-- it consumes 'Left' branches by feeding it to @x@, and 'Right' branches+-- by feeding it to @y@.  It then passes back the single result from the one of+-- the two that was chosen.+--+-- Mathematically, this is a invariant day convolution, except with+-- a different choice of bifunctor ('Either') than the typical one we talk+-- about in Haskell (which uses @(,)@).  Therefore, it is an alternative to+-- the typical 'Data.Functor.Day' convolution --- hence, the name 'Night'.+data Night :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) where+    Night :: f b+          -> g c+          -> (a -> Either b c)+          -> (b -> a)+          -> (c -> a)+          -> Night f g a++-- | 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.+night :: f a -> g b -> Night f g (Either a b)+night x y = Night x y id Left Right++-- | Interpret the covariant part of a 'Night' into a target context @h@,+-- as long as the context is an instance of 'Alt'.  The 'Alt' is used to+-- combine results back together, chosen by '<!>'.+runNightAlt+    :: forall f g h. Alt h+    => f ~> h+    -> g ~> h+    -> Night f g ~> h+runNightAlt f g (Night x y _ j k) = fmap j (f x) <!> fmap k (g y)++-- | Interpret the contravariant part of a 'Night' into a target context+-- @h@, as long as the context is an instance of 'Decide'.  The 'Decide' is+-- used to pick which part to feed the input to.+runNightDecide+    :: forall f g h. Decide h+    => f ~> h+    -> g ~> h+    -> Night f g ~> h+runNightDecide f g (Night x y h _ _) = decide h (f x) (g y)++-- | Convert an invariant 'Night' into the covariant version, dropping the+-- contravariant part.+--+-- Note that there is no covariant version of 'Night' defined in any common+-- library, so we use an equivalent type (if @f@ and @g@ are 'Functor's) @f+-- ':*:' g@.+toCoNight :: (Functor f, Functor g) => Night f g ~> f :*: g+toCoNight (Night x y _ f g) = fmap f x :*: fmap g y++-- | Convert an invariant 'Night' into the contravariant version, dropping+-- the covariant part.+toContraNight :: Night f g ~> CN.Night f g+toContraNight (Night x y f _ _) = CN.Night x y f++-- | 'Night' is associative.+assoc :: Night f (Night g h) ~> Night (Night f g) h+assoc (Night x (Night y z f g h) j k l) =+    Night (Night x y id Left Right) z+      (B.unassoc . second f . j)+      (either k (l . g))+      (l . h)++-- | 'Night' is associative.+unassoc :: Night (Night f g) h ~> Night f (Night g h)+unassoc (Night (Night x y f g h) z j k l) =+    Night x (Night y z id Left Right)+      (B.assoc . first f . j)+      (k . g)+      (either (k . h) l)++-- | The left identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+intro1 :: g ~> Night Not g+intro1 y = Night (Not id) y Right absurd id++-- | The right identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+intro2 :: f ~> Night f Not+intro2 x = Night x (Not id) Left id absurd++-- | The left identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+elim1 :: Invariant g => Night Not g ~> g+elim1 (Night x y f _ h) = invmap h (either (absurd . refute x) id . f) y++-- | The right identity of 'Night' is 'Not'; this is one side of that+-- isomorphism.+elim2 :: Invariant f => Night f Not ~> f+elim2 (Night x y f g _) = invmap g (either id (absurd . refute y) . f) x++-- | The two sides of a 'Night' can be swapped.+swapped :: Night f g ~> Night g f+swapped (Night x y f g h) = Night y x (B.swap . f) h g++-- | Hoist a function over the left side of a 'Night'.+trans1 :: f ~> h -> Night f g ~> Night h g+trans1 f (Night x y g h j) = Night (f x) y g h j++-- | Hoist a function over the right side of a 'Night'.+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)++-- | 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)++-- | 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 no @f@s, but only the+-- terminal value.  Analogous to the+-- 'Data.Functor.Contravariant.Divisible.Free.Choose' constructor.+pattern Share :: (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> NightChain f c -> NightChain f a+pattern Share 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 Share, 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 = chain1Pair++instance Tensor Night Not where+    type ListBy Night = NightChain++    intro1 = intro2+    intro2 = intro1+    elim1 = elim2+    elim2 = elim1++    appendLB = appendChain+    splitNE = splitChain1+    splittingLB = splittingChain++    toListBy = chainPair++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+-- @+--+-- This is much more convenient than doing it using manual applications of+-- 'decide' or 'Data.Functor.Contravariant.Divisible.choose' or 'Night',+-- which would require manually peeling 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 '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

@@ -62,13 +62,20 @@ import           Control.Natural.IsoF import           Data.Bifunctor.Joker import           Data.Coerce+import           Data.Constraint.Trivial import           Data.Data import           Data.Foldable import           Data.Functor.Apply.Free import           Data.Functor.Bind import           Data.Functor.Classes-import           Data.Functor.Day             (Day(..))+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible.Free+import           Data.Functor.Contravariant.Night          (Night(..))+import           Data.Functor.Day                          (Day(..)) import           Data.Functor.Identity+import           Data.Functor.Invariant import           Data.Functor.Plus import           Data.Functor.Product import           Data.Functor.Sum@@ -78,10 +85,13 @@ import           Data.HFunctor.Internal import           Data.HFunctor.Interpret import           Data.Kind-import           Data.List.NonEmpty           (NonEmpty(..))+import           Data.List.NonEmpty                        (NonEmpty(..))+import           Data.Void import           GHC.Generics-import qualified Data.Functor.Day             as D-import qualified Data.Map.NonEmpty            as NEM+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.Map.NonEmpty                         as NEM  -- | An 'HBifunctor' where it doesn't matter which binds first is -- 'Associative'.  Knowing this gives us a lot of power to rearrange the@@ -129,10 +139,18 @@     -- of this type.     type NonEmptyBy t :: (Type -> Type) -> Type -> Type +    -- | A description of "what type of Functor" this tensor is expected to+    -- be applied to.  This should typically always be either 'Functor',+    -- 'Contravariant', or 'Invariant'.+    --+    -- @since 0.3.0.0+    type FunctorBy t :: (Type -> Type) -> Constraint+    type FunctorBy t = Unconstrained+     -- | The isomorphism between @t f (t g h) a@ and @t (t f g) h a@.  To     -- use this isomorphism, see 'assoc' and 'disassoc'.     associating-        :: (Functor f, Functor g, Functor h)+        :: (FunctorBy t f, FunctorBy t g, FunctorBy t h)         => t f (t g h) <~> t (t f g) h      -- | If a @'NonEmptyBy' t f@ represents multiple applications of @t f@ to@@ -150,7 +168,7 @@     -- Note that you can recursively "unroll" a 'NonEmptyBy' completely     -- into a 'Data.HFunctor.Chain.Chain1' by using     -- 'Data.HFunctor.Chain.unrollNE'.-    matchNE  :: Functor f => NonEmptyBy t f ~> f :+: t f (NonEmptyBy t f)+    matchNE  :: FunctorBy t f => NonEmptyBy t f ~> f :+: t f (NonEmptyBy t f)      -- | Prepend an application of @t f@ to the front of a @'NonEmptyBy' t f@.     consNE :: t f (NonEmptyBy t f) ~> NonEmptyBy t f@@ -164,14 +182,14 @@  -- | Reassociate an application of @t@. assoc-    :: (Associative t, Functor f, Functor g, Functor h)+    :: (Associative t, FunctorBy t f, FunctorBy t g, FunctorBy t h)     => t f (t g h)     ~> t (t f g) h assoc = viewF associating  -- | Reassociate an application of @t@. disassoc-    :: (Associative t, Functor f, Functor g, Functor h)+    :: (Associative t, FunctorBy t f, FunctorBy t g, FunctorBy t h)     => t (t f g) h     ~> t f (t g h) disassoc = reviewF associating@@ -229,7 +247,7 @@ -- @ -- -- This will prevent problems with overloaded instances.-class Associative t => SemigroupIn t f where+class (Associative t, FunctorBy t f) => SemigroupIn t f where     -- | The 'HBifunctor' analogy of 'retract'. It retracts /both/ @f@s     -- into a single @f@, effectively fully mixing them together.     --@@ -261,7 +279,7 @@ -- -- Can be useful as a default implementation if you already have -- 'SemigroupIn' implemented.-retractNE :: forall t f. (SemigroupIn t f, Functor f) => NonEmptyBy t f ~> f+retractNE :: forall t f. SemigroupIn t f => NonEmptyBy t f ~> f retractNE = (id !*! biretract @t . hright (retractNE @t))           . matchNE @t @@ -270,7 +288,7 @@ -- -- Can be useful as a default implementation if you already have -- 'SemigroupIn' implemented.-interpretNE :: forall t g f. (SemigroupIn t f, Functor f) => (g ~> f) -> NonEmptyBy t g ~> f+interpretNE :: forall t g f. SemigroupIn t f => (g ~> f) -> NonEmptyBy t g ~> f interpretNE f = retractNE @t . hmap f  -- | An @'NonEmptyBy' t f@ represents the successive application of @t@ to @f@,@@ -279,7 +297,7 @@ -- -- 'matchingNE' states that these two are isomorphic.  Use 'matchNE' and -- @'inject' '!*!' 'consNE'@ to convert between one and the other.-matchingNE :: (Associative t, Functor f) => NonEmptyBy t f <~> f :+: t f (NonEmptyBy t f)+matchingNE :: (Associative t, FunctorBy t f) => NonEmptyBy t f <~> f :+: t f (NonEmptyBy t f) matchingNE = isoF matchNE (inject !*! consNE)  -- | Useful wrapper over 'binterpret' to allow you to directly extract@@ -427,6 +445,7 @@  instance Associative Day where     type NonEmptyBy Day = Ap1+    type FunctorBy Day = Functor     associating = isoF D.assoc D.disassoc      appendNE (Day x y z) = z <$> x <.> y@@ -444,6 +463,44 @@     biretract (Day x y z) = z <$> x <.> y     binterpret f g (Day x y z) = z <$> f x <.> g y +-- | @since 0.3.0.0+instance Associative CD.Day where+    type NonEmptyBy CD.Day = Div1+    type FunctorBy CD.Day = Contravariant+    associating = isoF CD.assoc CD.disassoc++    appendNE (CD.Day x y f) = divise f x y+    matchNE (Div1 f x xs) = case xs of+      Conquer -> L1 $ contramap (fst . f) x+      Divide g y ys -> R1 $ CD.Day x (Div1 g y ys) f++    consNE (CD.Day x y f) = Div1 f x (toDiv y)+    toNonEmptyBy (CD.Day x y f) = Div1 f x (inject y)++-- | @since 0.3.0.0+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)++-- | @since 0.3.0.0+instance Associative Night where+    type NonEmptyBy Night = Dec1+    type FunctorBy Night = Contravariant+    associating = isoF N.assoc N.unassoc++    appendNE (Night x y f) = decide f x y+    matchNE (Dec1 f x xs) = case xs of+      Lose g -> L1 $ contramap (either id (absurd . g) . f) x+      Choose g y ys -> R1 $ Night x (Dec1 g y ys) f++    consNE (Night x y f) = Dec1 f x (toDec y)+    toNonEmptyBy (Night x y f) = Dec1 f x (inject y)++-- | @since 0.3.0.0+instance Decide f => SemigroupIn Night f where+    biretract      (Night x y f) = decide f x y+    binterpret f g (Night x y h) = decide h (f x) (g y)+ instance Associative (:+:) where     type NonEmptyBy (:+:) = Step @@ -584,6 +641,8 @@  instance Associative Comp where     type NonEmptyBy Comp = Free1+    type FunctorBy Comp = Functor+     associating = isoF to_ from_       where         to_   (x :>>= y) = (x :>>= (unComp . y)) :>>= id@@ -637,6 +696,7 @@  instance Associative RightF where     type NonEmptyBy RightF = Step+     associating = isoF (RightF . runRightF . runRightF)                        (RightF . RightF    . runRightF) @@ -683,6 +743,8 @@  instance Associative t => Associative (WrapHBF t) where     type NonEmptyBy (WrapHBF t) = NonEmptyBy t+    type FunctorBy (WrapHBF t) = FunctorBy t+     associating = isoF (hright unwrapHBF . unwrapHBF) (WrapHBF . hright WrapHBF)                 . associating @t                 . isoF (WrapHBF . hleft WrapHBF) (hleft unwrapHBF . unwrapHBF)@@ -697,6 +759,15 @@ -- a newtype wrapper to avoid overlapping instances. newtype WrapNE t f a = WrapNE { unwrapNE :: NonEmptyBy t f a } -instance Associative t => SemigroupIn (WrapHBF t) (WrapNE t f) where+instance Functor (NonEmptyBy t f) => Functor (WrapNE t f) where+    fmap f (WrapNE x) = WrapNE (fmap f x)++instance Contravariant (NonEmptyBy t f) => Contravariant (WrapNE t f) where+    contramap f (WrapNE x) = WrapNE (contramap f x)++instance Invariant (NonEmptyBy t f) => Invariant (WrapNE t f) where+    invmap f g (WrapNE x) = WrapNE (invmap f g x)++instance (Associative t, FunctorBy t f, FunctorBy t (WrapNE t f)) => SemigroupIn (WrapHBF t) (WrapNE t f) where     biretract = WrapNE . appendNE . hbimap unwrapNE unwrapNE . unwrapHBF     binterpret f g = biretract . hbimap f g

@@ -81,8 +81,16 @@ import           Data.Functor.Apply.Free import           Data.Functor.Bind import           Data.Functor.Classes-import           Data.Functor.Day            (Day(..))+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Contravariant.Divisible.Free+import           Data.Functor.Contravariant.Night          (Night(..), Not(..))+import           Data.Functor.Day                          (Day(..)) import           Data.Functor.Identity+import           Data.Functor.Invariant import           Data.Functor.Plus import           Data.Functor.Product import           Data.Functor.Sum@@ -93,10 +101,12 @@ import           Data.HFunctor.Internal import           Data.HFunctor.Interpret import           Data.Kind-import           Data.List.NonEmpty          (NonEmpty(..))+import           Data.List.NonEmpty                        (NonEmpty(..)) import           GHC.Generics-import qualified Data.Functor.Day            as D-import qualified Data.Map.NonEmpty           as NEM+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.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@.@@ -160,11 +170,11 @@     -- | 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 :: Functor f => t f i ~> f+    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 :: Functor g => t i g ~> g+    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@@ -218,12 +228,12 @@  -- | @f@ is isomorphic to @t f i@: that is, @i@ is the identity of @t@, and -- leaves @f@ unchanged.-rightIdentity :: (Tensor t i, Functor f) => f <~> t f i+rightIdentity :: (Tensor t i, FunctorBy t f) => f <~> t f i rightIdentity = isoF intro1 elim1  -- | @g@ is isomorphic to @t i g@: that is, @i@ is the identity of @t@, and -- leaves @g@ unchanged.-leftIdentity  :: (Tensor t i, Functor g) => g <~> t i g+leftIdentity  :: (Tensor t i, FunctorBy t g) => g <~> t i g leftIdentity = isoF intro2 elim2  -- | 'leftIdentity' ('intro1' and 'elim1') for ':+:' actually does not@@ -424,7 +434,7 @@ -- See 'prodOutL' for a version that does not require @'Functor' f@, -- specifically for ':*:'. outL-    :: (Tensor t Proxy, Functor f)+    :: (Tensor t Proxy, FunctorBy t f)     => t f g ~> f outL = elim1 . hright absorb @@ -435,7 +445,7 @@ -- See 'prodOutR' for a version that does not require @'Functor' g@, -- specifically for ':*:'. outR-    :: (Tensor t Proxy, Functor g)+    :: (Tensor t Proxy, FunctorBy t g)     => t f g ~> g outR = elim2 . hleft absorb @@ -448,7 +458,7 @@     --     -- This is analogous to a function @'uncurry' ('Data.List.NonEmpty.:|')     -- :: (a, [a]) -> 'Data.List.NonEmpty.NonEmpty' a@.-    unsplitNE :: t f (ListBy t f) ~> NonEmptyBy t f+    unsplitNE :: FunctorBy t f => t f (ListBy t f) ~> NonEmptyBy t f      -- | "Pattern match" on an @'ListBy' t f@: it is either empty, or it is     -- non-empty (and so can be an @'NonEmptyBy' t f@).@@ -466,12 +476,12 @@     -- Note that you can recursively "unroll" a 'ListBy' completely into     -- a 'Data.HFunctor.Chain.Chain' by using     -- 'Data.HFunctor.Chain.unrollLB'.-    matchLB   :: ListBy t f ~> i :+: NonEmptyBy t f+    matchLB   :: FunctorBy t f => ListBy t f ~> i :+: NonEmptyBy t f  -- | An @'NonEmptyBy' t f@ is isomorphic to an @f@ consed with an @'ListBy' t f@, like -- how a @'Data.List.NonEmpty.NonEmpty' a@ is isomorphic to @(a, [a])@. splittingNE-    :: Matchable t i+    :: (Matchable t i, FunctorBy t f)     => NonEmptyBy t f <~> t f (ListBy t f) splittingNE = isoF splitNE unsplitNE @@ -479,7 +489,7 @@ -- non-empty case (@'NonEmptyBy' t f@), like how @[a]@ is isomorphic to @'Maybe' -- ('Data.List.NonEmpty.NonEmpty' a)@. matchingLB-    :: forall t i f. Matchable t i+    :: forall t i f. (Matchable t i, FunctorBy t f)     => ListBy t f <~> i :+: NonEmptyBy t f matchingLB = isoF (matchLB @t) (nilLB @t !*! fromNE @t) @@ -551,10 +561,10 @@           L1 (Identity x) -> Pure x           R1 (Day x xs f) -> Ap x (flip f <$> xs) -    toListBy (Day x y z) = z <$> liftAp x <*> liftAp y+    toListBy (Day x y z) = Ap x (Ap y (Pure (flip z)))  -- | Instances of 'Applicative' are monoids in the monoidal category on--- 'Day'.+-- the covariant 'Day'. -- -- Note that because of typeclass constraints, this requires 'Apply' as -- well as 'Applicative'.  But, you can get a "local" instance of 'Apply'@@ -563,6 +573,64 @@ instance (Apply f, Applicative f) => MonoidIn Day Identity f where     pureT            = generalize +-- | @since 0.3.0.0+instance Tensor CD.Day Proxy where+    type ListBy CD.Day = Div+    intro1 = CD.intro2+    intro2 = CD.intro1+    elim1 = CD.day1+    elim2 = CD.day2++    appendLB (CD.Day x y z) = divide z x y+    splitNE (Div1 f x xs) = CD.Day x xs f+    splittingLB = isoF to_ from_+      where+        to_ = \case+          Conquer       -> L1 Proxy+          Divide f x xs -> R1 (CD.Day x xs f)+        from_ = \case+          L1 Proxy           -> Conquer+          R1 (CD.Day x xs f) -> Divide f x xs++    toListBy (CD.Day x y z) = Divide z x (inject y)++-- | Instances of 'Divisible' are monoids in the monoidal category on+-- contravariant 'CD.Day'.+--+-- Note that because of typeclass constraints, this requires 'Divise' as+-- well as 'Divisible'.  But, you can get a "local" instance of 'Divise'+-- for any 'Divisible' using+-- 'Data.Functor.Combinators.Unsafe.unsafeDivise'.+--+-- @since 0.3.0.0+instance (Divise f, Divisible f) => MonoidIn CD.Day Proxy f where+    pureT _ = conquer++-- | @since 0.3.0.0+instance Tensor Night Not where+    type ListBy Night = Dec+    intro1 = N.intro2+    intro2 = N.intro1+    elim1 = N.elim2+    elim2 = N.elim1++    appendLB (Night x y z) = decide z x y+    splitNE (Dec1 f x xs) = Night x xs f+    splittingLB = isoF to_ from_+      where+        to_ = \case+          Lose   f      -> L1 (Not f)+          Choose f x xs -> R1 (Night x xs f)+        from_ = \case+          L1 (Not f)    -> Lose f+          R1 (Night x xs f) -> Choose f x xs++    toListBy (Night x y z) = Choose z x (inject y)++-- | Instances of 'Conclude' are monoids in the monoidal category on 'Night'.+instance Conclude f => MonoidIn Night Not f where+    pureT (Not x) = conclude x+ instance Tensor (:+:) V1 where     type ListBy (:+:) = Step     intro1 = L1@@ -689,6 +757,22 @@     unsplitNE = DayAp1     matchLB   = fromAp +-- | Instances of 'Conclude' are monoids in the monoidal category on 'Night'.+--+-- @since 0.3.0.0+instance Matchable CD.Day Proxy where+    unsplitNE (CD.Day x xs f) = Div1 f x xs+    matchLB = \case+      Conquer       -> L1 Proxy+      Divide f x xs -> R1 (Div1 f x xs)++-- | @since 0.3.0.0+instance Matchable Night Not where+    unsplitNE (Night x xs f) = Dec1 f x xs+    matchLB = \case+      Lose   f      -> L1 (Not f)+      Choose f x xs -> R1 (Dec1 f x xs)+ instance Matchable (:+:) V1 where     unsplitNE   = stepUp     matchLB     = R1@@ -744,9 +828,20 @@ -- require a newtype wrapper to avoid overlapping instances. newtype WrapLB t f a = WrapLB { unwrapLB :: ListBy t f a } -instance Tensor t i => SemigroupIn (WrapHBF t) (WrapLB t f) where+instance Functor (ListBy t f) => Functor (WrapLB t f) where+    fmap f (WrapLB x) = WrapLB (fmap f x)++-- | @since 0.3.0.0+instance Contravariant (ListBy t f) => Contravariant (WrapLB t f) where+    contramap f (WrapLB x) = WrapLB (contramap f x)++-- | @since 0.3.0.0+instance Invariant (ListBy t f) => Invariant (WrapLB t f) where+    invmap f g (WrapLB x) = WrapLB (invmap f g x)++instance (Tensor t i, FunctorBy t f, FunctorBy t (WrapLB t f)) => SemigroupIn (WrapHBF t) (WrapLB t f) where     biretract = WrapLB . appendLB . hbimap unwrapLB unwrapLB . unwrapHBF     binterpret f g = biretract . hbimap f g -instance Tensor t i => MonoidIn (WrapHBF t) (WrapF i) (WrapLB t f) where+instance (Tensor t i, FunctorBy t f, FunctorBy t (WrapLB t f)) => MonoidIn (WrapHBF t) (WrapF i) (WrapLB t f) where     pureT = WrapLB . nilLB @t . unwrapF

@@ -46,7 +46,13 @@ import           Data.Deriving import           Data.Functor.Bind import           Data.Functor.Classes+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible import           Data.Functor.Coyoneda+import           Data.Functor.Invariant import           Data.Functor.Plus import           Data.Functor.Product import           Data.Functor.Reverse@@ -54,15 +60,16 @@ import           Data.Functor.These import           Data.HFunctor.Internal import           Data.Kind-import           Data.List.NonEmpty             (NonEmpty(..))+import           Data.List.NonEmpty                   (NonEmpty(..)) import           Data.Pointed import           Data.Semigroup.Foldable import           GHC.Generics-import qualified Control.Alternative.Free       as Alt-import qualified Control.Applicative.Free.Fast  as FAF-import qualified Control.Applicative.Free.Final as FA-import qualified Data.Map                       as M-import qualified Data.Map.NonEmpty              as NEM+import qualified Control.Alternative.Free             as Alt+import qualified Control.Applicative.Free.Fast        as FAF+import qualified Control.Applicative.Free.Final       as FA+import qualified Data.Functor.Contravariant.Coyoneda  as CCY+import qualified Data.Map                             as M+import qualified Data.Map.NonEmpty                    as NEM  -- | Lift an isomorphism over an 'HFunctor'. --@@ -96,6 +103,30 @@ deriveEq1 ''ProxyF deriveOrd1 ''ProxyF +-- | @since 0.3.0.0+instance Contravariant (ProxyF f) where+    contramap _ = coerce+-- | @since 0.3.0.0+instance Divisible (ProxyF f) where+    divide _ _ _ = ProxyF+    conquer = ProxyF+-- | @since 0.3.0.0+instance Divise (ProxyF f) where+    divise _ _ _ = ProxyF+-- | @since 0.3.0.0+instance Decide (ProxyF f) where+    decide _ _ _ = ProxyF+-- | @since 0.3.0.0+instance Conclude (ProxyF f) where+    conclude _ = ProxyF+-- | @since 0.3.0.0+instance Decidable (ProxyF f) where+    choose _ _ _ = ProxyF+    lose _ = ProxyF+-- | @since 0.3.0.0+instance Invariant (ProxyF f) where+    invmap _ _ = coerce+ instance HFunctor ProxyF where     hmap _ = coerce @@ -115,6 +146,20 @@ deriveEq1 ''ConstF deriveOrd1 ''ConstF +-- | @since 0.3.0.0+instance Contravariant (ConstF e f) where+    contramap _ = coerce+-- | @since 0.3.0.0+instance Monoid e => Divisible (ConstF e f) where+    divide _ (ConstF x) (ConstF y) = ConstF (x <> y)+    conquer = ConstF mempty+-- | @since 0.3.0.0+instance Semigroup e => Divise (ConstF e f) where+    divise _ (ConstF x) (ConstF y) = ConstF (x <> y)+-- | @since 0.3.0.0+instance Invariant (ConstF e f) where+    invmap _ _ = coerce+ instance HFunctor (ConstF e) where     hmap _ = coerce @@ -163,6 +208,18 @@       HPure  x -> HPure  (f x)       HOther x -> HOther (hmap f x) +-- | @since 0.3.0.0+instance (Contravariant f, Contravariant (t f)) => Contravariant (HLift t f) where+    contramap f = \case+      HPure  x  -> HPure  (contramap f x)+      HOther xs -> HOther (contramap f xs)++-- | @since 0.3.0.0+instance (Invariant f, Invariant (t f)) => Invariant (HLift t f) where+    invmap f g = \case+      HPure  x  -> HPure  (invmap f g x)+      HOther xs -> HOther (invmap f g xs)+ -- | A higher-level 'Data.HFunctor.Interpret.retract' to get a @t f a@ back -- out of an @'HLift' t f a@, provided @t@ is an instance of 'Inject'. --@@ -226,6 +283,16 @@  deriving instance (Functor f, Functor (t (HFree t f))) => Functor (HFree t f) +instance (Contravariant f, Contravariant (t (HFree t f))) => Contravariant (HFree t f) where+    contramap f = \case+      HReturn x  -> HReturn (contramap f x)+      HJoin   xs -> HJoin   (contramap f xs)++instance (Invariant f, Invariant (t (HFree t f))) => Invariant (HFree t f) where+    invmap f g = \case+      HReturn x  -> HReturn (invmap f g x)+      HJoin   xs -> HJoin   (invmap f g xs)+ -- | Recursively fold down an 'HFree' into a single @g@ result, by handling -- each branch.  Can be more useful than -- 'Data.HFunctor.Interpret.interpret' because it allows you to treat each@@ -343,6 +410,10 @@  instance Inject Coyoneda where     inject = liftCoyoneda++-- | @since 0.3.0.0+instance Inject CCY.Coyoneda where+    inject = CCY.liftCoyoneda  instance Inject Ap where     inject = liftAp

@@ -31,6 +31,10 @@   , reroll   , unrolling   , appendChain+  , splittingChain+  , chainPair+  , injectChain+  , unconsChain   -- * 'Chain1'   , Chain1(..)   , foldChain1@@ -40,6 +44,9 @@   , rerollNE   , appendChain1   , fromChain1+  , matchChain1+  , chain1Pair+  , injectChain1   -- ** Matchable   -- | The following conversions between 'Chain' and 'Chain1' are only   -- possible if @t@ is 'Matchable'@@ -54,8 +61,14 @@ import           Control.Natural.IsoF import           Data.Functor.Bind import           Data.Functor.Classes-import           Data.Functor.Day hiding     (intro1, intro2, elim1, elim2)+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Day hiding              (intro1, intro2, elim1, elim2) import           Data.Functor.Identity+import           Data.Functor.Invariant import           Data.Functor.Plus import           Data.Functor.Product import           Data.HBifunctor@@ -66,6 +79,8 @@ 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@@ -162,6 +177,19 @@             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@@ -198,7 +226,7 @@     hmap f = foldChain1 (Done1 . f) (More1 . hleft f)  instance HBifunctor t => Inject (Chain1 t) where-    inject  = Done1+    inject  = injectChain1  instance (HBifunctor t, SemigroupIn t f) => Interpret (Chain1 t) f where     retract = \case@@ -212,6 +240,18 @@           Done1 x  -> f x           More1 xs -> binterpret f go xs +-- | Convert a tensor value pairing two @f@s into a two-item chain.+--+-- @since 0.3.0.0+chain1Pair :: HBifunctor t => t f f ~> Chain1 t f+chain1Pair = 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@@ -219,7 +259,7 @@ -- -- 'unrollingNE' states that the two types are isormorphic.  Use 'unrollNE' -- and 'rerollNE' to convert between the two.-unrollingNE :: forall t f. (Associative t, Functor f) => NonEmptyBy t f <~> Chain1 t f+unrollingNE :: forall t f. (Associative t, FunctorBy t f) => NonEmptyBy t f <~> Chain1 t f unrollingNE = isoF unrollNE rerollNE  -- | A type @'NonEmptyBy' t@ is supposed to represent the successive application of@@ -230,7 +270,7 @@ -- @ -- 'unrollNE' = 'unfoldChain1' 'matchNE' -- @-unrollNE :: (Associative t, Functor f) => NonEmptyBy t f ~> Chain1 t f+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@@ -252,7 +292,7 @@ -- -- @since 0.1.1.0 appendChain1-    :: forall t f. (Associative t, Functor f)+    :: forall t f. (Associative t, FunctorBy t f)     => t (Chain1 t f) (Chain1 t f) ~> Chain1 t f appendChain1 = unrollNE              . appendNE@@ -260,7 +300,7 @@  -- | @'Chain1' t@ is the "free @'SemigroupIn' t@".  However, we have to -- wrap @t@ in 'WrapHBF' to prevent overlapping instances.-instance (Associative t, Functor f) => SemigroupIn (WrapHBF t) (Chain1 t f) where+instance (Associative t, FunctorBy t f, FunctorBy t (Chain1 t f)) => SemigroupIn (WrapHBF t) (Chain1 t f) where     biretract = appendChain1 . unwrapHBF     binterpret f g = biretract . hbimap f g @@ -287,6 +327,21 @@ instance Functor f => Alt (Chain1 Product f) where     x <!> y = appendChain1 (Pair x y) +-- | @'Chain1' 'CD.Day'@ is the free "semigroup in the semigroupoidal+-- category of endofunctors enriched by 'CD.Day'" --- aka, the free 'Divise'.+--+-- @since 0.3.0.0+instance Contravariant f => Divise (Chain1 CD.Day f) where+    divise f x y = appendChain1 $ CD.Day x y f++-- | @'Chain1' 'N.Night'@ is the free "semigroup in the semigroupoidal+-- category of endofunctors enriched by 'N.Night'" --- aka, the free+-- 'Decide'.+--+-- @since 0.3.0.0+instance Contravariant f => Decide (Chain1 N.Night f) where+    decide 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@@ -371,6 +426,16 @@             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@.@@ -406,7 +471,7 @@     hmap f = foldChain Done (More . hleft f)  instance Tensor t i => Inject (Chain t i) where-    inject = More . hright Done . intro1+    inject = injectChain  -- | We can collapse and interpret an @'Chain' t i@ if we have @'Tensor' t@. instance MonoidIn t i f => Interpret (Chain t i) f where@@ -421,6 +486,18 @@           Done x  -> pureT @t x           More xs -> binterpret f go xs +-- | Convert a tensor value pairing two @f@s into a two-item chain.+--+-- @since 0.3.0.0+chainPair :: Tensor t i => t f f ~> Chain t i f+chainPair = More . hright inject++-- | Create a singleton chain+--+-- @since 0.3.0.0+injectChain :: Tensor t i => f ~> Chain t i f+injectChain = More . hright Done . intro1+ -- | A 'Chain1' is "one or more linked @f@s", and a 'Chain' is "zero or -- more linked @f@s".  So, we can convert from a 'Chain1' to a 'Chain' that -- always has at least one @f@.@@ -492,12 +569,39 @@             . 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 -- latter. splittingChain1-    :: forall t i f. (Matchable t i, Functor f)+    :: forall t i f. (Matchable t i, FunctorBy t f)     => Chain1 t f <~> t f (Chain t i f) splittingChain1 = fromF unrollingNE                 . splittingNE @t@@ -514,7 +618,7 @@ -- a non-empty linked list of @f@s.  This witnesses the fact that -- a @'Chain' t i f@ is either empty (@i@) or non-empty (@'Chain1' t f@). matchingChain-    :: forall t i f. (Tensor t i, Matchable t i, Functor f)+    :: forall t i f. (Tensor t i, Matchable t i, FunctorBy t f)     => Chain t i f <~> i :+: Chain1 t f matchingChain = fromF unrolling               . matchingLB @t@@ -528,13 +632,13 @@ unmatchChain = unroll . (nilLB @t !*! fromNE @t) . hright rerollNE  -- | We have to wrap @t@ in 'WrapHBF' to prevent overlapping instances.-instance (Tensor t i, Functor f) => SemigroupIn (WrapHBF t) (Chain t i f) where+instance (Tensor t i, FunctorBy t (Chain t i f)) => SemigroupIn (WrapHBF t) (Chain t i f) where     biretract = appendChain . unwrapHBF     binterpret f g = biretract . hbimap f g  -- | @'Chain' t i@ is the "free @'MonoidIn' t i@".  However, we have to -- wrap @t@ in 'WrapHBF' and @i@ in 'WrapF' to prevent overlapping instances.-instance (Tensor t i, Functor f) => MonoidIn (WrapHBF t) (WrapF i) (Chain t i f) where+instance (Tensor t i, FunctorBy t (Chain t i f)) => MonoidIn (WrapHBF t) (WrapF i) (Chain t i f) where     pureT = Done . unwrapF  instance Apply (Chain Day Identity f) where@@ -546,6 +650,31 @@ instance Applicative (Chain Day Identity f) where     pure  = Done . Identity     (<*>) = (<.>)++-- | @since 0.3.0.0+instance Divise (Chain CD.Day Proxy f) where+    divise f x y = appendChain $ CD.Day x y f++-- | @'Chain' 'CD.Day' 'Proxy'@ is the free "monoid in the monoidal+-- category of endofunctors enriched by contravariant 'CD.Day'" --- aka,+-- the free 'Divisible'.+--+-- @since 0.3.0.0+instance Divisible (Chain CD.Day Proxy f) where+    divide f x y = appendChain $ CD.Day x y f+    conquer = Done Proxy++-- | @since 0.3.0.0+instance Decide (Chain N.Night N.Not f) where+    decide f x y = appendChain $ N.Night x y f++-- | @'Chain' 'N.Night' 'N.Refutec'@ is the free "monoid in the monoidal+-- category of endofunctors enriched by 'N.Night'" --- aka, the free+-- 'Conclude'.+--+-- @since 0.3.0.0+instance Conclude (Chain N.Night N.Not f) where+    conclude = Done . N.Not  instance Apply (Chain Comp Identity f) where     (<.>) = apDefault

@@ -25,7 +25,7 @@ import           Control.Applicative.Lift import           Control.Applicative.ListF import           Control.Monad-import           Control.Monad.Freer.Church hiding (toFree)+import           Control.Monad.Freer.Church hiding         (toFree) import           Control.Monad.Reader import           Control.Monad.Trans.Identity import           Control.Natural@@ -33,13 +33,22 @@ import           Data.Constraint.Trivial import           Data.Functor.Apply.Free import           Data.Functor.Bind+import           Data.Functor.Contravariant+import           Data.Functor.Contravariant.Conclude+import           Data.Functor.Contravariant.Decide+import           Data.Functor.Contravariant.Divise+import           Data.Functor.Contravariant.Divisible+import           Data.Functor.Contravariant.Divisible.Free import           Data.Functor.Coyoneda+import           Data.Functor.Invariant import           Data.Functor.Plus import           Data.HFunctor import           Data.HFunctor.Interpret+import           Data.Kind import           Data.Pointed-import qualified Control.Alternative.Free          as Alt-import qualified Control.Applicative.Free.Fast     as FAF+import qualified Control.Alternative.Free                  as Alt+import qualified Control.Applicative.Free.Fast             as FAF+import qualified Data.Functor.Contravariant.Coyoneda       as CCY  -- | A simple way to inject/reject into any eventual typeclass. --@@ -135,6 +144,12 @@     pure x = liftFinal0 (pure x)     (<*>)  = liftFinal2 (<*>)     liftA2 f = liftFinal2 (liftA2 f)+-- | @since 0.3.0.0+instance Alt (Final Alternative f) where+    (<!>) = liftFinal2 (<|>)+-- | @since 0.3.0.0+instance Plus (Final Alternative f) where+    zero = liftFinal0 empty instance Alternative (Final Alternative f) where     empty = liftFinal0 empty     (<|>) = liftFinal2 (<|>)@@ -165,6 +180,12 @@     x >>= f  = Final $ \r -> do       y <- runFinal x r       runFinal (f y) r+-- | @since 0.3.0.0+instance Alt (Final MonadPlus f) where+    (<!>) = liftFinal2 (<|>)+-- | @since 0.3.0.0+instance Plus (Final MonadPlus f) where+    zero = liftFinal0 empty instance Alternative (Final MonadPlus f) where     empty = liftFinal0 empty     (<|>) = liftFinal2 (<|>)@@ -205,6 +226,67 @@ instance Plus (Final Plus f) where     zero = liftFinal0 zero +-- | @since 0.3.0.0+instance Contravariant (Final Contravariant f) where+    contramap f = liftFinal1 (contramap f)++-- | @since 0.3.0.0+instance Contravariant (Final Divise f) where+    contramap f = liftFinal1 (contramap f)+-- | @since 0.3.0.0+instance Divise (Final Divise f) where+    divise f = liftFinal2 (divise f)++-- | @since 0.3.0.0+instance Contravariant (Final Divisible f) where+    contramap f = liftFinal1 (contramap f)+-- | @since 0.3.0.0+instance Divise (Final Divisible f) where+    divise f = liftFinal2 (divide f)+-- | @since 0.3.0.0+instance Divisible (Final Divisible f) where+    divide f = liftFinal2 (divide f)+    conquer = liftFinal0 conquer++-- | @since 0.3.0.0+instance Contravariant (Final Decide f) where+    contramap f = liftFinal1 (contramap f)+-- | @since 0.3.0.0+instance Decide (Final Decide f) where+    decide f = liftFinal2 (decide f)++-- | @since 0.3.0.0+instance Contravariant (Final Conclude f) where+    contramap f = liftFinal1 (contramap f)+-- | @since 0.3.0.0+instance Decide (Final Conclude f) where+    decide f = liftFinal2 (decide f)+-- | @since 0.3.0.0+instance Conclude (Final Conclude f) where+    conclude f = liftFinal0 (conclude f)++-- | @since 0.3.0.0+instance Contravariant (Final Decidable f) where+    contramap f = liftFinal1 (contramap f)+-- | @since 0.3.0.0+instance Divisible (Final Decidable f) where+    divide f = liftFinal2 (divide f)+    conquer = liftFinal0 conquer+-- | @since 0.3.0.0+instance Decide (Final Decidable f) where+    decide f = liftFinal2 (choose f)+-- | @since 0.3.0.0+instance Conclude (Final Decidable f) where+    conclude f = liftFinal0 (lose f)+-- | @since 0.3.0.0+instance Decidable (Final Decidable f) where+    choose f = liftFinal2 (choose f)+    lose f = liftFinal0 (lose f)++-- | @since 0.3.0.0+instance Invariant (Final Invariant f) where+    invmap f g = liftFinal1 (invmap f g)+ -- | Re-interpret the context under a 'Final'. hoistFinalC     :: (forall g x. (c g => g x) -> (d g => g x))@@ -285,8 +367,15 @@ -- that you can pattern match on and inspect, but @t@ might.  This lets you -- work on a concrete structure if you desire. class FreeOf c t | t -> c where+    -- | What "type" of functor is expected: should be either+    -- 'Unconstrained', 'Functor', 'Contravariant', or 'Invariant'.+    --+    -- @since 0.3.0.0+    type FreeFunctorBy t :: (Type -> Type) -> Constraint+    type FreeFunctorBy t = Unconstrained+     fromFree :: t f ~> Final c f-    toFree   :: Functor f => Final c f ~> t f+    toFree   :: FreeFunctorBy t f => Final c f ~> t f      default fromFree :: Interpret t (Final c f) => t f ~> Final c f     fromFree = toFinal@@ -294,10 +383,12 @@     toFree = fromFinal  -- | The isomorphism between a free structure and its encoding as 'Final'.-finalizing :: (FreeOf c t, Functor f) => t f <~> Final c f+finalizing :: (FreeOf c t, FreeFunctorBy t f) => t f <~> Final c f finalizing = isoF fromFree toFree  instance FreeOf Functor       Coyoneda+-- | @since 0.3.0.0+instance FreeOf Contravariant CCY.Coyoneda instance FreeOf Applicative   Ap instance FreeOf Apply         Ap1 instance FreeOf Applicative   FAF.Ap@@ -306,6 +397,20 @@ instance FreeOf Bind          Free1 instance FreeOf Pointed       Lift instance FreeOf Pointed       MaybeApply-instance FreeOf Alt           NonEmptyF-instance FreeOf Plus          ListF+-- | This could also be @'FreeOf' 'Divise'@ if @'FreeFunctorBy' 'NonEmptyF'+-- ~ 'Contravariant'@.  However, there isn't really a way to express this+-- at the moment.+instance FreeOf Alt           NonEmptyF  where type FreeFunctorBy NonEmptyF = Functor+-- | This could also be @'FreeOf' 'Divisible'@ if @'FreeFunctorBy' 'ListF'+-- ~ 'Contravariant'@.  However, there isn't really a way to express this+-- at the moment.+instance FreeOf Plus          ListF      where type FreeFunctorBy ListF = Functor+-- | @since 0.3.0.0+instance FreeOf Divise        Div1+-- | @since 0.3.0.0+instance FreeOf Divisible     Div+-- | @since 0.3.0.0+instance FreeOf Decide        Dec1+-- | @since 0.3.0.0+instance FreeOf Conclude      Dec instance FreeOf Unconstrained IdentityT

@@ -25,8 +25,9 @@ import           Data.Bifunctor.Joker import           Data.Coerce import           Data.Functor.Bind+import           Data.Functor.Contravariant.Night    (Night(..)) import           Data.Functor.Coyoneda-import           Data.Functor.Day               (Day(..))+import           Data.Functor.Day                    (Day(..)) import           Data.Functor.Identity import           Data.Functor.Product import           Data.Functor.Reverse@@ -37,14 +38,20 @@ import           Data.Proxy import           Data.Tagged import           Data.Vinyl.CoRec-import           Data.Vinyl.Core                (Rec)+import           Data.Vinyl.Core                     (Rec) import           Data.Vinyl.Recursive import           GHC.Generics-import qualified Control.Alternative.Free       as Alt-import qualified Control.Applicative.Free.Fast  as FAF-import qualified Control.Applicative.Free.Final as FA-import qualified Control.Monad.Free.Church      as MC-import qualified Data.Functor.Day               as D+import qualified Control.Alternative.Free            as Alt+import qualified Control.Applicative.Free.Fast       as FAF+import qualified Control.Applicative.Free.Final      as FA+import qualified Control.Monad.Free.Church           as MC+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.SOP                            as SOP+import qualified Data.SOP.NP                         as SOP+import qualified Data.SOP.NS                         as SOP  -- | An 'HFunctor' can be thought of a unary "functor transformer" --- -- a basic functor combinator.  It takes a functor as input and returns@@ -184,6 +191,10 @@ instance HFunctor Coyoneda where     hmap = hoistCoyoneda +-- | @since 0.3.0.0+instance HFunctor CCY.Coyoneda where+    hmap f (CCY.Coyoneda g x) = CCY.Coyoneda g (f x)+ instance HFunctor Ap where     hmap = hoistAp @@ -286,6 +297,14 @@ instance HFunctor CoRec where     hmap f (CoRec x) = CoRec (f x) +-- | @since 0.3.0.0+instance HFunctor SOP.NP where+    hmap f = SOP.cata_NP SOP.Nil ((SOP.:*) . f)++-- | @since 0.3.0.0+instance HFunctor SOP.NS where+    hmap f = SOP.cata_NS (SOP.Z . f) SOP.S+ instance HBifunctor (:*:) where     hleft  f (x :*: y) = f x :*:   y     hright g (x :*: y) =   x :*: g y@@ -300,6 +319,18 @@     hleft  = D.trans1     hright = D.trans2     hbimap f g (Day x y z) = Day (f x) (g y) z++-- | @since 0.3.0.0+instance HBifunctor CD.Day where+    hleft  = CD.trans1+    hright = CD.trans2+    hbimap f g (CD.Day x y z) = CD.Day (f x) (g y) z++-- | @since 0.3.0.0+instance HBifunctor Night where+    hleft  = N.trans1+    hright = N.trans2+    hbimap f g (Night x y z) = Night (f x) (g y) z  instance HBifunctor (:+:) where     hleft f = \case

@@ -54,7 +54,7 @@ import           Control.Applicative.Lift import           Control.Applicative.ListF import           Control.Applicative.Step-import           Control.Comonad.Trans.Env      (EnvT(..))+import           Control.Comonad.Trans.Env           (EnvT(..)) import           Control.Monad.Freer.Church import           Control.Monad.Reader import           Control.Monad.Trans.Compose@@ -64,6 +64,7 @@ import           Data.Data import           Data.Functor.Bind import           Data.Functor.Classes+import           Data.Functor.Contravariant import           Data.Functor.Coyoneda import           Data.Functor.Plus import           Data.Functor.Product@@ -75,11 +76,12 @@ import           Data.Pointed import           Data.Semigroup.Foldable import           GHC.Generics-import qualified Control.Alternative.Free       as Alt-import qualified Control.Applicative.Free       as Ap-import qualified Control.Applicative.Free.Fast  as FAF-import qualified Control.Applicative.Free.Final as FA-import qualified Data.Map.NonEmpty              as NEM+import qualified Control.Alternative.Free            as Alt+import qualified Control.Applicative.Free            as Ap+import qualified Control.Applicative.Free.Fast       as FAF+import qualified Control.Applicative.Free.Final      as FA+import qualified Data.Functor.Contravariant.Coyoneda as CCY+import qualified Data.Map.NonEmpty                   as NEM  -- | An 'Interpret' lets us move in and out of the "enhanced" 'Functor' (@t -- f@) and the functor it enhances (@f@).  An instance @'Interpret' t f@@@ -197,6 +199,13 @@ instance Functor f => Interpret Coyoneda f where     retract                    = lowerCoyoneda     interpret f (Coyoneda g x) = g <$> f x++-- | A free 'Contravariant'+--+-- @since 0.3.0.0+instance Contravariant f => Interpret CCY.Coyoneda f where+    retract                        = CCY.lowerCoyoneda+    interpret f (CCY.Coyoneda g x) = contramap g (f x)  -- | A free 'Applicative' instance Applicative f => Interpret Ap.Ap f where

@@ -40,8 +40,10 @@ associatingProp     :: forall t f g h m a.      ( Associative t+     , FunctorBy t f+     , FunctorBy t g+     , FunctorBy t h      , Monad m-     , Functor f, Functor g, Functor h      , Show (t f (t g h) a)      , Show (t (t f g) h a)      , Eq (t f (t g h) a)@@ -55,8 +57,8 @@ matchingNEProp     :: forall t f m a.      ( Associative t+     , FunctorBy t f      , Monad m-     , Functor f      , Show (f a), Eq (f a)      , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)      , Show (t f (NonEmptyBy t f) a), Eq (t f (NonEmptyBy t f) a)@@ -71,7 +73,6 @@     :: forall t f m a.      ( SemigroupIn t f      , Monad m-     , Functor f      , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)      , Show (f a), Eq (f a)      , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)@@ -137,8 +138,8 @@ rightIdentityProp     :: forall t i f m a.      ( Tensor t i+     , FunctorBy t f      , Monad m-     , Functor f      , Show (f a), Eq (f a)      , Show (t f i a), Eq (t f i a)      )@@ -150,8 +151,8 @@ leftIdentityProp     :: forall t i g m a.      ( Tensor t i+     , FunctorBy t g      , Monad m-     , Functor g      , Show (g a), Eq (g a)      , Show (t i g a), Eq (t i g a)      )@@ -229,6 +230,7 @@ splittingNEProp     :: forall t i f m a.      ( Matchable t i+     , FunctorBy t f      , Monad m      , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)      , Show (t f (ListBy t f) a), Eq (t f (ListBy t f) a)@@ -241,6 +243,7 @@ matchingLBProp     :: forall t i f m a.      ( Matchable t i+     , FunctorBy t f      , Monad m      , Show (i a), Eq (i a)      , Show (ListBy t f a), Eq (ListBy t f a)@@ -254,8 +257,8 @@ matchingChainProp     :: forall t i f m a.      ( Matchable t i+     , FunctorBy t f      , Monad m-     , Functor f      , Show (f a), Eq (f a)      , Show (i a), Eq (i a)      , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)@@ -303,7 +306,6 @@      , Interpret (NonEmptyBy t) f      , TestHBifunctor t      , TestHFunctor (NonEmptyBy t)-     , Functor f      , Show (t f (t f f) a)     , Eq (t f (t f f) a)      , Show (t (t f f) f a)     , Eq (t (t f f) f a)      , Show (t f f a)@@ -311,6 +313,7 @@      , Show (NonEmptyBy t f a)          , Eq (NonEmptyBy t f a)      , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)      , Show (f a)               , Eq (f a)+     , TestHFunctorBy (NonEmptyBy t) f      )     => Gen (f a)     -> TestTree@@ -332,7 +335,6 @@      , TestHBifunctor t      , TestHFunctor (ListBy t)      , TestHFunctor (NonEmptyBy t)-     , Functor f      , Show (t f i a)            , Eq (t f i a)      , Show (t i f a)            , Eq (t i f a)      , Show (t f (ListBy t f) a)         , Eq (t f (ListBy t f) a)@@ -342,6 +344,8 @@      , Show (NonEmptyBy t f a)      , Show (i a)                  , Eq (i a)      , Show (f a)                    , Eq (f a)+     , TestHFunctorBy (ListBy t) f+     , TestHFunctorBy (NonEmptyBy t) f      )     => Gen (f a)     -> Maybe (Gen (i a))@@ -361,10 +365,10 @@ matchableProps     :: forall t i f a.      ( Matchable t i+     , FunctorBy t f      , TestHBifunctor t      , TestHFunctor (ListBy t)      , TestHFunctor (NonEmptyBy t)-     , Functor f      , Show (t f (ListBy t f) a)         , Eq (t f (ListBy t f) a)      , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)      , Show (t f (Chain1 t f) a)     , Eq (t f (Chain1 t f) a)@@ -372,6 +376,8 @@      , Show (NonEmptyBy t f a)               , Eq (NonEmptyBy t f a)      , Show (i a)                  , Eq (i a)      , Show (f a)                    , Eq (f a)+     , TestHFunctorBy (ListBy t) f+     , TestHFunctorBy (NonEmptyBy t) f      )     => Gen (f a)     -> Maybe (Gen (i a))@@ -389,7 +395,6 @@      , Interpret (NonEmptyBy t) f      , TestHBifunctor t      , TestHFunctor (NonEmptyBy t)-     , Functor f      , Show (t f (t f f) a)     , Eq (t f (t f f) a)      , Show (t (t f f) f a)     , Eq (t (t f f) f a)      , Show (t f f a)           , Eq (t f f a)@@ -397,6 +402,7 @@      , Show (NonEmptyBy t f a)          , Eq (NonEmptyBy t f a)      , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)      , Show (f a)               , Eq (f a)+     , TestHFunctorBy (NonEmptyBy t) f      )     => Gen (f a)     -> [TestTree]@@ -410,7 +416,6 @@      , TestHBifunctor t      , TestHFunctor (ListBy t)      , TestHFunctor (NonEmptyBy t)-     , Functor f      , Show (t f (t f f) a)          , Eq (t f (t f f) a)      , Show (t (t f f) f a)          , Eq (t (t f f) f a)      , Show (t f i a)            , Eq (t f i a)@@ -424,6 +429,8 @@      , Show (NonEmptyBy t f a)               , Eq (NonEmptyBy t f a)      , Show (i a)                  , Eq (i a)      , Show (f a)                    , Eq (f a)+     , TestHFunctorBy (NonEmptyBy t) f+     , TestHFunctorBy (ListBy t) f      )     => Gen (f a)     -> Maybe (Gen (i a))@@ -439,7 +446,6 @@      , TestHBifunctor t      , TestHFunctor (ListBy t)      , TestHFunctor (NonEmptyBy t)-     , Functor f      , Show (t f (t f f) a)          , Eq (t f (t f f) a)      , Show (t (t f f) f a)          , Eq (t (t f f) f a)      , Show (t f i a)            , Eq (t f i a)@@ -453,6 +459,8 @@      , Show (NonEmptyBy t f a)               , Eq (NonEmptyBy t f a)      , Show (i a)                  , Eq (i a)      , Show (f a)                    , Eq (f a)+     , TestHFunctorBy (ListBy t) f+     , TestHFunctorBy (NonEmptyBy t) f      )     => Gen (f a)     -> Maybe (Gen (i a))

@@ -104,6 +104,7 @@     :: forall t f a.      ( TestHFunctor t      , Show (t f a), Eq (t f a)+     , TestHFunctorBy t f      )     => Gen (f a)     -> TestTree@@ -119,6 +120,9 @@      , Show (t f a)        , Eq (t f a)      , Show (t (t f) a)      , Show (t (t (t f)) a)+     , TestHFunctorBy t (t (t f))+     , TestHFunctorBy t (t f)+     , TestHFunctorBy t f      )     => Gen (f a)     -> TestTree@@ -135,6 +139,7 @@      , TestHFunctor t      , Show (f a)          , Eq (f a)      , Show (t f a)+     , TestHFunctorBy t f      )     => Gen (f a)     -> TestTree@@ -151,6 +156,9 @@      , Show (t f a)        , Eq (t f a)      , Show (t (t f) a)      , Show (t (t (t f)) a)+     , TestHFunctorBy t f+     , TestHFunctorBy t (t f)+     , TestHFunctorBy t (t (t f))      )     => Gen (f a)     -> [TestTree]@@ -164,6 +172,7 @@      , TestHFunctor t      , Show (f a)          , Eq (f a)      , Show (t f a)        , Eq (t f a)+     , TestHFunctorBy t f      )     => Gen (f a)     -> [TestTree]@@ -181,6 +190,9 @@      , Show (t f a)        , Eq (t f a)      , Show (t (t f) a)      , Show (t (t (t f)) a)+     , TestHFunctorBy t (t (t f))+     , TestHFunctorBy t (t f)+     , TestHFunctorBy t f      )     => Gen (f a)     -> [TestTree]

@@ -15,6 +15,7 @@ import           Control.Monad.Freer.Church import           Control.Natural.IsoF import           Data.Bifunctor.Joker+import           Data.Constraint.Trivial import           Data.Function import           Data.Functor import           Data.Functor.Bind@@ -91,15 +92,15 @@ instance (GShow f, GShow g) => Show (Day f g a) where     showsPrec = gshowsPrec -instance GShow f => GShow (Ap1 f) where+instance (GShow f, Functor f) => GShow (Ap1 f) where     gshowsPrec d (Ap1 x y) = case matchLB @Day y of       L1 _  -> showsUnaryWith gshowsPrec "inject" d x       R1 ys -> showsBinaryWith gshowsPrec gshowsPrec "Ap1" d x ys -instance GShow f => Eq (Ap1 f a) where+instance (GShow f, Functor f) => Eq (Ap1 f a) where     (==) = (==) `on` show -instance GShow f => Show (Ap1 f a) where+instance (GShow f, Functor f) => Show (Ap1 f a) where     showsPrec = gshowsPrec  instance GShow f => GShow (Ap f) where@@ -159,8 +160,10 @@     liftEq _ = \case {}  class HFunctor t => TestHFunctor t where+    type TestHFunctorBy t :: (Type -> Type) -> Constraint+    type TestHFunctorBy t = Unconstrained     genHF-        :: MonadGen m+        :: (MonadGen m, TestHFunctorBy t f)         => m (f a)         -> m (t f a) @@ -240,6 +243,7 @@            <$> Gen.nonEmpty (Range.linear 1 3) gx  instance TestHFunctor t => TestHFunctor (HLift t) where+    type TestHFunctorBy (HLift t) = TestHFunctorBy t     genHF gx = Gen.bool >>= \case       False -> HPure  <$> gx       True  -> HOther <$> genHF gx@@ -247,7 +251,11 @@ instance (Enum e, Bounded e) => TestHFunctor (EnvT e) where     genHF gx = EnvT <$> Gen.enumBounded <*> gx +class (c f, d f) => AndC c d f+instance (c f, d f) => AndC c d f+ instance (TestHFunctor s, HTraversable s, TestHFunctor t) => TestHFunctor (ComposeT s t) where+    type TestHFunctorBy (ComposeT s t) = AndC (TestHFunctorBy s) (TestHFunctorBy t)     genHF gx = fmap ComposeT              . htraverse (genHF @t . pure)            =<< genHF @s gx