subcategories (empty) → 0.1.0.0

raw patch · 23 files changed

+4099/−0 lines, 23 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, containers, data-default, foldl, hashable, inspection-testing, mono-traversable, pointed, primitive, reflection, semialign, subcategories, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, template-haskell, text, these, unordered-containers, vector, vector-algorithms, vector-builder

Files

• ChangeLog.md +4/−0
• LICENSE +30/−0
• README.md +32/−0
• Setup.hs +2/−0
• src/Control/Subcategory.hs +17/−0
• src/Control/Subcategory/Alternative.hs +159/−0
• src/Control/Subcategory/Alternative/Class.hs +20/−0
• src/Control/Subcategory/Applicative.hs +168/−0
• src/Control/Subcategory/Applicative/Class.hs +22/−0
• src/Control/Subcategory/Bind.hs +147/−0
• src/Control/Subcategory/Foldable.hs +1606/−0
• src/Control/Subcategory/Functor.hs +375/−0
• src/Control/Subcategory/Pointed.hs +131/−0
• src/Control/Subcategory/RebindableSyntax.hs +33/−0
• src/Control/Subcategory/Semialign.hs +302/−0
• src/Control/Subcategory/Wrapper/Internal.hs +55/−0
• src/Control/Subcategory/Zip.hs +386/−0
• subcategories.cabal +112/−0
• test/Control/Subcategory/FoldableSpec.hs +208/−0
• test/Control/Subcategory/FunctorSpec.hs +231/−0
• test/Control/Subcategory/ZipSpec.hs +38/−0
• test/Shared.hs +19/−0
• test/spec.hs +2/−0

@@ -0,0 +1,4 @@+# Changelog for subcategories++## 0.1.0.0+Initial Release

@@ -0,0 +1,30 @@+Copyright Hiromi ISHII (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Hiromi ISHII nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,32 @@+# The `subcategories` package++This package provides variants of functor-like structures,+with domain types are constrained.+In particular, this package provides an abstraction for functorial+containers, which can be expressed as a functor from a *full-subcategory*+of **Hask** to **Hask** itself [^1].++For example:++- We can treat `Set` as if it is a `Fuctor`, `Foldable`, `Applicative`,+  with their domain restricted to full-subcategory **Ord** of `Ord` instances+  of **Hask**.+- For `MonoFoldable` or `MonoTraversable` types (from `mono-traversable` package),+  we provide `WrapMono` wrapper with zero-cost coercion. Such `mono`s can be+  regarded as a functorial structure from the full subcategory consisting of just a single object,+  say `Element mono`.++[^1]: Strictly speaking, `CFoldable`, a constrained counterpart of `Foldable`, doesn't require a functoriality as with the original `Foldable`.++## Optimisation+This library is designed to keep the abstraction runtime overhead as minimum as possible.++Some notes:++- If a constrained term such as `cmap` or `czipWith` has concrete type, it must have exactly the same representation as the corresponding operation modulo (zero-cost) coercion.+  * The same still holds if the set of required constraints coincides.+  * Although the constructor of `WrapMono mono a` is hidden, its just a `newtype`-wrapper around `mono`;+    hence, constrained operators must have the same representations as the corresponding combinators+    in `mono-traversable` package.+- OTOH, for a polymorphic term, like `cmap :: (Ord a, Ord b) => (a -> b) Set a -> Set b`+  and `Set.map`, they can have different representations; indeed, `Set.map` doesn't require `a` to be `Ord`-instance and therefore the implementation of `cmap` discards the dictionary for `Ord a` to call `Set.map`.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,17 @@+module Control.Subcategory+  ( module Control.Subcategory.Applicative+  , module Control.Subcategory.Alternative+  , module Control.Subcategory.Bind+  , module Control.Subcategory.Functor+  , module Control.Subcategory.Foldable+  , module Control.Subcategory.Zip+  , module Control.Subcategory.Pointed+  ) where++import Control.Subcategory.Alternative+import Control.Subcategory.Applicative+import Control.Subcategory.Bind+import Control.Subcategory.Foldable+import Control.Subcategory.Functor+import Control.Subcategory.Pointed+import Control.Subcategory.Zip

@@ -0,0 +1,159 @@+{-# LANGUAGE EmptyCase, ScopedTypeVariables, StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Control.Subcategory.Alternative+  (CAlternative(..), CChoice(..), CAlt(..)) where+import Control.Subcategory.Alternative.Class+import Control.Subcategory.Applicative.Class+import Control.Subcategory.Functor+import Control.Subcategory.Pointed++import qualified Control.Applicative             as App+import           Data.Coerce                     (coerce)+import qualified Data.Functor.Compose            as SOP+import qualified Data.Functor.Product            as SOP+import           Data.Hashable                   (Hashable)+import qualified Data.HashMap.Strict             as HM+import qualified Data.HashSet                    as HS+import qualified Data.IntMap                     as IM+import           Data.List.NonEmpty              (NonEmpty)+import qualified Data.Map                        as Map+import           Data.MonoTraversable            (GrowingAppend, MonoFunctor)+import qualified Data.Primitive.Array            as A+import qualified Data.Primitive.PrimArray        as PA+import qualified Data.Primitive.SmallArray       as SA+import qualified Data.Semigroup                  as Sem+import qualified Data.Sequence                   as Seq+import qualified Data.Set                        as Set+import qualified Data.Vector                     as V+import qualified Data.Vector.Primitive           as P+import qualified Data.Vector.Storable            as S+import qualified Data.Vector.Unboxed             as U+import           Text.ParserCombinators.ReadP    (ReadP)+import           Text.ParserCombinators.ReadPrec (ReadPrec)++instance CChoice []+instance CChoice Maybe+instance CChoice V.Vector+instance CChoice U.Vector where+  (<!>) = (<>)+  {-# INLINE [1] (<!>) #-}+instance CChoice S.Vector where+  (<!>) = (<>)+  {-# INLINE [1] (<!>) #-}+instance CChoice P.Vector where+  (<!>) = (<>)+  {-# INLINE [1] (<!>) #-}+instance CChoice PA.PrimArray where+  (<!>) = (<>)+  {-# INLINE [1] (<!>) #-}+instance CChoice SA.SmallArray+instance CChoice A.Array+instance CChoice Seq.Seq+instance CChoice Sem.Option+instance CChoice NonEmpty where+  (<!>) = (Sem.<>)+  {-# INLINE (<!>) #-}+instance CChoice (Either a) where+  Left _ <!> b = b+  a      <!> _ = a+  {-# INLINE (<!>) #-}+instance CChoice IM.IntMap where+  (<!>) = IM.union+instance CChoice ReadP+instance CChoice ReadPrec+instance (CChoice f, CFunctor g) => CChoice (SOP.Compose f g) where+  SOP.Compose a <!> SOP.Compose b = SOP.Compose (a <!> b)+  {-# INLINE (<!>) #-}++instance (CChoice f, CChoice g) => CChoice (SOP.Product f g) where+  SOP.Pair a1 b1 <!> SOP.Pair a2 b2 =+    SOP.Pair (a1 <!> a2) (b1 <!> b2)+  {-# INLINE (<!>) #-}++instance CChoice HS.HashSet where+  (<!>) = HS.union+  {-# INLINE (<!>) #-}++instance CChoice Set.Set where+  (<!>) = Set.union+  {-# INLINE (<!>) #-}++instance Ord k => CChoice (Map.Map k) where+  (<!>) = Map.union+  {-# INLINE (<!>) #-}++instance+    (MonoFunctor mono, GrowingAppend mono, Semigroup mono)+  => CChoice (WrapMono mono) where+  (<!>) = (<>)+  {-# INLINE [1] (<!>) #-}++instance (Eq k, Hashable k) => CChoice (HM.HashMap k) where+  (<!>) = HM.union+  {-# INLINE (<!>) #-}++instance CAlternative IM.IntMap where+  cempty = IM.empty+  {-# INLINE cempty #-}+instance (Eq k, Hashable k) => CAlternative (HM.HashMap k) where+  cempty = HM.empty+  {-# INLINE cempty #-}+instance Ord k => CAlternative (Map.Map k) where+  cempty = Map.empty+  {-# INLINE cempty #-}+instance CAlternative HS.HashSet where+  cempty = HS.empty+  {-# INLINE cempty #-}+instance CAlternative Set.Set where+  cempty = Set.empty+  {-# INLINE cempty #-}+instance (MonoFunctor mono, Monoid mono, GrowingAppend mono)+      => CAlternative (WrapMono mono) where+  cempty = WrapMono mempty+  {-# INLINE [1] cempty #-}++instance (CAlternative f, CFunctor g) => CAlternative (SOP.Compose f g) where+  cempty = SOP.Compose cempty+  {-# INLINE cempty #-}++instance (CAlternative f, CAlternative g) => CAlternative (SOP.Product f g) where+  cempty = SOP.Pair cempty cempty+  {-# INLINE cempty #-}++instance CAlternative []+instance CAlternative Maybe+instance CAlternative Seq.Seq+instance CAlternative Sem.Option+instance CAlternative ReadP+instance CAlternative V.Vector+instance CAlternative U.Vector where+  cempty = U.empty+  {-# INLINE [1] cempty #-}+instance CAlternative S.Vector where+  cempty = S.empty+  {-# INLINE [1] cempty #-}+instance CAlternative P.Vector where+  cempty = P.empty+  {-# INLINE [1] cempty #-}+instance CAlternative PA.PrimArray where+  cempty = PA.primArrayFromListN 0 []+  {-# INLINE [1] cempty #-}+instance CAlternative SA.SmallArray+instance CAlternative A.Array+instance CAlternative ReadPrec++newtype CAlt f a = CAlt { runAlt :: f a }+  deriving newtype (Functor, Constrained, Applicative, App.Alternative)+deriving newtype instance CFunctor f => CFunctor (CAlt f)+deriving newtype instance CChoice f => CChoice (CAlt f)+deriving newtype instance CAlternative f => CAlternative (CAlt f)+deriving newtype instance CApplicative f => CApplicative (CAlt f)+deriving newtype instance CPointed f => CPointed (CAlt f)+++instance (Dom f a, CChoice f) => Sem.Semigroup (CAlt f a) where+  (<>) = coerce @(f a -> f a -> f a) (<!>)++instance (Dom f a, CAlternative f) => Monoid (CAlt f a) where+  mempty = coerce @(f a) cempty+  mappend = coerce @(f a -> f a -> f a) (<!>)

@@ -0,0 +1,20 @@+{-# LANGUAGE EmptyCase, UndecidableSuperClasses #-}+module Control.Subcategory.Alternative.Class+  (CChoice(..), CAlternative(..)) where+import Control.Subcategory.Functor++import qualified Control.Applicative as App++infixl 3 <!>+class CFunctor f => CChoice f where+  (<!>) :: Dom f a => f a -> f a -> f a+  default (<!>) :: App.Alternative f => f a -> f a -> f a+  (<!>) = (App.<|>)+  {-# INLINE (<!>) #-}++class CChoice f => CAlternative f where+  cempty :: Dom f a => f a+  default cempty :: App.Alternative f => f a+  cempty = App.empty+  {-# INLINE cempty #-}+

@@ -0,0 +1,168 @@+{-# LANGUAGE EmptyCase, StandaloneDeriving, TupleSections #-}+{-# LANGUAGE UndecidableSuperClasses                      #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Control.Subcategory.Applicative+  ( CApplicative(..), defaultRightApply, defaultLeftApply, CApp(..)+  ) where+import Control.Subcategory.Alternative.Class+import Control.Subcategory.Applicative.Class+import Control.Subcategory.Functor+import Control.Subcategory.Pointed++import qualified Control.Applicative             as App+import qualified Control.Monad.ST.Lazy           as LST+import qualified Control.Monad.ST.Strict         as SST+import           Data.Coerce                     (coerce)+import           Data.Functor.Const              (Const)+import           Data.Functor.Identity           (Identity)+import qualified Data.Functor.Product            as SOP+import           Data.Hashable                   (Hashable)+import qualified Data.HashMap.Strict             as HM+import qualified Data.HashSet                    as HS+import qualified Data.IntMap                     as IM+import           Data.List.NonEmpty              (NonEmpty)+import qualified Data.Map                        as Map+import qualified Data.Primitive.Array            as A+import qualified Data.Primitive.SmallArray       as SA+import qualified Data.Semigroup                  as Sem+import qualified Data.Sequence                   as Seq+import qualified Data.Set                        as Set+import qualified Data.Tree                       as Tree+import qualified Data.Vector                     as V+import           GHC.Conc                        (STM)+import           Text.ParserCombinators.ReadP    (ReadP)+import           Text.ParserCombinators.ReadPrec (ReadPrec)++defaultLeftApply :: (Dom f (b1, b2), Dom f b1, Dom f b2, CApplicative f)+                 => f b1 -> f b2 -> f b1+defaultLeftApply a b = uncurry const <$:> pair a b+defaultRightApply :: (Dom f (b1, b2), Dom f b2, Dom f b1, CApplicative f)+                  => f b1 -> f b2 -> f b2+defaultRightApply a b = uncurry (const id) <$:> pair a b++instance Semigroup w => CApplicative (Const w) where+  pair = coerce @(w -> w -> w) (<>)+  (<.>) = coerce @(w -> w -> w) (<>)+  {-# INLINE (<.>) #-}+  (<. ) = coerce @(w -> w -> w) (<>)+  {-# INLINE (<. ) #-}+  ( .>) = coerce @(w -> w -> w) (<>)+  {-# INLINE ( .>) #-}++instance CApplicative []+instance CApplicative IO+instance CApplicative STM+instance CApplicative ReadP+instance CApplicative V.Vector+instance CApplicative SA.SmallArray+instance CApplicative A.Array+instance CApplicative ReadPrec+instance CApplicative (SST.ST s)+instance CApplicative (LST.ST s)+instance CApplicative App.ZipList+instance CApplicative Maybe+instance CApplicative Identity+instance CApplicative Tree.Tree+instance CApplicative Seq.Seq+instance CApplicative Sem.Option+instance CApplicative NonEmpty+instance CApplicative ((->) a)+instance CApplicative (Either a)+instance (CApplicative f, CApplicative g)+      => CApplicative (SOP.Product f g) where+  pair (SOP.Pair a b) (SOP.Pair c d) = SOP.Pair (pair a c) (pair b d)+  SOP.Pair f g <.> SOP.Pair a b = SOP.Pair (f <.> a) (g <.> b)+  {-# INLINE (<.>) #-}+  SOP.Pair f g <. SOP.Pair a b = SOP.Pair (f <. a) (g <. b)+  {-# INLINE (<.) #-}+  SOP.Pair f g .> SOP.Pair a b = SOP.Pair (f .> a) (g .> b)+  {-# INLINE (.>) #-}++class Dom f (g a -> g b) => DomOver f g a b+instance Dom f (g a -> g b) => DomOver f g a b++instance Applicative f => CApplicative (WrapFunctor f)+instance Semigroup w => CApplicative ((,) w) where+  pair (w, a) (u, b) = (w <> u, (a, b))+  {-# INLINE pair #-}+  (w, f) <.> (u, a) = (w <> u, f a)+  {-# INLINE (<.>) #-}+  (w, a) <.  (u, _) = (w <> u, a)+  {-# INLINE (<.) #-}+  (w, _)  .> (u, b) = (w <> u, b)+  {-# INLINE (.>) #-}+instance CApplicative IM.IntMap where+  pair = IM.intersectionWith (,)+  {-# INLINE pair #-}+  (<.>) = IM.intersectionWith id+  {-# INLINE (<.>) #-}+  (<.)  = IM.intersectionWith const+  {-# INLINE (<.) #-}+  (.>)  = IM.intersectionWith $ const id+  {-# INLINE (.>) #-}++instance Ord k => CApplicative (Map.Map k) where+  pair = Map.intersectionWith (,)+  {-# INLINE pair #-}+  (<.>) = Map.intersectionWith id+  {-# INLINE (<.>) #-}+  (<.)  = Map.intersectionWith const+  {-# INLINE (<.) #-}+  (.>)  = Map.intersectionWith $ const id+  {-# INLINE (.>) #-}++instance (Eq k, Hashable k) => CApplicative (HM.HashMap k) where+  pair = HM.intersectionWith (,)+  {-# INLINE pair #-}+  (<.>) = HM.intersectionWith id+  {-# INLINE (<.>) #-}+  (<.)  = HM.intersectionWith const+  {-# INLINE (<.) #-}+  (.>)  = HM.intersectionWith $ const id+  {-# INLINE (.>) #-}++instance CApplicative Set.Set where+  pair as bs = foldMap (\b -> Set.map (,b) as) bs+  {-# INLINE pair #-}+  fs <.> as = foldMap (\f -> Set.map f as) fs+  {-# INLINE (<.>) #-}+  a <. b | Set.null b = Set.empty+         | otherwise  = a+  {-# INLINE (<.) #-}+  a .> b | Set.null a = Set.empty+         | otherwise  = b+  {-# INLINE (.>) #-}++instance CApplicative HS.HashSet where+  pair as bs = foldMap (\b -> HS.map (,b) as) bs+  {-# INLINE pair #-}+  fs <.> as = foldMap (\f -> HS.map f as) fs+  {-# INLINE (<.>) #-}+  a <. b | HS.null b = HS.empty+         | otherwise  = a+  {-# INLINE (<.) #-}+  a .> b | HS.null a = HS.empty+         | otherwise  = b+  {-# INLINE (.>) #-}++instance Constrained f => Constrained (CApp f) where+  type Dom (CApp f) a = Dom f a++newtype CApp f a = CApp { runCApp :: f a }+  deriving (Read, Show, Eq, Ord)+  deriving newtype (Functor, Applicative, App.Alternative)++deriving newtype instance (CFunctor f) => CFunctor (CApp f)+deriving newtype instance (CChoice f) => CChoice (CApp f)+deriving newtype instance (CAlternative f) => CAlternative (CApp f)+deriving newtype instance (CApplicative f) => CApplicative (CApp f)+deriving newtype instance (CPointed f) => CPointed (CApp f)++instance (Dom f a, CApplicative f, Semigroup a, Dom f (a, a))+       => Semigroup (CApp f a) where+  CApp a <> CApp b = CApp $ uncurry (<>) <$:> pair a b++instance (Dom f a, CPointed f, CApplicative f, Monoid a, Dom f (a, a))+       => Monoid (CApp f a) where+  CApp a `mappend` CApp b = CApp $ uncurry mappend <$:> pair a b+  mempty = CApp $ cpure mempty

@@ -0,0 +1,22 @@+{-# LANGUAGE EmptyCase, UndecidableSuperClasses #-}+module Control.Subcategory.Applicative.Class  (CApplicative(..)) where+import Control.Subcategory.Functor++import qualified Control.Applicative as App++infixl 4 <.>+class CFunctor f => CApplicative f where+  pair :: (Dom f a, Dom f b, Dom f (a, b)) => f a -> f b -> f (a, b)+  default pair :: (Applicative f) => f a -> f b -> f (a, b)+  pair = App.liftA2 (,)+  (<.>) :: (Dom f a, Dom f b, Dom f (a -> b)) => f (a -> b) -> f a -> f b+  default (<.>) :: (Applicative f) => f (a -> b) -> f a -> f b+  (<.>) = (<*>)+  (.>) :: (Dom f a, Dom f b) => f a -> f b -> f b+  default (.>) :: Applicative f+               => f a -> f b -> f b+  (.>) = (*>)+  (<.) :: (Dom f a, Dom f b) => f a -> f b -> f a+  default (<.) :: Applicative f+               => f a -> f b -> f a+  (<.) = (<*)

@@ -0,0 +1,147 @@+module Control.Subcategory.Bind+  (CBind(..), CMonad, creturn, (-<<)) where+import Control.Subcategory.Functor+import Control.Subcategory.Pointed++import           Control.Monad                   (join)+import qualified Control.Monad.ST.Lazy           as LST+import qualified Control.Monad.ST.Strict         as SST+import           Data.Coerce                     (coerce)+import           Data.Functor.Identity           (Identity)+import qualified Data.Functor.Product            as SOP+import           Data.Hashable                   (Hashable)+import qualified Data.HashMap.Strict             as HM+import qualified Data.HashSet                    as HS+import qualified Data.IntMap                     as IM+import qualified Data.IntSet                     as IS+import           Data.List.NonEmpty              (NonEmpty)+import qualified Data.Map                        as Map+import           Data.MonoTraversable+import qualified Data.Semigroup                  as Sem+import qualified Data.Sequence                   as Seq+import qualified Data.Set                        as Set+import qualified Data.Tree                       as Tree+import           GHC.Conc                        (STM)+import           Text.ParserCombinators.ReadP    (ReadP)+import           Text.ParserCombinators.ReadPrec (ReadPrec)++class CFunctor m => CBind m where+  (>>-) :: (Dom m a, Dom m b) => m a -> (a -> m b) -> m b+  default (>>-) :: (Dom m a, Dom m b, Dom m (m b)) => m a -> (a -> m b) -> m b+  m >>- f = cjoin (cmap f m)+  cjoin :: (Dom m (m a), Dom m a) => m (m a) -> m a+  cjoin = (>>- id)++instance (Monad m) => CBind (WrapFunctor m) where+  (>>-) :: forall a b.+           WrapFunctor m a+        -> (a -> WrapFunctor m b) -> WrapFunctor m b+  (>>-) = coerce @(m a -> (a -> m b) -> m b) (>>=)+  cjoin :: forall a. WrapFunctor m (WrapFunctor m a) -> WrapFunctor m a+  cjoin (WrapFunctor m) = WrapFunctor $ join (fmap coerce m)++instance CBind [] where+  (>>-) = (>>=)+  cjoin  = concat++instance CBind IO where+  (>>-) = (>>=)++instance CBind STM where+  (>>-) = (>>=)++instance CBind (SST.ST s) where+  (>>-) = (>>=)++instance CBind (LST.ST s) where+  (>>-) = (>>=)++instance CBind Identity where+  (>>-) = (>>=)++instance CBind (Either a) where+  (>>-) = (>>=)++instance CBind Tree.Tree where+  (>>-) = (>>=)++instance CBind Maybe where+  (>>-) = (>>=)++instance CBind IM.IntMap where+  m >>- f = IM.mapMaybeWithKey (\k -> IM.lookup k . f) m++instance Ord k => CBind (Map.Map k) where+  m >>- f = Map.mapMaybeWithKey (\k -> Map.lookup k . f) m++instance (Hashable k, Eq k) => CBind (HM.HashMap k) where+  m >>- f = HM.mapMaybeWithKey (\k -> HM.lookup k . f) m++instance CBind Set.Set where+  (>>-) = flip foldMap+  {-# INLINE (>>-) #-}+  cjoin = foldMap id+  {-# INLINE cjoin #-}++instance CBind (WrapMono IS.IntSet) where+  (>>-) = withMonoCoercible $ flip ofoldMap+  {-# INLINE (>>-) #-}++instance CBind NonEmpty where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance CBind Seq.Seq where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance CBind Sem.Option where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance CBind ((->) a) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance CBind HS.HashSet where+  (>>-) = flip foldMap+  {-# INLINE (>>-) #-}+  cjoin = foldMap id+  {-# INLINE cjoin #-}++instance CBind ReadP where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance CBind ReadPrec where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance Semigroup w => CBind ((,) w) where+  (m, a) >>- f =+    let (w, b) = f a+    in (m <> w, b)+  {-# INLINE (>>-) #-}+  cjoin (w, (m, a)) = (w <> m, a)+  {-# INLINE cjoin #-}++infixl 1 >>-+infixr 1 -<<++(-<<) :: (Dom m b, Dom m a, CBind m) => (a -> m b) -> m a -> m b+(-<<) = flip (>>-)+{-# INLINE (-<<) #-}++instance (CBind m, CBind n) => CBind (SOP.Product m n) where+  (SOP.Pair a b) >>- f = SOP.Pair (a >>- fstP . f) (b >>- sndP . f)+    where+      fstP (SOP.Pair x _) = x+      sndP (SOP.Pair _ y) = y+  {-# INLINE (>>-) #-}++class    (CBind f, CPointed f) => CMonad f+instance (CBind f, CPointed f) => CMonad f++creturn :: (Dom m a, CMonad m) => a -> m a+creturn = cpure+{-# INLINE creturn #-}

@@ -0,0 +1,1606 @@+{-# LANGUAGE BangPatterns, CPP, DefaultSignatures, DerivingVia, LambdaCase #-}+{-# LANGUAGE OverloadedStrings, QuantifiedConstraints, StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell, TypeOperators                                #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Control.Subcategory.Foldable+  ( CFoldable(..),+    ctoList,+    CTraversable(..),+    CFreeMonoid(..),+    cfromList,+    cfolded, cfolding,+    cctraverseFreeMonoid,+    cctraverseZipFreeMonoid+  ) where+import           Control.Applicative                  (ZipList, getZipList)+import           Control.Arrow                        (first, second, (***))+import qualified Control.Foldl                        as L+import           Control.Monad                        (forM)+import           Control.Subcategory.Applicative+import           Control.Subcategory.Functor+import           Control.Subcategory.Pointed+import           Control.Subcategory.Wrapper.Internal+import           Control.Subcategory.Zip+import           Data.Coerce+import           Data.Complex                         (Complex)+import           Data.Foldable+import           Data.Functor.Const                   (Const)+import           Data.Functor.Contravariant           (Contravariant, contramap,+                                                       phantom)+import           Data.Functor.Identity                (Identity)+import qualified Data.Functor.Product                 as SOP+import qualified Data.Functor.Sum                     as SOP+import qualified Data.HashMap.Strict                  as HM+import qualified Data.HashSet                         as HS+import qualified Data.IntMap.Strict                   as IM+import qualified Data.IntSet                          as IS+import           Data.Kind                            (Type)+import           Data.List                            (uncons)+import           Data.List                            (intersperse)+import           Data.List                            (nub)+import qualified Data.List                            as List+import           Data.List.NonEmpty                   (NonEmpty)+import qualified Data.List.NonEmpty                   as NE+import qualified Data.Map                             as M+import           Data.Maybe+import           Data.Monoid+import qualified Data.Monoid                          as Mon+import           Data.MonoTraversable                 hiding (WrappedMono,+                                                       unwrapMono)+import           Data.Ord                             (Down)+import qualified Data.Primitive.Array                 as A+import qualified Data.Primitive.PrimArray             as PA+import qualified Data.Primitive.SmallArray            as SA+import           Data.Proxy                           (Proxy)+import           Data.Semigroup                       (Arg, Max (..), Min (..),+                                                       Option)+import qualified Data.Semigroup                       as Sem+import qualified Data.Sequence                        as Seq+import           Data.Sequences                       (IsSequence (indexEx))+import qualified Data.Sequences                       as MT+import qualified Data.Set                             as Set+import qualified Data.Text                            as T+import qualified Data.Vector                          as V+import qualified Data.Vector.Algorithms.Intro         as AI+import qualified Data.Vector.Primitive                as P+import qualified Data.Vector.Storable                 as S+import qualified Data.Vector.Unboxed                  as U+import           Foreign.Ptr                          (Ptr)+import qualified GHC.Exts                             as GHC+import           GHC.Generics+import           Language.Haskell.TH                  hiding (Type)+import           Language.Haskell.TH.Syntax           hiding (Type)+import qualified VectorBuilder.Builder                as VB+import qualified VectorBuilder.Vector                 as VB++-- See Note [Function coercion]+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)+(#.) _f = coerce+{-# INLINE (#.) #-}++ctoList :: (CFoldable f, Dom f a) => f a -> [a]+{-# INLINE [1] ctoList #-}+ctoList = cbasicToList++cfromList :: (CFreeMonoid f, Dom f a) => [a] -> f a+{-# INLINE [1] cfromList #-}+cfromList = cbasicFromList+++-- | Fold-optic for 'CFoldable' instances.+--   In the terminology of lens, cfolded is a constrained+--   variant of @folded@ optic.+--+--  @+--    cfolded :: (CFoldable t, Dom t a) => Fold (t a) a+--  @+cfolded+  :: (CFoldable t, Dom t a)+  => forall f. (Contravariant f, Applicative f) => (a -> f a) -> t a -> f (t a)+{-# INLINE cfolded #-}+cfolded = (contramap (const ()) .) . ctraverse_++class Constrained f => CFoldable f where+  {-# MINIMAL cfoldMap | cfoldr #-}+  cfoldMap :: (Dom f a, Monoid w) => (a -> w) -> f a -> w+  {-# INLINE [1] cfoldMap #-}+  cfoldMap f = cfoldr (mappend . f) mempty++  cfoldMap' :: (Dom f a, Monoid m) => (a -> m) -> f a -> m+  {-# INLINE [1] cfoldMap' #-}+  cfoldMap' f = cfoldl' (\ acc a -> acc <> f a) mempty++  cfold :: (Dom f w, Monoid w) => f w -> w+  cfold = cfoldMap id++  {-# INLINE [1] cfold #-}+  cfoldr :: (Dom f a) => (a -> b -> b) -> b -> f a -> b+  {-# INLINE [1] cfoldr #-}+  cfoldr f z t = appEndo (cfoldMap (Endo #. f) t) z++  cfoldlM+    :: (Monad m, Dom f b)+    => (a -> b -> m a) -> a -> f b -> m a+  {-# INLINE [1] cfoldlM #-}+  cfoldlM f z0 xs = cfoldr f' return xs z0+    where f' x k z = f z x >>= k++  cfoldlM'+    :: (Monad m, Dom f b)+    => (a -> b -> m a) -> a -> f b -> m a+  {-# INLINE [1] cfoldlM' #-}+  cfoldlM' f z0 xs = cfoldr' f' return xs z0+    where f' !x k z = do+            !i <- f z x+            k i++  cfoldrM+    :: (Monad m, Dom f a)+    => (a -> b -> m b) -> b -> f a -> m b+  {-# INLINE [1] cfoldrM #-}+  cfoldrM f z0 xs = cfoldl c return xs z0+    where c k x z = f x z >>= k++  cfoldrM'+    :: (Monad m, Dom f a)+    => (a -> b -> m b) -> b -> f a -> m b+  {-# INLINE [1] cfoldrM' #-}+  cfoldrM' f z0 xs = cfoldl' c return xs z0+    where c k !x z = do+            !i <- f x z+            k i+  cfoldl+      :: (Dom f a)+      => (b -> a -> b) -> b -> f a -> b+  {-# INLINE [1] cfoldl #-}+  cfoldl f z t = appEndo (getDual (cfoldMap (Dual . Endo . flip f) t)) z++  cfoldr' :: (Dom f a) => (a -> b -> b) -> b -> f a -> b+  {-# INLINE [1] cfoldr' #-}+  cfoldr' f z0 xs = cfoldl f' id xs z0+      where f' k x z = k $! f x z++  cfoldl' :: Dom f a => (b -> a -> b) -> b -> f a -> b+  {-# INLINE [1] cfoldl' #-}+  cfoldl' f z0 xs = cfoldr f' id xs z0+    where f' x k z = k $! f z x++  cbasicToList :: Dom f a => f a -> [a]+  {-# INLINE cbasicToList #-}+  cbasicToList = cfoldr (:) []++  cfoldr1 :: Dom f a => (a -> a -> a) -> f a -> a+  {-# INLINE [1] cfoldr1 #-}+  cfoldr1 f xs = fromMaybe (errorWithoutStackTrace "cfoldr1: empty structure")+                    (cfoldr mf Nothing xs)+      where+        mf x m = Just $+          case m of+            Nothing -> x+            Just y  -> f x y++++  cfoldl1 :: Dom f a => (a -> a -> a) -> f a -> a+  {-# INLINE [1] cfoldl1 #-}+  cfoldl1 f xs = fromMaybe (errorWithoutStackTrace "cfoldl1: empty structure")+                  (cfoldl mf Nothing xs)+    where+      mf m y = Just $+        case m of+          Nothing -> y+          Just x  -> f x y++  cindex :: Dom f a => f a -> Int -> a+  cindex xs n = case cfoldl' go (Left' 0) xs of+    Right' x -> x+    Left'{} -> errorWithoutStackTrace $ "cindex: index out of bound " ++ show n+    where+      go (Left' i) x+        | i == n = Right' x+        | otherwise = Left' (i + 1)+      go r@Right'{} _ = r++  cnull :: Dom f a => f a -> Bool+  cnull = cfoldr (const $ const False) True++  clength :: Dom f a => f a -> Int+  {-# INLINE [1] clength #-}+  clength = cfoldl' (\c _ -> c + 1) 0++  cany :: Dom f a => (a -> Bool) -> f a -> Bool+  {-# INLINE [1] cany #-}+  cany p = cfoldl' (\b -> (||) b . p) False++  call :: Dom f a => (a -> Bool) -> f a -> Bool+  {-# INLINE [1] call #-}+  call p = cfoldl' (\b -> (&&) b . p) True++  celem :: (Eq a, Dom f a) => a -> f a -> Bool+  {-# INLINE [1] celem #-}+  celem = cany . (==)++  cnotElem :: (Eq a, Dom f a) => a -> f a -> Bool+  {-# INLINE [1] cnotElem #-}+  cnotElem = call . (/=)++  cminimum :: (Ord a, Dom f a) => f a -> a+  {-# INLINE [1] cminimum #-}+  cminimum =+    getMin+    . fromMaybe (errorWithoutStackTrace "minimum: empty structure")+    . cfoldMap (Just . Min)++  cmaximum :: (Ord a, Dom f a) => f a -> a+  {-# INLINE [1] cmaximum #-}+  cmaximum =+    getMax+    . fromMaybe (errorWithoutStackTrace "cmaximum: empty structure")+    . cfoldMap (Just . Max)++  csum :: (Num a, Dom f a) => f a -> a+  {-# INLINE [1] csum #-}+  csum = getSum #. cfoldMap Sum++  cproduct :: (Num a, Dom f a) => f a -> a+  {-# INLINE [1] cproduct #-}+  cproduct = getProduct #. cfoldMap Product++  cctraverse_+    :: (CApplicative g, CPointed g, Dom g (), Dom f a, Dom g b)+    => (a -> g b)+    -> f a -> g ()+  {-# INLINE [1] cctraverse_ #-}+  cctraverse_ f = cfoldr c (cpure ())+    where+      {-# INLINE c #-}+      c x k = f x .> k++  ctraverse_+    :: (Applicative g, Dom f a)+    => (a -> g b)+    -> f a -> g ()+  {-# INLINE [1] ctraverse_ #-}+  ctraverse_ f = cfoldr c (pure ())+    where+      {-# INLINE c #-}+      c x k = f x *> k++  clast :: Dom f a => f a -> a+  {-# INLINE [1] clast #-}+  clast = fromJust . L.foldOver cfolded L.last++  chead :: Dom f a => f a -> a+  {-# INLINE [1] chead #-}+  chead = fromJust . L.foldOver cfolded L.head++  cfind :: Dom f a => (a -> Bool) -> f a -> Maybe a+  {-# INLINE [1] cfind #-}+  cfind = \p -> getFirst . cfoldMap (\x -> First $ if p x then Just x else Nothing)++  cfindIndex :: Dom f a => (a -> Bool) -> f a -> Maybe Int+  {-# INLINE [1] cfindIndex #-}+  cfindIndex = \p -> L.foldOver cfolded (L.findIndex p)++  cfindIndices :: Dom f a => (a -> Bool) -> f a -> [Int]+  {-# INLINE [1] cfindIndices #-}+  cfindIndices = \p -> List.findIndices p . ctoList++  celemIndex :: (Dom f a, Eq a) => a -> f a -> Maybe Int+  {-# INLINE [0] celemIndex #-}+  celemIndex = cfindIndex . (==)++  celemIndices :: (Dom f a, Eq a) => a -> f a -> [Int]+  {-# INLINE [0] celemIndices #-}+  celemIndices = cfindIndices . (==)++data Eith' a b = Left' !a | Right' !b++instance Traversable f => CTraversable (WrapFunctor f) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}++instance Foldable f => CFoldable (WrapFunctor f) where+  cfoldMap = foldMap+  {-# INLINE [1] cfoldMap #-}+#if MIN_VERSION_base(4,13,0)+  cfoldMap' = foldMap'+  {-# INLINE [1] cfoldMap' #-}+#endif+  cfold = fold+  {-# INLINE [1] cfold #-}+  cfoldr = foldr+  {-# INLINE [1] cfoldr #-}+  cfoldr' = foldr'+  {-# INLINE [1] cfoldr' #-}+  cfoldl = foldl+  {-# INLINE [1] cfoldl #-}+  cfoldl' = foldl'+  {-# INLINE [1] cfoldl' #-}+  cbasicToList = toList+  {-# INLINE [1] cbasicToList #-}+  cfoldr1 = foldr1+  {-# INLINE [1] cfoldr1 #-}+  cfoldl1 = foldl1+  {-# INLINE [1] cfoldl1 #-}+  cfoldlM = foldlM+  {-# INLINE [1] cfoldlM #-}+  cfoldrM = foldrM+  {-# INLINE [1] cfoldrM #-}+  cnull = null+  {-# INLINE [1] cnull #-}+  clength = length+  {-# INLINE [1] clength #-}+  cany = any+  {-# INLINE [1] cany #-}+  call = all+  {-# INLINE [1] call #-}+  celem = elem+  {-# INLINE [1] celem #-}+  cnotElem = notElem+  {-# INLINE [1] cnotElem #-}+  cminimum = minimum+  {-# INLINE [1] cminimum #-}+  cmaximum = maximum+  {-# INLINE [1] cmaximum #-}+  csum = sum+  {-# INLINE [1] csum #-}+  cproduct = product+  {-# INLINE [1] cproduct #-}+  ctraverse_ = traverse_+  {-# INLINE [1] ctraverse_ #-}+  cfind = find+  {-# INLINE [1] cfind #-}+  cfindIndex = L.fold . L.findIndex+  {-# INLINE [1] cfindIndex #-}+  celemIndex = L.fold . L.elemIndex+  {-# INLINE [1] celemIndex #-}++{-# RULES+"cfind/List"+  cfind = find @[]++"cfindIndex/List"+  cfindIndex = List.findIndex++"cfindIndices/List"+  cfindIndices = List.findIndices++"celemIndex/List"+  celemIndex = List.elemIndex++"celemIndices/List"+  celemIndices = List.elemIndices++"cfindIndex/List"+  cfindIndex = Seq.findIndexL++"cfindIndices/Seq"+  cfindIndices = Seq.findIndicesL++"celemIndex/Seq"+  celemIndex = Seq.elemIndexL++"celemIndices/Seq"+  celemIndices = Seq.elemIndicesL++  #-}++{-# RULES+"cctraverse_/traverse_"+  forall (f :: Applicative f => a -> f b) (tx :: Foldable t => t a).+  cctraverse_ f tx = traverse_ f tx+  #-}++{-# RULES+"cindex/List"+  cindex = (!!)+  #-}++class (CFunctor f, CFoldable f) => CTraversable f where+  -- | __N.B.__ If we require @g@ to be 'CApplicative'+  --   we cannot directly lift plain 'Traversable' to 'CTraversable'.+  --   This is rather annoying, so we require the strongest possible+  --   constraint to @g@ here.+  ctraverse+    :: (Dom f a, Dom f b, Applicative g)+    => (a -> g b) -> f a -> g (f b)++deriving via WrapFunctor []+  instance CFoldable []+{-# RULES+"ctoList/List"+  ctoList = id+"cfromList/List"+  cbasicFromList = id+"clast/List"+  clast = last+"chead/List"+  chead = head+  #-}++instance CTraversable [] where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Maybe+  instance CFoldable Maybe+instance CTraversable Maybe where+  ctraverse = traverse+deriving via WrapFunctor (Either e)+  instance CFoldable (Either e)+instance CTraversable (Either e) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor IM.IntMap+  instance CFoldable IM.IntMap+instance CTraversable IM.IntMap where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (M.Map k)+  instance CFoldable (M.Map k)+instance Ord k => CTraversable (M.Map k) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (HM.HashMap k)+  instance CFoldable (HM.HashMap k)+instance CTraversable (HM.HashMap k) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Seq.Seq+  instance CFoldable Seq.Seq+instance CTraversable Seq.Seq where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+{-# RULES+"cindex/Seq"+  cindex = Seq.index+  #-}++deriving via WrapFunctor Par1+  instance CFoldable Par1+instance CTraversable Par1 where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor NonEmpty+  instance CFoldable NonEmpty+instance CTraversable NonEmpty where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+{-# RULES+"cindex/NonEmpty"+  cindex = (NE.!!)+  #-}++deriving via WrapFunctor Down+  instance CFoldable Down+instance CTraversable Down where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Mon.Last+  instance CFoldable Mon.Last+instance CTraversable Mon.Last where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Mon.First+  instance CFoldable Mon.First+instance CTraversable Mon.First where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Sem.Last+  instance CFoldable Sem.Last+instance CTraversable Sem.Last where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Sem.First+  instance CFoldable Sem.First+instance CTraversable Sem.First where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Identity+  instance CFoldable Identity+instance CTraversable Identity where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor ZipList+  instance CFoldable ZipList+instance CTraversable ZipList where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+{-# RULES+"cindex/ZipList"+  cindex = (!!) . getZipList+  #-}++deriving via WrapFunctor Option+  instance CFoldable Option+instance CTraversable Option where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Min+  instance CFoldable Min+instance CTraversable Min where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Max+  instance CFoldable Max+instance CTraversable Max where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor Complex+  instance CFoldable Complex+instance CTraversable Complex where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (V1 :: Type -> Type)+  instance CFoldable (V1 :: Type -> Type)+instance CTraversable (V1 :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (U1 :: Type -> Type)+  instance CFoldable (U1 :: Type -> Type)+instance CTraversable (U1 :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor ((,) a)+  instance CFoldable ((,) a)+instance CTraversable ((,) a) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (Proxy :: Type -> Type)+  instance CFoldable (Proxy :: Type -> Type)+instance CTraversable (Proxy :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (Arg a)+  instance CFoldable (Arg a)+instance CTraversable (Arg a) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (Rec1 (f :: Type -> Type))+  instance Foldable f => CFoldable (Rec1 (f :: Type -> Type))+deriving via WrapFunctor (URec Char :: Type -> Type)+  instance CFoldable (URec Char :: Type -> Type)+instance CTraversable (URec Char :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (URec Double :: Type -> Type)+  instance CFoldable (URec Double :: Type -> Type)+instance CTraversable (URec Double :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (URec Float :: Type -> Type)+  instance CFoldable (URec Float :: Type -> Type)+instance CTraversable (URec Float :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (URec Int :: Type -> Type)+  instance CFoldable (URec Int :: Type -> Type)+instance CTraversable (URec Int :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (URec Word :: Type -> Type)+  instance CFoldable (URec Word :: Type -> Type)+instance CTraversable (URec Word :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (URec (Ptr ()) :: Type -> Type)+  instance CFoldable (URec (Ptr ()) :: Type -> Type)+instance CTraversable (URec (Ptr ()) :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving newtype+  instance CFoldable f => CFoldable (Alt f)+deriving newtype+  instance CFoldable f => CFoldable (Ap f)+deriving via WrapFunctor (Const m :: Type -> Type)+  instance CFoldable (Const m :: Type -> Type)+instance CTraversable (Const m :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}+deriving via WrapFunctor (K1 i c :: Type -> Type)+  instance CFoldable (K1 i c :: Type -> Type)+instance CTraversable (K1 i c :: Type -> Type) where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}++instance (CFoldable f, CFoldable g) => CFoldable (f :+: g) where+  {-# INLINE [1] cfoldMap #-}+  cfoldMap f = \case+    L1 x -> cfoldMap f x+    R1 x -> cfoldMap f x++  {-# INLINE [1] cfoldr #-}+  cfoldr f z = \case+    L1 x -> cfoldr f z x+    R1 x -> cfoldr f z x++  cfoldMap' = \f -> \case+    L1 x -> cfoldMap' f x+    R1 x -> cfoldMap' f x+  {-# INLINE [1] cfoldMap' #-}+  cfold = \case+    L1 x -> cfold x+    R1 x -> cfold x+  {-# INLINE [1] cfold #-}+  cfoldr' = \f z -> \case+    L1 x -> cfoldr' f z x+    R1 x -> cfoldr' f z x+  {-# INLINE [1] cfoldr' #-}+  cfoldl = \f z -> \case+    L1 x -> cfoldl f z x+    R1 x -> cfoldl f z x+  {-# INLINE [1] cfoldl #-}+  cfoldl' = \f z -> \case+    L1 x -> cfoldl' f z x+    R1 x -> cfoldl' f z x+  {-# INLINE [1] cfoldl' #-}+  cbasicToList = \case+    L1 x -> ctoList x+    R1 x -> ctoList x+  {-# INLINE cbasicToList #-}+  cfoldr1 = \f -> \case+    L1 x -> cfoldr1 f x+    R1 x -> cfoldr1 f x+  {-# INLINE [1] cfoldr1 #-}+  cfoldl1 = \f -> \case+    L1 x -> cfoldl1 f x+    R1 x -> cfoldl1 f x+  {-# INLINE [1] cfoldl1 #-}+  cnull = \case+    L1 x -> cnull x+    R1 x -> cnull x+  {-# INLINE [1] cnull #-}+  clength = \case+    L1 x -> clength x+    R1 x -> clength x+  {-# INLINE [1] clength #-}+  cany = \f -> \case+    L1 x -> cany f x+    R1 x -> cany f x+  {-# INLINE [1] cany #-}+  call = \f -> \case+    L1 x -> call f x+    R1 x -> call f x+  {-# INLINE [1] call #-}+  celem = \x -> \case+    L1 xs -> celem x xs+    R1 xs -> celem x xs+  {-# INLINE [1] celem #-}+  cminimum = \case+    L1 xs -> cminimum xs+    R1 xs -> cminimum xs+  {-# INLINE [1] cminimum #-}+  cmaximum = \case+    L1 xs -> cmaximum xs+    R1 xs -> cmaximum xs+  {-# INLINE [1] cmaximum #-}+  csum = \case+    L1 xs -> csum xs+    R1 xs -> csum xs+  {-# INLINE [1] csum #-}+  cproduct = \case+    L1 xs -> cproduct xs+    R1 xs -> cproduct xs+  {-# INLINE [1] cproduct #-}+  ctraverse_ f = \case+    L1 xs -> ctraverse_ f xs+    R1 xs -> ctraverse_ f xs+  {-# INLINE [1] ctraverse_ #-}++instance (CTraversable f, CTraversable g) => CTraversable (f :+: g) where+  ctraverse f = \case+    L1 xs -> L1 <$> ctraverse f xs+    R1 xs -> R1 <$> ctraverse f xs+  {-# INLINE [1] ctraverse #-}++instance (CFoldable f, CFoldable g) => CFoldable (f :*: g) where+  {-# INLINE [1] cfoldMap #-}+  cfoldMap f (l :*: r) = cfoldMap f l <> cfoldMap f r++  cfoldMap' f (l :*: r) = cfoldMap' f l <> cfoldMap' f r+  {-# INLINE [1] cfoldMap' #-}+  cfold (l :*: r) = cfold l <> cfold r+  {-# INLINE [1] cfold #-}+  cnull (l :*: r) = cnull l && cnull r+  {-# INLINE [1] cnull #-}+  clength (l :*: r) = clength l + clength r+  {-# INLINE [1] clength #-}+  cany f (l :*: r) = cany f l || cany f r+  {-# INLINE [1] cany #-}+  call f (l :*: r) = call f l && call f r+  {-# INLINE [1] call #-}+  celem x (l :*: r) = celem x l || celem x r+  {-# INLINE [1] celem #-}+  csum (l :*: r) = csum l + csum r+  {-# INLINE [1] csum #-}+  cproduct (l :*: r) = cproduct l * cproduct r+  {-# INLINE [1] cproduct #-}+  ctraverse_ f (l :*: r) = ctraverse_ f l *> ctraverse_ f r+  {-# INLINE [1] ctraverse_ #-}++instance (CTraversable f, CTraversable g) => CTraversable (f :*: g) where+  ctraverse f (l :*: r) =+    (:*:) <$> ctraverse f l <*> ctraverse f r++instance (CFoldable f, CFoldable g) => CFoldable (SOP.Sum f g) where+  {-# INLINE [1] cfoldMap #-}+  cfoldMap f = \case+    SOP.InL x -> cfoldMap f x+    SOP.InR x -> cfoldMap f x++  {-# INLINE [1] cfoldr #-}+  cfoldr f z = \case+    SOP.InL x -> cfoldr f z x+    SOP.InR x -> cfoldr f z x++  cfoldMap' = \f -> \case+    SOP.InL x -> cfoldMap' f x+    SOP.InR x -> cfoldMap' f x+  {-# INLINE [1] cfoldMap' #-}+  cfold = \case+    SOP.InL x -> cfold x+    SOP.InR x -> cfold x+  {-# INLINE [1] cfold #-}+  cfoldr' = \f z -> \case+    SOP.InL x -> cfoldr' f z x+    SOP.InR x -> cfoldr' f z x+  {-# INLINE [1] cfoldr' #-}+  cfoldl = \f z -> \case+    SOP.InL x -> cfoldl f z x+    SOP.InR x -> cfoldl f z x+  {-# INLINE [1] cfoldl #-}+  cfoldl' = \f z -> \case+    SOP.InL x -> cfoldl' f z x+    SOP.InR x -> cfoldl' f z x+  {-# INLINE [1] cfoldl' #-}+  cbasicToList = \case+    SOP.InL x -> ctoList x+    SOP.InR x -> ctoList x+  {-# INLINE cbasicToList #-}+  cfoldr1 = \f -> \case+    SOP.InL x -> cfoldr1 f x+    SOP.InR x -> cfoldr1 f x+  {-# INLINE [1] cfoldr1 #-}+  cfoldl1 = \f -> \case+    SOP.InL x -> cfoldl1 f x+    SOP.InR x -> cfoldl1 f x+  {-# INLINE [1] cfoldl1 #-}+  cnull = \case+    SOP.InL x -> cnull x+    SOP.InR x -> cnull x+  {-# INLINE [1] cnull #-}+  clength = \case+    SOP.InL x -> clength x+    SOP.InR x -> clength x+  {-# INLINE [1] clength #-}+  cany = \f -> \case+    SOP.InL x -> cany f x+    SOP.InR x -> cany f x+  {-# INLINE [1] cany #-}+  call = \f -> \case+    SOP.InL x -> call f x+    SOP.InR x -> call f x+  {-# INLINE [1] call #-}+  celem = \x -> \case+    SOP.InL xs -> celem x xs+    SOP.InR xs -> celem x xs+  {-# INLINE [1] celem #-}+  cminimum = \case+    SOP.InL xs -> cminimum xs+    SOP.InR xs -> cminimum xs+  {-# INLINE [1] cminimum #-}+  cmaximum = \case+    SOP.InL xs -> cmaximum xs+    SOP.InR xs -> cmaximum xs+  {-# INLINE [1] cmaximum #-}+  csum = \case+    SOP.InL xs -> csum xs+    SOP.InR xs -> csum xs+  {-# INLINE [1] csum #-}+  cproduct = \case+    SOP.InL xs -> cproduct xs+    SOP.InR xs -> cproduct xs+  {-# INLINE [1] cproduct #-}+  ctraverse_ f = \case+    SOP.InL xs -> ctraverse_ f xs+    SOP.InR xs -> ctraverse_ f xs+  {-# INLINE [1] ctraverse_ #-}++instance (CTraversable f, CTraversable g) => CTraversable (SOP.Sum f g) where+  ctraverse f = \case+    SOP.InL xs -> SOP.InL <$> ctraverse f xs+    SOP.InR xs -> SOP.InR <$> ctraverse f xs+  {-# INLINE [1] ctraverse #-}++instance (CFoldable f, CFoldable g) => CFoldable (SOP.Product f g) where+  {-# INLINE [1] cfoldMap #-}+  cfoldMap f (SOP.Pair l r) = cfoldMap f l <> cfoldMap f r++  cfoldMap' f (SOP.Pair l r) = cfoldMap' f l <> cfoldMap' f r+  {-# INLINE [1] cfoldMap' #-}+  cfold (SOP.Pair l r) = cfold l <> cfold r+  {-# INLINE [1] cfold #-}+  cnull (SOP.Pair l r) = cnull l && cnull r+  {-# INLINE [1] cnull #-}+  clength (SOP.Pair l r) = clength l + clength r+  {-# INLINE [1] clength #-}+  cany f (SOP.Pair l r) = cany f l || cany f r+  {-# INLINE [1] cany #-}+  call f (SOP.Pair l r) = call f l && call f r+  {-# INLINE [1] call #-}+  celem x (SOP.Pair l r) = celem x l || celem x r+  {-# INLINE [1] celem #-}+  csum (SOP.Pair l r) = csum l + csum r+  {-# INLINE [1] csum #-}+  cproduct (SOP.Pair l r) = cproduct l * cproduct r+  {-# INLINE [1] cproduct #-}+  ctraverse_ f (SOP.Pair l r) =+    ctraverse_ f l *> ctraverse_ f r+  {-# INLINE ctraverse_ #-}++deriving via WrapFunctor SA.SmallArray instance CFoldable SA.SmallArray+deriving via WrapFunctor A.Array instance CFoldable A.Array++instance CFoldable PA.PrimArray where+  cfoldr = PA.foldrPrimArray+  {-# INLINE [1] cfoldr #-}+  cfoldl' = PA.foldlPrimArray'+  {-# INLINE [1] cfoldl' #-}+  cfoldlM' = PA.foldlPrimArrayM'+  {-# INLINE [1] cfoldlM' #-}+  cfoldl = PA.foldlPrimArray+  {-# INLINE [1] cfoldl #-}+  clength = PA.sizeofPrimArray+  {-# INLINE [1] clength #-}+  csum = PA.foldlPrimArray' (+) 0+  {-# INLINE [1] csum #-}+  cproduct = PA.foldlPrimArray' (*) 1+  {-# INLINE [1] cproduct #-}+  ctraverse_ = PA.traversePrimArray_+  {-# INLINE [1] ctraverse_ #-}++instance CTraversable PA.PrimArray where+  ctraverse = PA.traversePrimArray+  {-# INLINE [1] ctraverse #-}++instance CTraversable SA.SmallArray where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}++instance CTraversable A.Array where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}++instance (CTraversable f, CTraversable g) => CTraversable (SOP.Product f g) where+  {-# INLINE [1] ctraverse #-}+  ctraverse f (SOP.Pair l r) =+    SOP.Pair <$> ctraverse f l <*> ctraverse f r++instance CFoldable Set.Set where+  cfoldMap = ofoldMap+  {-# INLINE [1] cfoldMap #-}+  cfoldr = Set.foldr+  {-# INLINE [1] cfoldr #-}+  cfoldl = Set.foldl+  {-# INLINE [1] cfoldl #-}+  cfoldr' = Set.foldr'+  {-# INLINE [1] cfoldr' #-}+  cfoldl' = Set.foldl'+  {-# INLINE [1] cfoldl' #-}+  cminimum = Set.findMin+  {-# INLINE [1] cminimum #-}+  cmaximum = Set.findMax+  {-# INLINE [1] cmaximum #-}+  celem = Set.member+  {-# INLINE [1] celem #-}+  cnotElem = Set.notMember+  {-# INLINE [1] cnotElem #-}+  cbasicToList = Set.toList+  {-# INLINE cbasicToList #-}+  celemIndex = Set.lookupIndex+  {-# INLINE [1] celemIndex #-}+  cindex = flip Set.elemAt+  {-# INLINE [1] cindex #-}++instance CTraversable Set.Set where+  -- TODO: more efficient implementation+  ctraverse f =+      fmap Set.fromList+    . traverse f+    . Set.toList+  {-# INLINE [1] ctraverse #-}++instance CFoldable HS.HashSet where+  cfoldMap = ofoldMap+  {-# INLINE [1] cfoldMap #-}+  cfoldr = HS.foldr+  {-# INLINE [1] cfoldr #-}+  cfoldl' = HS.foldl'+  {-# INLINE [1] cfoldl' #-}+  celem = HS.member+  {-# INLINE [1] celem #-}+  cbasicToList = HS.toList+  {-# INLINE cbasicToList #-}++instance CTraversable HS.HashSet where+  -- TODO: more efficient implementation+  ctraverse f =+      fmap HS.fromList+    . traverse f+    . HS.toList+  {-# INLINE [1] ctraverse #-}++{-# RULES+"celem/IntSet"+  celem = coerce+    @(Int -> IS.IntSet -> Bool)+    @(Int -> WrapMono IS.IntSet Int -> Bool)+    IS.member+"cnotElem/IntSet"+  cnotElem = coerce+    @(Int -> IS.IntSet -> Bool)+    @(Int -> WrapMono IS.IntSet Int -> Bool)+    IS.notMember+"cmaximum/IntSet"+  cmaximum = coerce @_ @(WrapMono IS.IntSet Int -> Int)+    IS.findMax+"cminimum/IntSet"+  cminimum = coerce @(IS.IntSet -> Int) @(WrapMono IS.IntSet Int -> Int)+    IS.findMin+  #-}++instance MonoFoldable mono => CFoldable (WrapMono mono) where+  cfoldMap = ofoldMap+  {-# INLINE [1] cfoldMap #-}+  cfold = ofold+  {-# INLINE [1] cfold #-}+  cfoldr = ofoldr+  {-# INLINE [1] cfoldr #-}+  cfoldl' = ofoldl'+  {-# INLINE [1] cfoldl' #-}+  cfoldlM = ofoldlM+  {-# INLINE [1] cfoldlM #-}+  cbasicToList = otoList+  {-# INLINE cbasicToList #-}+  cfoldr1 = ofoldr1Ex+  {-# INLINE [1] cfoldr1 #-}+  cnull = onull+  {-# INLINE [1] cnull #-}+  clength = olength+  {-# INLINE [1] clength #-}+  cany = oany+  {-# INLINE [1] cany #-}+  call = oall+  {-# INLINE [1] call #-}+  celem = oelem+  {-# INLINE [1] celem #-}+  cnotElem = onotElem+  {-# INLINE [1] cnotElem #-}+  cminimum = minimumEx+  {-# INLINE [1] cminimum #-}+  cmaximum = maximumEx+  {-# INLINE [1] cmaximum #-}+  csum = osum+  {-# INLINE [1] csum #-}+  cproduct = oproduct+  {-# INLINE [1] cproduct #-}+  ctraverse_ = otraverse_+  {-# INLINE [1] ctraverse_ #-}++instance MonoTraversable mono => CTraversable (WrapMono mono) where+  ctraverse = \f -> fmap WrapMono . otraverse f . unwrapMono++instance CFoldable V.Vector where+  {-# INLINE [1] cfoldMap #-}+  cfoldMap = foldMap+  {-# INLINE [1] cfoldr #-}+  cfoldr = V.foldr+  {-# INLINE [1] cfoldr' #-}+  cfoldr' = V.foldr'+  {-# INLINE [1] cfoldl #-}+  cfoldl = V.foldl+  {-# INLINE [1] cfoldl' #-}+  cfoldl' = V.foldl'+  {-# INLINE cfoldlM #-}+  cfoldlM = V.foldM+  {-# INLINE cfoldlM' #-}+  cfoldlM' = V.foldM'+  {-# INLINE [1] cindex #-}+  cindex = (V.!)+  {-# INLINE [1] celem #-}+  celem = V.elem+  {-# INLINE [1] cnotElem #-}+  cnotElem = V.notElem+  {-# INLINE [1] cany #-}+  cany = V.any+  {-# INLINE [1] call #-}+  call = V.all+  {-# INLINE [1] cfoldl1 #-}+  cfoldl1 = V.foldl1+  {-# INLINE [1] cfoldr1 #-}+  cfoldr1 = V.foldr1+  {-# INLINE [1] csum #-}+  csum = V.sum+  {-# INLINE [1] cproduct #-}+  cproduct = V.product+  {-# INLINE [1] cmaximum #-}+  cmaximum = V.maximum+  {-# INLINE [1] cminimum #-}+  cminimum = V.minimum+  {-# INLINE cbasicToList #-}+  cbasicToList = V.toList+  {-# INLINE [1] clast #-}+  clast = V.last+  {-# INLINE [1] chead #-}+  chead = V.head+  {-# INLINE [1] cfind #-}+  cfind = V.find+  {-# INLINE [1] cfindIndex #-}+  cfindIndex = V.findIndex+  {-# INLINE [1] cfindIndices #-}+  cfindIndices = fmap V.toList . V.findIndices+  {-# INLINE [1] celemIndex #-}+  celemIndex = V.elemIndex+  {-# INLINE [1] celemIndices #-}+  celemIndices = fmap V.toList . V.elemIndices++instance CFoldable U.Vector where+  {-# INLINE [1] cfoldMap #-}+  cfoldMap = ofoldMap+  {-# INLINE [1] cfoldr #-}+  cfoldr = U.foldr+  {-# INLINE [1] cfoldr' #-}+  cfoldr' = U.foldr'+  {-# INLINE [1] cfoldl #-}+  cfoldl = U.foldl+  {-# INLINE [1] cfoldl' #-}+  cfoldl' = U.foldl'+  {-# INLINE cfoldlM #-}+  cfoldlM = U.foldM+  {-# INLINE cfoldlM' #-}+  cfoldlM' = U.foldM'+  {-# INLINE [1] cindex #-}+  cindex = (U.!)+  {-# INLINE [1] celem #-}+  celem = U.elem+  {-# INLINE [1] cnotElem #-}+  cnotElem = U.notElem+  {-# INLINE [1] cany #-}+  cany = U.any+  {-# INLINE [1] call #-}+  call = U.all+  {-# INLINE [1] cfoldl1 #-}+  cfoldl1 = U.foldl1+  {-# INLINE [1] cfoldr1 #-}+  cfoldr1 = U.foldr1+  {-# INLINE [1] csum #-}+  csum = U.sum+  {-# INLINE [1] cproduct #-}+  cproduct = U.product+  {-# INLINE [1] cmaximum #-}+  cmaximum = U.maximum+  {-# INLINE [1] cminimum #-}+  cminimum = U.minimum+  {-# INLINE cbasicToList #-}+  cbasicToList = U.toList+  {-# INLINE [1] clast #-}+  clast = U.last+  {-# INLINE [1] chead #-}+  chead = U.head+  {-# INLINE [1] cfind #-}+  cfind = U.find+  {-# INLINE [1] cfindIndex #-}+  cfindIndex = U.findIndex+  {-# INLINE [1] cfindIndices #-}+  cfindIndices = fmap U.toList . U.findIndices+  {-# INLINE [1] celemIndex #-}+  celemIndex = U.elemIndex+  {-# INLINE [1] celemIndices #-}+  celemIndices = fmap U.toList . U.elemIndices++instance CFoldable S.Vector where+  {-# INLINE [1] cfoldr #-}+  cfoldr = S.foldr+  {-# INLINE [1] cfoldr' #-}+  cfoldr' = S.foldr'+  {-# INLINE [1] cfoldl #-}+  cfoldl = S.foldl+  {-# INLINE [1] cfoldl' #-}+  cfoldl' = S.foldl'+  {-# INLINE cfoldlM #-}+  cfoldlM = S.foldM+  {-# INLINE cfoldlM' #-}+  cfoldlM' = S.foldM'+  {-# INLINE [1] cindex #-}+  cindex = (S.!)+  {-# INLINE [1] celem #-}+  celem = S.elem+  {-# INLINE [1] cnotElem #-}+  cnotElem = S.notElem+  {-# INLINE [1] cany #-}+  cany = S.any+  {-# INLINE [1] call #-}+  call = S.all+  {-# INLINE [1] cfoldl1 #-}+  cfoldl1 = S.foldl1+  {-# INLINE [1] cfoldr1 #-}+  cfoldr1 = S.foldr1+  {-# INLINE [1] csum #-}+  csum = S.sum+  {-# INLINE [1] cproduct #-}+  cproduct = S.product+  {-# INLINE [1] cmaximum #-}+  cmaximum = S.maximum+  {-# INLINE [1] cminimum #-}+  cminimum = S.minimum+  {-# INLINE cbasicToList #-}+  cbasicToList = S.toList+  {-# INLINE [1] clast #-}+  clast = S.last+  {-# INLINE [1] chead #-}+  chead = S.head+  {-# INLINE [1] cfind #-}+  cfind = S.find+  {-# INLINE [1] cfindIndex #-}+  cfindIndex = S.findIndex+  {-# INLINE [1] cfindIndices #-}+  cfindIndices = fmap S.toList . S.findIndices+  {-# INLINE [1] celemIndex #-}+  celemIndex = S.elemIndex+  {-# INLINE [1] celemIndices #-}+  celemIndices = fmap S.toList . S.elemIndices++instance CFoldable P.Vector where+  {-# INLINE [1] cfoldr #-}+  cfoldr = P.foldr+  {-# INLINE [1] cfoldr' #-}+  cfoldr' = P.foldr'+  {-# INLINE [1] cfoldl #-}+  cfoldl = P.foldl+  {-# INLINE [1] cfoldl' #-}+  cfoldl' = P.foldl'+  {-# INLINE cfoldlM #-}+  cfoldlM = P.foldM+  {-# INLINE cfoldlM' #-}+  cfoldlM' = P.foldM'+  {-# INLINE [1] cindex #-}+  cindex = (P.!)+  {-# INLINE [1] celem #-}+  celem = P.elem+  {-# INLINE [1] cnotElem #-}+  cnotElem = P.notElem+  {-# INLINE [1] cany #-}+  cany = P.any+  {-# INLINE [1] call #-}+  call = P.all+  {-# INLINE [1] cfoldl1 #-}+  cfoldl1 = P.foldl1+  {-# INLINE [1] cfoldr1 #-}+  cfoldr1 = P.foldr1+  {-# INLINE [1] csum #-}+  csum = P.sum+  {-# INLINE [1] cproduct #-}+  cproduct = P.product+  {-# INLINE [1] cmaximum #-}+  cmaximum = P.maximum+  {-# INLINE [1] cminimum #-}+  cminimum = P.minimum+  {-# INLINE cbasicToList #-}+  cbasicToList = P.toList+  {-# INLINE [1] clast #-}+  clast = P.last+  {-# INLINE [1] chead #-}+  chead = P.head+  {-# INLINE [1] cfind #-}+  cfind = P.find+  {-# INLINE [1] cfindIndex #-}+  cfindIndex = P.findIndex+  {-# INLINE [1] cfindIndices #-}+  cfindIndices = fmap P.toList . P.findIndices+  {-# INLINE [1] celemIndex #-}+  celemIndex = P.elemIndex+  {-# INLINE [1] celemIndices #-}+  celemIndices = fmap P.toList . P.elemIndices++instance CTraversable V.Vector where+  ctraverse = traverse+  {-# INLINE [1] ctraverse #-}++instance CTraversable U.Vector where+  ctraverse = \f -> fmap S.convert . traverse f . U.convert @_ @_ @V.Vector+  {-# INLINE [1] ctraverse #-}++instance CTraversable S.Vector where+  ctraverse = \f -> fmap S.convert . traverse f . U.convert @_ @_ @V.Vector+  {-# INLINE [1] ctraverse #-}++instance CTraversable P.Vector where+  ctraverse = \f -> fmap P.convert . traverse f . U.convert @_ @_ @V.Vector+  {-# INLINE [1] ctraverse #-}++{-# RULES+"cindex/IsSequence" forall (xs :: (MT.Index mono ~ Int, IsSequence mono) => WrapMono mono b).+  cindex xs = withMonoCoercible (coerce @(mono -> Int -> Element mono) indexEx xs)+  #-}++{-# RULES+"cfromList/ctoList" [~1]+  cfromList . ctoList = id+"cfromList/ctoList" [~1] forall xs.+  cfromList (ctoList xs) = xs+  #-}++{-# RULES+"ctoList/cfromList" [~1]+  ctoList . cfromList = id+"ctoList/cfromList" forall xs.+  ctoList (cfromList xs) = xs+  #-}+-- | Free monoid functor from fullsubcategory.+--   It must be a pointed foldable functor with the property+--   that for any 'Monoid' @w@ and @f :: a -> w@,+--   @'cfoldMap' f@ must be a monoid homomorphism and the following+--   must be hold:+--+--    @+--       'cfoldMap' f . 'cpure' == f+--    @+--+--   Hence, @'Set's@ cannot be a free monoid functor;+class (CFunctor f, forall x. Dom f x => Monoid (f x), CPointed f, CFoldable f)+  => CFreeMonoid f where+  cbasicFromList :: Dom f a => [a] -> f a+  cbasicFromList = foldr ((<>) . cpure) mempty+  {-# INLINE cbasicFromList #-}++  ccons :: Dom f a => a -> f a -> f a+  {-# INLINE [1] ccons #-}+  ccons = (<>) . cpure++  csnoc :: Dom f a => f a -> a -> f a+  {-# INLINE [1] csnoc #-}+  csnoc = (. cpure) . (<>)++  {- |+    The 'cfromListN' function takes the input list's length as a hint. Its behaviour should be equivalent to 'cfromList'. The hint can be used to construct the structure l more efficiently compared to 'cfromList'.+    If the given hint does not equal to the input list's length the behaviour of fromListN is not specified.+  -}+  cfromListN :: Dom f a => Int -> [a] -> f a+  cfromListN = const cfromList+  {-# INLINE [1] cfromListN #-}++  ctake :: Dom f a => Int -> f a -> f a+  {-# INLINE [1] ctake #-}+  ctake n = cfromList . take n . ctoList++  cdrop :: Dom f a => Int -> f a -> f a+  {-# INLINE [1] cdrop #-}+  cdrop n = cfromList . drop n . ctoList++  cinit :: Dom f a => f a -> f a+  {-# INLINE [1] cinit #-}+  cinit = cfromList . init . ctoList++  ctail :: Dom f a => f a -> f a+  ctail = cfromList . tail . ctoList++  csplitAt :: Dom f a => Int -> f a -> (f a, f a)+  {-# INLINE [1] csplitAt #-}+  csplitAt n = (\(a, b) -> (cfromList a, cfromList b)) . splitAt n . ctoList++  creplicate :: Dom f a => Int -> a -> f a+  {-# INLINE [1] creplicate #-}+  creplicate n = cfromList . replicate n++  cgenerate :: Dom f a => Int -> (Int -> a) -> f a+  {-# INLINE [1] cgenerate #-}+  cgenerate = \n f ->+    cfromList [f i | i <- [0.. n - 1]]++  cgenerateM :: (Dom f a, Monad m) => Int -> (Int -> m a) -> m (f a)+  {-# INLINE [1] cgenerateM #-}+  cgenerateM = \n f ->+    cfromList <$> mapM f [0..n-1]++  cgenerateA :: (Dom f a, Applicative g) => Int -> (Int -> g a) -> g (f a)+  {-# INLINE [1] cgenerateA #-}+  cgenerateA = \n f ->+    cfromList <$> traverse f [0..n-1]++  cuncons :: Dom f a => f a -> Maybe (a, f a)+  {-# INLINE [1] cuncons #-}+  cuncons = fmap (second cfromList) . uncons . ctoList++  cunsnoc :: Dom f a => f a -> Maybe (f a, a)+  {-# INLINE [1] cunsnoc #-}+  cunsnoc = fmap (first cfromList) . MT.unsnoc . ctoList++  creverse :: Dom f a => f a -> f a+  {-# INLINE [1] creverse #-}+  creverse = cfromList . reverse . ctoList++  cintersperse :: Dom f a => a -> f a -> f a+  cintersperse = \a -> cfromList . intersperse a . ctoList++  cnub :: (Dom f a, Eq a) => f a -> f a+  {-# INLINE [1] cnub #-}+  cnub = cfromList . nub . ctoList++  cnubOrd :: (Dom f a, Ord a) => f a -> f a+  {-# INLINE [1] cnubOrd #-}+  cnubOrd = cfromList . L.foldOver cfolded L.nub++  csort :: (Dom f a, Ord a) => f a -> f a+  {-# INLINE [1] csort #-}+  csort = cfromList . List.sort . ctoList++  csortBy :: (Dom f a) => (a -> a -> Ordering) -> f a -> f a+  {-# INLINE [1] csortBy #-}+  csortBy = \f -> cfromList . List.sortBy f . ctoList++  cinsert :: (Dom f a, Ord a) => a -> f a -> f a+  {-# INLINE [1] cinsert #-}+  cinsert = \a -> cfromList . List.insert a . ctoList++  cinsertBy :: (Dom f a) => (a -> a -> Ordering) -> a -> f a -> f a+  {-# INLINE [1] cinsertBy #-}+  cinsertBy = \f a -> cfromList . List.insertBy f a . ctoList++  ctakeWhile :: Dom f a => (a -> Bool) -> f a -> f a+  {-# INLINE [1] ctakeWhile #-}+  ctakeWhile = \f -> cfromList . takeWhile f . ctoList++  cdropWhile :: Dom f a => (a -> Bool) -> f a -> f a+  {-# INLINE [1] cdropWhile #-}+  cdropWhile = \f -> cfromList . dropWhile f . ctoList++  cspan :: Dom f a => (a -> Bool) -> f a -> (f a, f a)+  {-# INLINE [1] cspan #-}+  cspan = \f -> (cfromList *** cfromList) . span f . ctoList++  cbreak :: Dom f a => (a -> Bool) -> f a -> (f a, f a)+  {-# INLINE [1] cbreak #-}+  cbreak = \f -> (cfromList *** cfromList) . break f . ctoList++  cfilter :: Dom f a => (a -> Bool) -> f a -> f a+  {-# INLINE [1] cfilter #-}+  cfilter = \f -> cfromList . filter f . ctoList++  cpartition :: Dom f a => (a -> Bool) -> f a -> (f a, f a)+  {-# INLINE [1] cpartition #-}+  cpartition = \f -> (cfromList *** cfromList) . List.partition f . ctoList++  -- TODO: more ListLike equivalent functions here++instance CFreeMonoid [] where+  cbasicFromList = id+  {-# INLINE cbasicFromList #-}+  cfromListN = take+  {-# INLINE [1] cfromListN #-}+  ccons = (:)+  {-# INLINE [1] ccons #-}+  csnoc = \xs x -> xs ++ [x]+  {-# INLINE [1] csnoc #-}+  ctake = take+  {-# INLINE [1] ctake #-}+  cdrop = drop+  {-# INLINE [1] cdrop #-}+  cinit = init+  {-# INLINE [1] cinit #-}+  ctail = tail+  {-# INLINE [1] ctail #-}+  csplitAt = splitAt+  {-# INLINE [1] csplitAt #-}+  creplicate = replicate+  {-# INLINE [1] creplicate #-}+  cgenerateM = \n f -> mapM f [0..n-1]+  {-# INLINE [1] cgenerateM #-}+  cgenerateA = \n f -> traverse f [0..n-1]+  {-# INLINE [1] cgenerateA #-}+  cuncons = uncons+  {-# INLINE [1] cuncons #-}+  cunsnoc = MT.unsnoc+  {-# INLINE [1] cunsnoc #-}+  creverse = reverse+  {-# INLINE [1] creverse #-}+  cintersperse = intersperse+  {-# INLINE [1] cintersperse #-}+  cnub = cnub+  {-# INLINE [1] cnub #-}+  csort = List.sort+  {-# INLINE [1] csort #-}+  csortBy = List.sortBy+  {-# INLINE [1] csortBy #-}+  ctakeWhile = takeWhile+  {-# INLINE [1] ctakeWhile #-}+  cdropWhile = dropWhile+  {-# INLINE [1] cdropWhile #-}+  cspan = span+  {-# INLINE [1] cspan #-}+  cbreak = break+  {-# INLINE [1] cbreak #-}+  cfilter = filter+  {-# INLINE [1] cfilter #-}+  cpartition = List.partition+  {-# INLINE [1] cpartition #-}++fmap concat $ forM+  [''V.Vector, ''U.Vector, ''S.Vector, ''P.Vector]+  $ \vecTy@(Name _ (NameG _ pkg modl0@(ModName mn))) ->+    let modl = maybe modl0 (ModName . T.unpack)+          $ T.stripSuffix ".Base" $ T.pack mn+        modFun fun = varE $+          Name (OccName fun) (NameG VarName pkg modl)+    in [d|+    instance CFreeMonoid $(conT vecTy) where+      cbasicFromList = $(modFun "fromList")+      {-# INLINE cbasicFromList #-}+      cfromListN = $(modFun "fromListN")+      {-# INLINE [1] cfromListN #-}+      ccons = $(modFun "cons")+      {-# INLINE [1] ccons #-}+      csnoc = $(modFun "snoc")+      {-# INLINE [1] csnoc #-}+      ctake = $(modFun "take")+      {-# INLINE [1] ctake #-}+      cdrop = $(modFun "drop")+      {-# INLINE [1] cdrop #-}+      cinit = $(modFun "init")+      {-# INLINE [1] cinit #-}+      ctail = $(modFun "tail")+      {-# INLINE [1] ctail #-}+      csplitAt = $(modFun "splitAt")+      {-# INLINE [1] csplitAt #-}+      creplicate = $(modFun "replicate")+      {-# INLINE [1] creplicate #-}+      cgenerate = $(modFun "generate")+      {-# INLINE [1] cgenerate #-}+      cgenerateM = $(modFun "generateM")+      {-# INLINE [1] cgenerateM #-}+      cgenerateA = \n f ->+        fmap VB.build+        $ getAp $ foldMap (Ap . fmap VB.singleton . f) [0..n-1]+      {-# INLINE [1] cgenerateA #-}+      cuncons = \xs ->+        if $(modFun "null") xs+        then Nothing+        else Just ($(modFun "head") xs, $(modFun "tail") xs)+      {-# INLINE [1] cuncons #-}+      cunsnoc = \xs ->+        if $(modFun "null") xs+        then Nothing+        else Just ($(modFun "init") xs, $(modFun "last") xs)+      {-# INLINE [1] cunsnoc #-}+      creverse = $(modFun "reverse")+      {-# INLINE [1] creverse #-}+      cnubOrd = $(modFun "uniq") . $(modFun "modify") AI.sort+      {-# INLINE cnubOrd #-}+      csort = $(modFun "modify") AI.sort+      {-# INLINE [1] csort #-}+      csortBy = \f -> $(modFun "modify") $ AI.sortBy f+      {-# INLINE [1] csortBy #-}+      ctakeWhile = $(modFun "takeWhile")+      {-# INLINE [1] ctakeWhile #-}+      cdropWhile = $(modFun "dropWhile")+      {-# INLINE [1] cdropWhile #-}+      cspan = $(modFun "span")+      {-# INLINE [1] cspan #-}+      cbreak = $(modFun "break")+      {-# INLINE [1] cbreak #-}+      cfilter = $(modFun "filter")+      {-# INLINE [1] cfilter #-}+      cpartition = $(modFun "partition")+      {-# INLINE [1] cpartition #-}+    |]++instance CFreeMonoid PA.PrimArray where+  cbasicFromList = PA.primArrayFromList+  {-# INLINE cbasicFromList #-}+  cfromListN = PA.primArrayFromListN+  {-# INLINE [1] cfromListN #-}+  cgenerate = PA.generatePrimArray+  {-# INLINE [1] cgenerate #-}+  cgenerateM = PA.generatePrimArrayA+  {-# INLINE [1] cgenerateM #-}+  cgenerateA = PA.generatePrimArrayA+  {-# INLINE [1] cgenerateA #-}+  cfilter = PA.filterPrimArray+  {-# INLINE [1] cfilter #-}+  creplicate = PA.replicatePrimArray+  {-# INLINE [1] creplicate #-}++instance CFreeMonoid SA.SmallArray where+  cbasicFromList = SA.smallArrayFromList+  {-# INLINE cbasicFromList #-}+  cfromListN = SA.smallArrayFromListN+  {-# INLINE [1] cfromListN #-}++instance CFreeMonoid A.Array where+  cbasicFromList = A.fromList+  {-# INLINE cbasicFromList #-}+  cfromListN = A.fromListN+  {-# INLINE [1] cfromListN #-}+instance CFreeMonoid Seq.Seq where+  cbasicFromList = Seq.fromList+  {-# INLINE cbasicFromList #-}+  cfromListN = GHC.fromListN+  {-# INLINE [1] cfromListN #-}++instance MT.IsSequence mono+      => CFreeMonoid (WrapMono mono) where+  cbasicFromList = coerce $ MT.fromList @mono+  {-# INLINE cbasicFromList #-}+  cfromListN = \n -> coerce $ MT.take (fromIntegral n) . MT.fromList @mono+  {-# INLINE [1] cfromListN #-}+  ctake = coerce . MT.take @mono . fromIntegral+  {-# INLINE [1] ctake #-}+  cdrop = coerce . MT.drop @mono . fromIntegral+  {-# INLINE [1] cdrop #-}+  ccons = coerce $ MT.cons @mono+  {-# INLINE ccons #-}+  csnoc = coerce $ MT.snoc @mono+  {-# INLINE [1] csnoc #-}+  cuncons = coerce $ MT.uncons @mono+  {-# INLINE [1] cuncons #-}+  cunsnoc = coerce $ MT.unsnoc @mono+  {-# INLINE [1] cunsnoc #-}+  ctail = coerce $ MT.tailEx @mono+  {-# INLINE [1] ctail #-}+  cinit = coerce $ MT.initEx @mono+  {-# INLINE [1] cinit #-}+  csplitAt = coerce $ \(n :: Int) ->+      MT.splitAt @mono (fromIntegral n :: MT.Index mono)+  {-# INLINE [1] csplitAt #-}+  creplicate = coerce $ \(n :: Int) ->+      MT.replicate @mono (fromIntegral n :: MT.Index mono)+  {-# INLINE [1] creplicate #-}+  creverse = coerce $ MT.reverse @mono+  {-# INLINE [1] creverse #-}+  cintersperse = coerce $ MT.intersperse @mono+  {-# INLINE [1] cintersperse #-}+  csort = coerce $ MT.sort @mono+  {-# INLINE [1] csort #-}+  csortBy = coerce $ MT.sortBy @mono+  {-# INLINE [1] csortBy #-}+  ctakeWhile = coerce $ MT.takeWhile @mono+  {-# INLINE [1] ctakeWhile #-}+  cdropWhile = coerce $ MT.dropWhile @mono+  {-# INLINE [1] cdropWhile #-}+  cbreak = coerce $ MT.break @mono+  {-# INLINE [1] cbreak #-}+  cspan = coerce $ MT.span @mono+  {-# INLINE [1] cspan #-}+  cfilter = coerce $ MT.filter @mono+  {-# INLINE [1] cfilter #-}+  cpartition = coerce $ MT.partition @mono+  {-# INLINE [1] cpartition #-}++cctraverseFreeMonoid+  ::  ( CFreeMonoid t, CApplicative f, CPointed f,+        Dom t a, Dom f (t b), Dom f b, Dom t b,+        Dom f (t b, t b)+      )+  => (a -> f b) -> t a -> f (t b)+cctraverseFreeMonoid f =+  runCApp . cfoldMap (CApp . cmap cpure . f)++cctraverseZipFreeMonoid+  :: ( CFreeMonoid t, CRepeat f,+        Dom t a, Dom f (t b), Dom f b, Dom t b,+        Dom f (t b, t b)+      )+  => (a -> f b) -> t a -> f (t b)+cctraverseZipFreeMonoid f =+  runCZippy . cfoldMap (CZippy . cmap cpure . f)++-- | Lifts 'CFoldable' along given function.+--+--  @+--    cfolding :: (CFoldable t, Dom t a) => (s -> t a) -> Fold s a+--  @+cfolding+  :: (CFoldable t, Dom t a, Contravariant f, Applicative f)+  => (s -> t a)+  -> (a -> f a) -> s -> f s+{-# INLINE cfolding #-}+cfolding = \sfa agb -> phantom . ctraverse_ agb . sfa

@@ -0,0 +1,375 @@+{-# LANGUAGE CPP, DerivingVia, GADTs, InstanceSigs, KindSignatures    #-}+{-# LANGUAGE PatternSynonyms, RankNTypes, RoleAnnotations             #-}+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}+{-# LANGUAGE TypeApplications, TypeFamilies, TypeOperators            #-}+{-# LANGUAGE UndecidableSuperClasses                                  #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Control.Subcategory.Functor+  ( Constrained(..), Dom(), CFunctor (..),+    (<$:>),+    defaultCmapConst,+    WrapFunctor (..),+    WrapMono (WrapMono, unwrapMono),+    coerceToMono, withMonoCoercible,+  )+where+import qualified Control.Applicative                  as App+import           Control.Arrow                        (Arrow, ArrowMonad)+import           Control.Exception                    (Handler)+import qualified Control.Monad.ST.Lazy                as LST+import qualified Control.Monad.ST.Strict              as SST+import           Control.Subcategory.Wrapper.Internal+import           Data.Coerce+import           Data.Complex                         (Complex)+import qualified Data.Functor.Compose                 as SOP+import           Data.Functor.Const                   (Const)+import           Data.Functor.Identity                (Identity)+import qualified Data.Functor.Product                 as SOP+import qualified Data.Functor.Sum                     as SOP+import           Data.Hashable                        (Hashable)+import qualified Data.HashMap.Strict                  as HM+import qualified Data.HashSet                         as HS+import qualified Data.IntMap                          as IM+import           Data.Kind                            (Constraint, Type)+import           Data.List.NonEmpty                   (NonEmpty)+import qualified Data.Map                             as Map+import qualified Data.Monoid                          as Mon+import           Data.MonoTraversable                 (Element,+                                                       MonoFunctor (..))+#if MIN_VERSION_mono_traversable(1,0,14)+import Data.MonoTraversable (WrappedMono)+#endif++import qualified Data.IntSet                     as IS+import           Data.Ord                        (Down (..))+import qualified Data.Primitive.Array            as A+import qualified Data.Primitive.PrimArray        as PA+import qualified Data.Primitive.SmallArray       as SA+import           Data.Proxy                      (Proxy)+import qualified Data.Semigroup                  as Sem+import qualified Data.Sequence                   as Seq+import qualified Data.Set                        as Set+import qualified Data.Tree                       as Tree+import qualified Data.Vector                     as V+import qualified Data.Vector.Primitive           as P+import qualified Data.Vector.Storable            as S+import qualified Data.Vector.Unboxed             as U+import           Foreign.Ptr                     (Ptr)+import           GHC.Conc                        (STM)+import           GHC.Generics                    ((:*:) (..), (:+:) (..),+                                                  (:.:) (..), K1, M1, Par1,+                                                  Rec1, U1, URec, V1)+import qualified System.Console.GetOpt           as GetOpt+import           Text.ParserCombinators.ReadP    (ReadP)+import           Text.ParserCombinators.ReadPrec (ReadPrec)++infixl 4 <$:++class Constrained (f :: Type -> Type) where+  type Dom f (a :: Type) :: Constraint+  type Dom f a = ()++class Constrained f => CFunctor f where+  cmap :: (Dom f a, Dom f b) => (a -> b) -> f a -> f b+  default cmap :: Functor f => (a -> b) -> f a -> f b+  cmap = fmap+  {-# INLINE cmap #-}+  (<$:) :: (Dom f a, Dom f b) => a -> f b -> f a+  (<$:) = cmap . const+  {-# INLINE (<$:) #-}++defaultCmapConst :: (CFunctor f, Dom f a, Dom f b) => a -> f b -> f a+defaultCmapConst = cmap . const+{-# INLINE defaultCmapConst #-}++instance Constrained (WrapFunctor f) where+  type Dom (WrapFunctor f) a = ()++instance Functor f => CFunctor (WrapFunctor f) where+  cmap :: (a -> b) -> WrapFunctor f a -> WrapFunctor f b+  cmap = fmap+  {-# INLINE cmap #-}+  (<$:) :: a -> WrapFunctor f b -> WrapFunctor f a+  (<$:) = (<$)+  {-# INLINE (<$:) #-}++instance Constrained []+instance CFunctor []+instance Constrained Maybe+instance CFunctor Maybe+instance Constrained IO+instance CFunctor IO+instance Constrained Par1+instance CFunctor Par1+instance Constrained NonEmpty+instance CFunctor NonEmpty+instance Constrained ReadP+instance CFunctor ReadP+instance Constrained ReadPrec+instance CFunctor ReadPrec+++instance Constrained Down+instance CFunctor Down+instance Constrained Mon.Product+instance CFunctor Mon.Product++instance Constrained Mon.Sum+instance CFunctor Mon.Sum+instance Constrained Mon.Dual+instance CFunctor Mon.Dual++instance Constrained Mon.Last+instance CFunctor Mon.Last+instance Constrained Mon.First+instance CFunctor Mon.First++instance Constrained STM+instance CFunctor STM+instance Constrained Handler+instance CFunctor Handler++instance Constrained Identity+instance CFunctor Identity+instance Constrained App.ZipList+instance CFunctor App.ZipList+instance Constrained GetOpt.ArgDescr+instance CFunctor GetOpt.ArgDescr+instance Constrained GetOpt.OptDescr+instance CFunctor GetOpt.OptDescr+instance Constrained GetOpt.ArgOrder+instance CFunctor GetOpt.ArgOrder+instance Constrained Sem.Option+instance CFunctor Sem.Option++instance Constrained Sem.Last+instance CFunctor Sem.Last+instance Constrained Sem.First+instance CFunctor Sem.First++instance Constrained Sem.Max+instance CFunctor Sem.Max+instance Constrained Sem.Min+instance CFunctor Sem.Min++instance Constrained Complex+instance CFunctor Complex+instance Constrained (Either a)+instance CFunctor (Either a)++instance Constrained V1+instance CFunctor V1+instance Constrained U1+instance CFunctor U1++instance Constrained ((,) a)+instance CFunctor ((,) a)+instance Constrained (SST.ST s)+instance CFunctor (SST.ST s)++instance Constrained (LST.ST s)+instance CFunctor (LST.ST s)+instance Constrained Proxy+instance CFunctor Proxy++instance Constrained (ArrowMonad a)+instance Arrow a => CFunctor (ArrowMonad a)+instance Constrained (App.WrappedMonad m)+instance Monad m => CFunctor (App.WrappedMonad m)++instance Constrained (Sem.Arg a)+instance CFunctor (Sem.Arg a)+instance Constrained (Rec1 f)+instance Functor f => CFunctor (Rec1 f)++instance Constrained (URec Char)+instance CFunctor (URec Char)+instance Constrained (URec Double)+instance CFunctor (URec Double)++instance Constrained (URec Float)+instance CFunctor (URec Float)+instance Constrained (URec Int)+instance CFunctor (URec Int)++instance Constrained (URec Word)+instance CFunctor (URec Word)+instance Constrained (URec (Ptr ()))+instance CFunctor (URec (Ptr ()))++instance Constrained f => Constrained (Mon.Ap f) where+  type Dom (Mon.Ap f) a = Dom f a++deriving newtype instance CFunctor f => CFunctor (Mon.Ap f)++instance Constrained (Mon.Alt f) where+  type Dom (Mon.Alt f) a = Dom f a+deriving newtype instance CFunctor f => CFunctor (Mon.Alt f)++instance Constrained (Const m)+instance CFunctor (Const m)+instance Constrained (App.WrappedArrow a b)+instance Arrow a => CFunctor (App.WrappedArrow a b)++instance Constrained ((->) r)+instance CFunctor ((->) r)+instance Constrained (K1 i c)+instance CFunctor (K1 i c)++instance Constrained (f :+: g) where+  type Dom (f :+: g) a = (Dom f a, Dom g a)+instance (CFunctor f, CFunctor g) => CFunctor (f :+: g) where+  cmap f (L1 xs) = L1 $ cmap f xs+  cmap f (R1 xs) = R1 $ cmap f xs+  {-# INLINE [1] cmap #-}+instance Constrained (f :*: g) where+  type Dom (f :*: g) a = (Dom f a, Dom g a)+instance (CFunctor f, CFunctor g) => CFunctor (f :*: g) where+  cmap f (l :*: r) = cmap f l :*: cmap f r+  {-# INLINE cmap #-}++instance Constrained (f :.: (g :: Type -> Type)) where+  type Dom (f :.: g) a = (Dom f (g a), Dom g a)+instance (CFunctor f, CFunctor g) => CFunctor (f :.: g) where+  cmap f gfa = Comp1 $ cmap (cmap f) $ unComp1 gfa+  {-# INLINE cmap #-}+instance (Constrained f, Constrained g) => Constrained (SOP.Sum f g) where+  type Dom (SOP.Sum f g) a = (Dom f a, Dom g a)++instance (CFunctor f, CFunctor g) => CFunctor (SOP.Sum f g) where+  cmap f (SOP.InL a) = SOP.InL $ cmap f a+  cmap f (SOP.InR b) = SOP.InR $ cmap f b+  {-# INLINE cmap #-}++  (<$:) = defaultCmapConst+  {-# INLINE (<$:) #-}++instance (Constrained f, Constrained g) => Constrained (SOP.Product f g) where+  type Dom (SOP.Product f g) a = (Dom f a, Dom g a)++instance (CFunctor f, CFunctor g) => CFunctor (SOP.Product f g) where+  cmap f (SOP.Pair a b) = SOP.Pair (cmap f a) (cmap f b)+  {-# INLINE cmap #-}++  (<$:) = defaultCmapConst+  {-# INLINE (<$:) #-}++instance (Constrained (f ::Type -> Type), Constrained (g :: Type -> Type))+  => Constrained (SOP.Compose f g) where+  type Dom (SOP.Compose f g) a = (Dom g a, Dom f (g a))++instance (CFunctor f, CFunctor g) => CFunctor (SOP.Compose f g) where+  cmap f (SOP.Compose a) = SOP.Compose $ cmap (cmap f) a+  (<$:) = defaultCmapConst++  {-# INLINE (<$:) #-}++instance Constrained (M1 i c f)+instance Functor f => CFunctor (M1 i c f)++instance Constrained Seq.Seq+instance CFunctor Seq.Seq++#if MIN_VERSION_mono_traversable(1,0,14)+instance Constrained (WrappedMono mono) where+  type Dom (WrappedMono mono) a = a ~ Element mono++instance MonoFunctor IS.IntSet where+  omap = IS.map++instance MonoFunctor mono => CFunctor (WrappedMono mono) where+  cmap = omap+  (<$:) = omap . const+#endif++instance Constrained (WrapMono mono) where+  type Dom (WrapMono mono) b = b ~ Element mono++instance {-# OVERLAPPABLE #-} MonoFunctor a+      => CFunctor (WrapMono a) where+  cmap = coerce @((Element a -> Element a) -> a -> a) omap+  {-# INLINE [1] cmap #-}++  (<$:) = defaultCmapConst+  {-# INLINE [1] (<$:) #-}+++instance Constrained IM.IntMap+instance CFunctor IM.IntMap++instance Constrained (Map.Map k)+instance Ord k => CFunctor (Map.Map k)++instance Constrained Set.Set where+  type Dom Set.Set a = Ord a++instance CFunctor Set.Set where+  cmap = Set.map+  {-# INLINE [1] cmap #-}+  (<$:) = flip $ \s ->+    if Set.null s+    then const Set.empty else Set.singleton+  {-# INLINE [1] (<$:) #-}++instance Constrained HS.HashSet where+  type Dom HS.HashSet a = (Hashable a, Eq a)++instance CFunctor HS.HashSet where+  cmap :: (Hashable b, Eq b) => (a -> b) -> HS.HashSet a -> HS.HashSet b+  cmap = HS.map+  {-# INLINE [1] cmap #-}+  (<$:) = flip $ \s -> if HS.null s+    then const HS.empty else HS.singleton+  {-# INLINE (<$:) #-}++instance Constrained (HM.HashMap k)+instance CFunctor (HM.HashMap k)+instance Constrained Tree.Tree+instance CFunctor Tree.Tree+++infixl 4 <$:>+(<$:>) :: (CFunctor f, Dom f a, Dom f b) => (a -> b) -> f a -> f b+(<$:>) = cmap+{-# INLINE [1] (<$:>) #-}++instance Constrained V.Vector where+  type Dom V.Vector a = ()++instance CFunctor V.Vector where+  cmap = V.map+  {-# INLINE [1] cmap #-}++instance Constrained U.Vector where+  type Dom U.Vector a = U.Unbox a+instance CFunctor U.Vector where+  cmap = U.map+  {-# INLINE [1] cmap #-}+instance Constrained S.Vector where+  type Dom S.Vector a = S.Storable a+instance CFunctor S.Vector where+  cmap = S.map+  {-# INLINE [1] cmap #-}++instance Constrained P.Vector where+  type Dom P.Vector a = P.Prim a+instance CFunctor P.Vector where+  cmap = P.map+  {-# INLINE [1] cmap #-}++instance Constrained PA.PrimArray where+  type Dom PA.PrimArray a = P.Prim a++instance CFunctor PA.PrimArray where+  cmap = PA.mapPrimArray+  {-# INLINE [1] cmap #-}++deriving via WrapFunctor SA.SmallArray+  instance Constrained SA.SmallArray+deriving via WrapFunctor SA.SmallArray+  instance CFunctor SA.SmallArray++deriving via WrapFunctor A.Array+  instance Constrained A.Array+deriving via WrapFunctor A.Array+  instance CFunctor A.Array

@@ -0,0 +1,131 @@+{-# LANGUAGE DerivingVia, StandaloneDeriving, TypeOperators #-}+module Control.Subcategory.Pointed where+import Control.Subcategory.Functor++import qualified Control.Applicative             as App+import qualified Control.Monad.ST.Lazy           as LST+import qualified Control.Monad.ST.Strict         as SST+import qualified Data.Functor.Compose            as SOP+import           Data.Functor.Identity           (Identity)+import qualified Data.Functor.Product            as SOP+import qualified Data.HashSet                    as HS+import qualified Data.IntSet                     as IS+import           Data.List.NonEmpty              (NonEmpty)+import qualified Data.Monoid                     as Mon+import           Data.MonoTraversable            (MonoPointed, opoint)+import           Data.Ord                        (Down)+import qualified Data.Pointed                    as Pt+import qualified Data.Primitive.Array            as A+import qualified Data.Primitive.PrimArray        as PA+import qualified Data.Primitive.SmallArray       as SA+import           Data.Proxy                      (Proxy)+import qualified Data.Semigroup                  as Sem+import qualified Data.Sequence                   as Seq+import qualified Data.Set                        as Set+import qualified Data.Tree                       as Tree+import qualified Data.Vector                     as V+import qualified Data.Vector.Primitive           as P+import qualified Data.Vector.Storable            as S+import qualified Data.Vector.Unboxed             as U+import           GHC.Conc                        (STM)+import           GHC.Generics                    ((:*:) (..), (:.:) (..))+import           GHC.Generics                    (Par1, Rec1, U1)+import           Text.ParserCombinators.ReadP    (ReadP)+import           Text.ParserCombinators.ReadPrec (ReadPrec)++class Constrained f => CPointed f where+  cpure :: Dom f a => a -> f a+  default cpure :: App.Applicative f => a -> f a+  cpure = pure++instance (Functor f, Pt.Pointed f) => CPointed (WrapFunctor f) where+  cpure = Pt.point+  {-# INLINE cpure #-}++instance CPointed []+instance CPointed Maybe+instance CPointed IO+instance CPointed (SST.ST s)+instance CPointed (LST.ST s)+instance CPointed Par1+instance CPointed Sem.Min+instance CPointed Sem.Max+instance CPointed Mon.First+instance CPointed Mon.Last+instance CPointed Sem.First+instance CPointed Sem.Last+instance CPointed Sem.Option+instance CPointed NonEmpty+instance CPointed App.ZipList+instance CPointed Identity+instance CPointed STM+instance CPointed Sem.Dual+instance CPointed Sem.Sum+instance CPointed Sem.Product+instance CPointed Down+instance CPointed Tree.Tree+instance CPointed Seq.Seq+instance CPointed Set.Set where+  cpure = Set.singleton+  {-# INLINE cpure #-}+instance CPointed (Either a)+instance CPointed U1+instance CPointed Proxy+instance (Pt.Pointed f) => CPointed (Rec1 f) where+  cpure = Pt.point+  {-# INLINE cpure #-}+instance (Pt.Pointed p, Pt.Pointed q)+      => CPointed (p :*: q) where+  cpure a = (:*:) (Pt.point a) (Pt.point a)+  {-# INLINE cpure #-}+instance (Pt.Pointed p, Pt.Pointed q)+      => CPointed (p :.: q) where+  cpure a = Comp1 $ Pt.point $ Pt.point a+  {-# INLINE cpure #-}+instance (Constrained p, Constrained q, Pt.Pointed p, Pt.Pointed q)+      => CPointed (SOP.Compose p q) where+  cpure a = SOP.Compose $ Pt.point $ Pt.point a+  {-# INLINE cpure #-}+instance (CPointed p, CPointed q)+      => CPointed (SOP.Product p q) where+  cpure a = SOP.Pair (cpure a) (cpure a)+  {-# INLINE cpure #-}+instance CPointed ReadP+instance CPointed ReadPrec+instance CPointed (WrapMono IS.IntSet) where+  cpure = WrapMono . IS.singleton+  {-# INLINE cpure #-}+instance CPointed HS.HashSet where+  cpure = HS.singleton+  {-# INLINE cpure #-}++instance MonoPointed mono => CPointed (WrapMono mono) where+  cpure = opoint++instance CPointed V.Vector where+  cpure = V.singleton+  {-# INLINE [1] cpure #-}++instance CPointed U.Vector where+  cpure = U.singleton+  {-# INLINE [1] cpure #-}++instance CPointed S.Vector where+  cpure = S.singleton+  {-# INLINE [1] cpure #-}++instance CPointed P.Vector where+  cpure = P.singleton+  {-# INLINE [1] cpure #-}++instance CPointed PA.PrimArray where+  cpure = PA.replicatePrimArray 1+  {-# INLINE [1] cpure #-}++instance CPointed SA.SmallArray where+  cpure = SA.smallArrayFromListN 1 . pure+  {-# INLINE [1] cpure #-}++instance CPointed A.Array where+  cpure = A.fromListN 1 . pure+  {-# INLINE [1] cpure #-}

@@ -0,0 +1,33 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Control.Subcategory.RebindableSyntax+  ( ifThenElse, Eq(..), Num(..)+  , (>>=), (>>), fromLabel, return+  , module Control.Arrow+  ) where+import Control.Subcategory.Applicative+import Control.Subcategory.Bind+import Control.Subcategory.Functor+import Control.Subcategory.Pointed++import Control.Arrow+import GHC.OverloadedLabels+import Prelude              (Bool (..), Eq (..), Num (..))++ifThenElse :: Bool -> a -> a -> a+ifThenElse True t _  = t+ifThenElse False _ f = f+{-# INLINE ifThenElse #-}++(>>=) :: (Dom m a, Dom m b, CBind m)+      => m a -> (a -> m b) -> m b+(>>=) = (>>-)+{-# INLINE (>>=) #-}++(>>) :: (Dom m a, Dom m b, CApplicative m)+      => m a -> m b -> m b+(>>) = (.>)+{-# INLINE (>>) #-}++return :: (Dom m a, CPointed m) => a -> m a+return = cpure+{-# INLINE return #-}

@@ -0,0 +1,302 @@+{-# LANGUAGE BangPatterns, CPP, DerivingStrategies, DerivingVia         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiWayIf, StandaloneDeriving #-}+{-# LANGUAGE TypeOperators                                              #-}+module Control.Subcategory.Semialign+  ( CSemialign(..), CAlign(..),+    csalign, cpadZip, cpadZipWith+  ) where+import           Control.Applicative                  (ZipList)+import           Control.Monad                        (forM_)+import           Control.Monad.ST.Strict              (runST)+import           Control.Subcategory.Functor+import           Control.Subcategory.Wrapper.Internal+import           Data.Bifunctor                       (Bifunctor (bimap))+import           Data.Coerce+import           Data.Containers+import           Data.Functor.Compose                 (Compose (..))+import           Data.Functor.Identity                (Identity)+import qualified Data.Functor.Product                 as SOP+import           Data.Hashable                        (Hashable)+import           Data.HashMap.Strict                  (HashMap)+import           Data.IntMap.Strict                   (IntMap)+import qualified Data.IntSet                          as IS+import           Data.List.NonEmpty                   (NonEmpty)+import           Data.Map                             (Map)+import           Data.MonoTraversable+import qualified Data.Primitive.Array                 as A+import qualified Data.Primitive.PrimArray             as PA+import qualified Data.Primitive.SmallArray            as SA+import           Data.Proxy                           (Proxy)+import           Data.Semialign+import           Data.Semigroup                       (Option (..))+import           Data.Sequence                        (Seq)+import qualified Data.Sequences                       as MT+import           Data.These                           (These (..), fromThese,+                                                       mergeThese)+import           Data.Tree                            (Tree)+import qualified Data.Vector                          as V+import qualified Data.Vector.Primitive                as P+import qualified Data.Vector.Storable                 as S+import qualified Data.Vector.Unboxed                  as U+import           GHC.Generics                         ((:*:) (..), (:.:) (..))++class CFunctor f => CSemialign f where+  {-# MINIMAL calignWith #-}+  calignWith+    :: (Dom f a, Dom f b, Dom f c)+    => (These a b -> c) -> f a -> f b -> f c+  calign+    :: (Dom f a, Dom f b, Dom f (These a b))+    => f a -> f b -> f (These a b)+  {-# INLINE [1] calign #-}+  calign = calignWith id++instance Semialign f => CSemialign (WrapFunctor f) where+  calignWith = alignWith+  {-# INLINE [1] calignWith #-}+  calign = align+  {-# INLINE [1] calign #-}++instance {-# OVERLAPPING #-}  CSemialign (WrapMono IS.IntSet) where+  calignWith f = withMonoCoercible @IS.IntSet $+    coerce @(IS.IntSet -> IS.IntSet -> IS.IntSet) $ \ l r ->+    let ints = l `IS.intersection` r+    in IS.unions+          [ IS.map (f . This) l+          , IS.map (f . That) r+          , IS.map (\x -> f $ These x x) ints+          ]+  {-# INLINE [1] calignWith #-}++class CSemialign f => CAlign f where+  cnil :: Dom f a => f a++instance Align f => CAlign (WrapFunctor f) where+  cnil = WrapFunctor nil+  {-# INLINE [1] cnil #-}++deriving via WrapFunctor [] instance CSemialign []+deriving via WrapFunctor [] instance CAlign []+deriving via WrapFunctor Maybe instance CSemialign Maybe+deriving via WrapFunctor Maybe instance CAlign Maybe+#if MIN_VERSION_semialign(1,1,0)+deriving via WrapFunctor Option instance CSemialign Option+deriving via WrapFunctor Option instance CAlign Option+#else+deriving newtype instance CSemialign Option+deriving newtype instance CAlign Option+#endif++deriving via WrapFunctor ZipList instance CSemialign ZipList+deriving via WrapFunctor ZipList instance CAlign ZipList+deriving via WrapFunctor Identity instance CSemialign Identity+deriving via WrapFunctor NonEmpty instance CSemialign NonEmpty+deriving via WrapFunctor IntMap instance CSemialign IntMap+deriving via WrapFunctor IntMap instance CAlign IntMap+deriving via WrapFunctor Tree instance CSemialign Tree+deriving via WrapFunctor Seq instance CSemialign Seq+deriving via WrapFunctor Seq instance CAlign Seq+deriving via WrapFunctor V.Vector instance CSemialign V.Vector+deriving via WrapFunctor V.Vector instance CAlign V.Vector+deriving via WrapFunctor Proxy instance CSemialign Proxy+deriving via WrapFunctor Proxy instance CAlign Proxy+deriving via WrapFunctor (Map k) instance Ord k => CSemialign (Map k)+deriving via WrapFunctor (Map k) instance Ord k => CAlign (Map k)+deriving via WrapFunctor (HashMap k)+  instance (Eq k, Hashable k) => CSemialign (HashMap k)+deriving via WrapFunctor (HashMap k)+  instance (Eq k, Hashable k) => CAlign (HashMap k)+deriving via WrapFunctor ((->) s) instance CSemialign ((->) s)++instance (CSemialign f, CSemialign g) => CSemialign (SOP.Product f g) where+  calign (SOP.Pair a b) (SOP.Pair c d) = SOP.Pair (calign a c) (calign b d)+  {-# INLINE [1] calign #-}+  calignWith f (SOP.Pair a b) (SOP.Pair c d) =+    SOP.Pair (calignWith f a c) (calignWith f b d)+  {-# INLINE [1] calignWith #-}++instance (CAlign f, CAlign g) => CAlign (SOP.Product f g) where+  cnil = SOP.Pair cnil cnil+  {-# INLINE [1] cnil #-}++instance (CSemialign f, CSemialign g) => CSemialign (f :*: g) where+  calign ((:*:) a b) ((:*:) c d) = (:*:) (calign a c) (calign b d)+  {-# INLINE [1] calign #-}+  calignWith f ((:*:) a b) ((:*:) c d) =+    (:*:) (calignWith f a c) (calignWith f b d)+  {-# INLINE [1] calignWith #-}++instance (CAlign f, CAlign g) => CAlign (f :*: g) where+  cnil = cnil :*: cnil+  {-# INLINE [1] cnil #-}++instance (CSemialign f, CSemialign g) => CSemialign (Compose f g) where+  calignWith f (Compose x) (Compose y) = Compose (calignWith g x y)+    where+      g (This ga)     = cmap (f . This) ga+      g (That gb)     = cmap (f . That) gb+      g (These ga gb) = calignWith f ga gb+  {-# INLINE [1] calignWith #-}++instance (CAlign f, CSemialign g) => CAlign (Compose f g) where+  cnil = Compose cnil+  {-# INLINE [1] cnil #-}++instance (CSemialign f, CSemialign g) => CSemialign ((:.:) f g) where+  calignWith f (Comp1 x) (Comp1 y) = Comp1 (calignWith g x y)+    where+      g (This ga)     = cmap (f . This) ga+      g (That gb)     = cmap (f . That) gb+      g (These ga gb) = calignWith f ga gb+  {-# INLINE [1] calignWith #-}++instance (CAlign f, CSemialign g) => CAlign ((:.:) f g) where+  cnil = Comp1 cnil+  {-# INLINE [1] cnil #-}++instance CSemialign U.Vector where+  calignWith = alignVectorWith+  {-# INLINE [1] calignWith #-}++instance CAlign U.Vector where+  cnil = U.empty+  {-# INLINE [1] cnil #-}++instance CSemialign S.Vector where+  calignWith = alignVectorWith+  {-# INLINE [1] calignWith #-}++instance CAlign S.Vector where+  cnil = S.empty+  {-# INLINE [1] cnil #-}++instance CSemialign P.Vector where+  calignWith = alignVectorWith+  {-# INLINE [1] calignWith #-}++instance CAlign P.Vector where+  cnil = P.empty+  {-# INLINE [1] cnil #-}++instance CSemialign SA.SmallArray where+  calignWith f l r = runST $ do+    let !lenL = length l+        !lenR = length r+        (isLftShort, thresh, len)+          | lenL < lenR = (True, lenL, lenR)+          | otherwise = (False, lenR, lenL)+    sa <- SA.newSmallArray len (error "Uninitialised element")+    forM_ [0..len-1] $ \n ->+      if  | n == len -> pure ()+          | n < thresh ->+            SA.writeSmallArray sa n+            $ f $ These+              (SA.indexSmallArray l n)+              (SA.indexSmallArray r n)+          | isLftShort ->+            SA.writeSmallArray sa n+            $ f $ That $ SA.indexSmallArray r n+          | otherwise ->+            SA.writeSmallArray sa n+            $ f $ This $ SA.indexSmallArray l n+    SA.unsafeFreezeSmallArray sa+  {-# INLINE [1] calignWith #-}++instance CAlign SA.SmallArray where+  cnil = SA.smallArrayFromListN 0 []+  {-# INLINE [1] cnil #-}++instance CSemialign A.Array where+  calignWith f l r = runST $ do+    let !lenL = length l+        !lenR = length r+        (isLftShort, thresh, len)+          | lenL < lenR = (True, lenL, lenR)+          | otherwise = (False, lenR, lenL)+    sa <- A.newArray len (error "Uninitialised element")+    forM_ [0..len-1] $ \n ->+      if  | n == len -> pure ()+          | n < thresh ->+            A.writeArray sa n+            $ f $ These+              (A.indexArray l n)+              (A.indexArray r n)+          | isLftShort ->+            A.writeArray sa n+            $ f $ That $ A.indexArray r n+          | otherwise ->+            A.writeArray sa n+            $ f $ This $ A.indexArray l n+    A.unsafeFreezeArray sa+  {-# INLINE [1] calignWith #-}++instance CAlign A.Array where+  cnil = A.fromListN 0 []+  {-# INLINE [1] cnil #-}++instance CSemialign PA.PrimArray where+  calignWith f l r = runST $ do+    let !lenL = PA.sizeofPrimArray l+        !lenR = PA.sizeofPrimArray r+        (isLftShort, thresh, len)+          | lenL < lenR = (True, lenL, lenR)+          | otherwise = (False, lenR, lenL)+    sa <- PA.newPrimArray len+    forM_ [0..len-1] $ \n ->+      if  | n == len -> pure ()+          | n < thresh ->+            PA.writePrimArray sa n+            $ f $ These+              (PA.indexPrimArray l n)+              (PA.indexPrimArray r n)+          | isLftShort ->+            PA.writePrimArray sa n+            $ f $ That $ PA.indexPrimArray r n+          | otherwise ->+            PA.writePrimArray sa n+            $ f $ This $ PA.indexPrimArray l n+    PA.unsafeFreezePrimArray sa+  {-# INLINE [1] calignWith #-}++instance CAlign PA.PrimArray where+  cnil = PA.primArrayFromListN 0 []+  {-# INLINE [1] cnil #-}++instance (MT.IsSequence mono, MonoZip mono)+  => CSemialign (WrapMono mono) where+  calignWith f = coerce go+    where+      go :: mono -> mono -> mono+      go ls rs+        | lenL == lenR = ozipWith (fmap f . These) ls rs+        | lenL < lenR  =+            ozipWith (fmap f . These) ls rs+            <> omap (f . That) (MT.drop (fromIntegral lenL) rs)+        | otherwise  =+            ozipWith (fmap f . These) ls rs+            <> omap (f . This) (MT.drop (fromIntegral lenL) ls)+        where lenL = olength ls+              lenR = olength rs++instance (MT.IsSequence mono, MonoZip mono)+  => CAlign (WrapMono mono) where+  cnil = WrapMono mempty++csalign :: (CSemialign f, Dom f a, Semigroup a)+  => f a -> f a -> f a+{-# INLINE [1] csalign #-}+csalign = calignWith $ mergeThese (<>)++cpadZip+  :: (CSemialign f, Dom f a, Dom f b, Dom f (Maybe a, Maybe b))+  => f a -> f b -> f (Maybe a, Maybe b)+{-# INLINE [1] cpadZip #-}+cpadZip = calignWith (fromThese Nothing Nothing . bimap Just Just)++cpadZipWith+  :: (CSemialign f, Dom f a, Dom f b, Dom f c)+  => (Maybe a -> Maybe b -> c)+  -> f a -> f b -> f c+{-# INLINE [1] cpadZipWith #-}+cpadZipWith f = calignWith $+  uncurry f . fromThese Nothing Nothing . bimap Just Just

@@ -0,0 +1,55 @@+{-# LANGUAGE CPP, GADTs, InstanceSigs, KindSignatures, PatternSynonyms #-}+{-# LANGUAGE RankNTypes, RoleAnnotations, ScopedTypeVariables          #-}+{-# LANGUAGE StandaloneDeriving, TemplateHaskell, TypeApplications     #-}+{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableSuperClasses      #-}+module Control.Subcategory.Wrapper.Internal where+import Control.Applicative+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 808+import Control.Monad.Fail+#endif+import Control.Monad.Fix    (MonadFix)+import Control.Monad.Zip    (MonadZip)+import Data.Coerce+import Data.Kind            (Type)+import Data.MonoTraversable+import Data.Pointed+import Data.Semialign       (Align, Unalign)+import Data.Zip             (Semialign, Unzip, Zip)+import GHC.Base             (MonadPlus)++newtype WrapFunctor f (a :: Type) = WrapFunctor {runFunctor :: f a}+  deriving newtype (Functor, Applicative, Alternative, Monad, Foldable)+  deriving newtype (MonadPlus, MonadFix, MonadFail)+  deriving newtype (Pointed, MonadZip, Unalign, Align, Semialign, Zip,  Unzip)++instance Traversable f => Traversable (WrapFunctor f) where+  traverse f = fmap WrapFunctor . traverse f . runFunctor+++type role WrapMono representational nominal+-- | Similar to 'WrappedMono' from @mono-traversable,+--   but uses @newtype@ instaed of GADTs, which is efficient.+--   To restrict the construction, we hide genuine constructor+--   and expose the constrained pattern synonym 'WrapMono' and+--   specifies type roles tightly (note: the role for @mono@+--   should NOT be representational honestly; indeed, @WrapMono mono a@+--   could be coerced to @WrapMono mono' a@ iff @mono@ and @mono' are+--   representationally equivalent __AND__ @Element a ~ Element a@.)+newtype WrapMono mono b = WrapMono' mono+  deriving newtype (MonoFoldable, MonoFunctor, Monoid, Semigroup, MonoPointed)+  deriving newtype (GrowingAppend)++type instance Element (WrapMono mono b) = Element mono++pattern WrapMono :: b ~ Element mono => b ~ Element mono => mono -> WrapMono mono b+pattern WrapMono {unwrapMono} = WrapMono' unwrapMono++coerceToMono :: WrapMono mono (Element mono) -> mono+{-# INLINE coerceToMono #-}+coerceToMono = coerce++withMonoCoercible+  :: (Coercible (WrapMono mono (Element mono)) mono => r)+  -> r+{-# INLINE withMonoCoercible #-}+withMonoCoercible = id

@@ -0,0 +1,386 @@+{-# LANGUAGE CPP, DerivingVia, StandaloneDeriving, TypeOperators #-}+module Control.Subcategory.Zip+  ( CZip(..),+    CUnzip(..),+    cunzipDefault,+    CZippy(..),+    CRepeat(..),+    module Control.Subcategory.Semialign+  ) where+import           Control.Applicative                  (ZipList (..))+import           Control.Arrow                        (Arrow ((&&&)), (***))+import           Control.Monad.Zip                    (MonadZip (mzip),+                                                       mzipWith)+import           Control.Subcategory.Functor+import           Control.Subcategory.Semialign+import           Control.Subcategory.Wrapper.Internal+import           Data.Coerce                          (coerce)+import           Data.Containers+import           Data.Functor.Compose                 (Compose (..))+import           Data.Functor.Identity+import qualified Data.Functor.Product                 as SOP+import           Data.Hashable                        (Hashable)+import qualified Data.HashMap.Strict                  as HM+import qualified Data.IntMap.Strict                   as IM+import qualified Data.List.NonEmpty                   as NE+import qualified Data.Map.Strict                      as M+import           Data.MonoTraversable+import qualified Data.Primitive.Array                 as A+import qualified Data.Primitive.PrimArray             as PA+import qualified Data.Primitive.SmallArray            as SA+import           Data.Proxy+import           Data.Semigroup                       (Option (..))+import qualified Data.Sequence                        as Seq+import qualified Data.Sequences                       as MT+import           Data.Tree+import qualified Data.Vector                          as V+import qualified Data.Vector.Generic                  as G+import qualified Data.Vector.Primitive                as Prim+import qualified Data.Vector.Primitive                as PV+import qualified Data.Vector.Storable                 as S+import qualified Data.Vector.Unboxed                  as U+import           Data.Zip+import           GHC.Generics                         ((:*:) (..), (:.:) (..))+import           Prelude                              hiding (repeat, unzip,+                                                       zip, zipWith)+import qualified Prelude                              as P++class CSemialign f => CZip f where+  czipWith+    :: (Dom f a, Dom f b, Dom f c)+    => (a -> b -> c) -> f a -> f b -> f c+  czip+    :: (Dom f a, Dom f b, Dom f (a, b))+    => f a -> f b -> f (a, b)+  {-# INLINE [1] czip #-}+  czip = czipWith (,)++instance Zip f => CZip (WrapFunctor f) where+  czip = zip+  {-# INLINE [1] czip #-}+  czipWith = zipWith+  {-# INLINE [1] czipWith #-}++deriving via WrapFunctor [] instance CZip []+deriving via WrapFunctor Maybe instance CZip Maybe+deriving newtype instance CZip Option+deriving via WrapFunctor ZipList instance CZip ZipList+deriving via WrapFunctor Identity instance CZip Identity+deriving via WrapFunctor NE.NonEmpty instance CZip NE.NonEmpty+deriving via WrapFunctor Tree instance CZip Tree+deriving via WrapFunctor ((->) e) instance CZip ((->) e)++#if MIN_VERSION_semialign(1,1,0)+deriving via WrapFunctor Seq.Seq instance CZip Seq.Seq+deriving via WrapFunctor (M.Map k) instance Ord k => CZip (M.Map k)+deriving via WrapFunctor (HM.HashMap k)+  instance (Eq k, Hashable k)+  => CZip (HM.HashMap k)+deriving via WrapFunctor IM.IntMap instance CZip IM.IntMap+#else+instance CZip Seq.Seq where+  czipWith = Seq.zipWith+  {-# INLINE [1] czipWith #-}+  czip = Seq.zip+  {-# INLINE [1] czip #-}+instance Ord k => CZip (M.Map k) where+  czipWith = M.intersectionWith+  {-# INLINE [1] czipWith #-}+instance (Eq k, Hashable k) => CZip (HM.HashMap k) where+  czipWith = HM.intersectionWith+  {-# INLINE [1] czipWith #-}+instance CZip IM.IntMap where+  czipWith = IM.intersectionWith+  {-# INLINE [1] czipWith #-}+#endif+++instance CZip V.Vector where+  czip = V.zip+  {-# INLINE [1] czip #-}+  czipWith = V.zipWith+  {-# INLINE [1] czipWith #-}++instance CZip U.Vector where+  czip = U.zip+  {-# INLINE [1] czip #-}+  czipWith = U.zipWith+  {-# INLINE [1] czipWith #-}++instance CZip S.Vector where+  czipWith = S.zipWith+  {-# INLINE [1] czipWith #-}++instance CZip Prim.Vector where+  czipWith = Prim.zipWith+  {-# INLINE [1] czipWith #-}++instance CZip Proxy where+  czip = const $ const Proxy+  {-# INLINE czip #-}+  czipWith = const $ const $ const Proxy+  {-# INLINE czipWith #-}++instance (CZip f, CZip g) => CZip (SOP.Product f g) where+  czipWith f (SOP.Pair a b) (SOP.Pair c d) =+    SOP.Pair (czipWith f a c) (czipWith f b d)+  {-# INLINE [1] czipWith #-}+  czip (SOP.Pair a b) (SOP.Pair c d) =+    SOP.Pair (czip a c) (czip b d)+  {-# INLINE [1] czip #-}++instance (CZip f, CZip g) => CZip (f :*: g) where+  czipWith f (a :*: b) (c :*: d) =+    czipWith f a c :*: czipWith f b d+  {-# INLINE [1] czipWith #-}+  czip (a :*: b) (c :*: d) =+    czip a c :*: czip b d+  {-# INLINE [1] czip #-}++instance (CZip f, CZip g) => CZip (Compose f g) where+  czipWith f (Compose a) (Compose b) =+    Compose $ czipWith (czipWith f) a b+  {-# INLINE [1] czipWith #-}+  czip (Compose a) (Compose b) =+    Compose $ czipWith czip a b+  {-# INLINE [1] czip #-}++instance (CZip f, CZip g) => CZip (f :.: g) where+  czipWith f (Comp1 a) (Comp1 b) =+    Comp1 $ czipWith (czipWith f) a b+  {-# INLINE [1] czipWith #-}+  czip (Comp1 a) (Comp1 b) =+    Comp1 $ czipWith czip a b+  {-# INLINE [1] czip #-}++{-# RULES+"czip/List"+  czip = P.zip+"czipWith/List"+  czipWith = P.zipWith+"czip/NonEmpty"+  czip = NE.zip+"czipWith/NonEmpty"+  czipWith = NE.zipWith+"czip/Seq"+  czip = Seq.zip+"czipWith/Seq"+  czipWith = Seq.zipWith+  #-}++class CZip f => CRepeat f where+  crepeat :: Dom f a => a -> f a++newtype CZippy f a = CZippy { runCZippy :: f a }+  deriving (Show, Read)+  deriving newtype (Functor, Zip, Semialign, Eq, Ord)+  deriving newtype (Constrained)+#if MIN_VERSION_semialign(1,1,0)+  deriving newtype (Repeat)+#endif++instance CFunctor f => CFunctor (CZippy f) where+  cmap = coerce $ cmap @f @a @b+    :: forall a b. (Dom f a, Dom f b) => (a -> b) -> CZippy f a -> CZippy f b+  {-# INLINE [1] cmap #-}++instance CSemialign f => CSemialign (CZippy f) where+  calignWith = \f -> coerce $ calignWith @f f+  {-# INLINE [1] calignWith #-}++instance CZip f => CZip (CZippy f) where+  czipWith f = coerce $ czipWith @f f+  {-# INLINE [1] czipWith #-}++instance CRepeat f => CRepeat (CZippy f) where+  crepeat = CZippy . crepeat+  {-# INLINE [1] crepeat #-}++instance (CZip f, Dom f a, Semigroup a) => Semigroup (CZippy f a) where+  (<>) = coerce $ czipWith @f ((<>) @a)+  {-# INLINE [1] (<>) #-}++instance (CRepeat f, Dom f a, Monoid a) => Monoid (CZippy f a) where+  mempty = coerce $ crepeat @f (mempty @a)+  {-# INLINE [1] mempty #-}++#if MIN_VERSION_semialign(1,1,0)+instance Repeat f => CRepeat (WrapFunctor f) where+  crepeat = coerce $ repeat @f @a+    :: forall a. a -> WrapFunctor f a+  {-# INLINE [1] crepeat #-}+deriving via WrapFunctor [] instance CRepeat []+deriving via WrapFunctor Maybe instance CRepeat Maybe+deriving newtype instance CRepeat Option+deriving via WrapFunctor ZipList instance CRepeat ZipList+deriving via WrapFunctor Identity instance CRepeat Identity+deriving via WrapFunctor NE.NonEmpty instance CRepeat NE.NonEmpty+deriving via WrapFunctor Tree instance CRepeat Tree+deriving via WrapFunctor ((->) e) instance CRepeat ((->) e)+#else+instance CRepeat [] where+  crepeat = P.repeat+  {-# INLINE [1] crepeat #-}+instance CRepeat Maybe where+  crepeat = Just+  {-# INLINE [1] crepeat #-}+deriving newtype instance CRepeat Option+deriving newtype instance CRepeat ZipList+instance CRepeat Identity where+  crepeat = Identity+  {-# INLINE [1] crepeat #-}+instance CRepeat NE.NonEmpty where+  crepeat = NE.repeat+  {-# INLINE [1] crepeat #-}+instance CRepeat Tree where+  crepeat x = n where n = Node x (P.repeat n)+  {-# INLINE [1] crepeat #-}+instance CRepeat Proxy where+  crepeat = const Proxy+  {-# INLINE [1] crepeat #-}+instance CRepeat ((->) e) where+  crepeat = const+  {-# INLINE [1] crepeat #-}+#endif++instance CZip SA.SmallArray where+  czip = mzip+  {-# INLINE [1] czip #-}+  czipWith = mzipWith+  {-# INLINE [1] czipWith #-}++instance CZip A.Array where+  czip = mzip+  {-# INLINE [1] czip #-}+  czipWith = mzipWith+  {-# INLINE [1] czipWith #-}++instance CZip PA.PrimArray where+  czipWith f l r =+    PA.generatePrimArray+      (PA.sizeofPrimArray l `min` PA.sizeofPrimArray r) $ \n ->+        f (PA.indexPrimArray l n) (PA.indexPrimArray r n)+  {-# INLINE [1] czipWith #-}++class CZip f => CUnzip f where+  cunzip+    :: (Dom f (a, b), Dom f a, Dom f b)+    => f (a, b) -> (f a, f b)+  {-# INLINE [1] cunzip #-}+  cunzip = cunzipWith id++  cunzipWith+    :: (Dom f c, Dom f a, Dom f b)+    => (c -> (a, b)) -> f c -> (f a, f b)++cunzipDefault+  :: (CFunctor f, Dom f (a, b), Dom f a, Dom f b)+  => f (a, b) -> (f a, f b)+{-# INLINE cunzipDefault #-}+cunzipDefault = cmap fst &&& cmap snd++#if MIN_VERSION_semialign(1,1,0)+instance Unzip f => CUnzip (WrapFunctor f) where+#else+instance (Zip f, Unzip f) => CUnzip (WrapFunctor f) where+#endif+  cunzip :: forall a b. WrapFunctor f (a, b) -> (WrapFunctor f a, WrapFunctor f b)+  {-# INLINE cunzip #-}+  cunzip = coerce $ unzip @f @a @b+  {-# INLINE cunzipWith #-}+  cunzipWith = coerce $ unzipWith @f @c @a @b+    :: forall a b c. (c -> (a, b)) -> WrapFunctor f c -> (WrapFunctor f a, WrapFunctor f b)++instance CUnzip [] where+  cunzip = P.unzip+  {-# INLINE [1] cunzip #-}+  cunzipWith = \f -> P.unzip . map f+  {-# INLINE [1] cunzipWith #-}++deriving via WrapFunctor Maybe instance CUnzip Maybe+#if MIN_VERSION_semialign(1,1,0)+deriving via WrapFunctor Option instance CUnzip Option+#endif+deriving via [] instance CUnzip ZipList+deriving via WrapFunctor Identity instance CUnzip Identity+deriving via WrapFunctor NE.NonEmpty instance CUnzip NE.NonEmpty+deriving via WrapFunctor Tree instance CUnzip Tree+instance CUnzip V.Vector where+  cunzip = V.unzip+  {-# INLINE [1] cunzip #-}+  cunzipWith = \f -> V.unzip . V.map f+  {-# INLINE [1] cunzipWith #-}+instance CUnzip U.Vector where+  cunzip = U.unzip+  {-# INLINE [1] cunzip #-}+  cunzipWith = \f -> U.unzip . U.map f+  {-# INLINE [1] cunzipWith #-}++instance CUnzip PV.Vector where+  cunzip = G.unzip+  {-# INLINE [1] cunzip #-}+  cunzipWith = \f ->+    (G.convert *** G.convert)  . cunzipWith @V.Vector f . V.convert+  {-# INLINE [1] cunzipWith #-}++instance CUnzip S.Vector where+  cunzip = G.unzip+  {-# INLINE [1] cunzip #-}+  cunzipWith = \f ->+    (G.convert *** G.convert)  . cunzipWith @V.Vector f . V.convert+  {-# INLINE [1] cunzipWith #-}+deriving via WrapFunctor Proxy instance CUnzip Proxy+#if MIN_VERSION_semialign(1,1,0)+deriving via WrapFunctor Seq.Seq instance CUnzip Seq.Seq+deriving via WrapFunctor (M.Map k) instance Ord k => CUnzip (M.Map k)+deriving via WrapFunctor IM.IntMap instance CUnzip IM.IntMap+deriving via WrapFunctor (HM.HashMap k)+  instance (Eq k, Hashable k) => CUnzip (HM.HashMap k)+#endif++instance (CUnzip f, CUnzip g) => CUnzip (SOP.Product f g) where+  cunzipWith f (SOP.Pair a b)  =+    (SOP.Pair al bl, SOP.Pair ar br)+    where+      ~(al, ar) = cunzipWith f a+      ~(bl, br) = cunzipWith f b+  {-# INLINE [1] cunzipWith #-}+  cunzip (SOP.Pair a b)  =+    (SOP.Pair al bl, SOP.Pair ar br)+    where+      ~(al, ar) = cunzip a+      ~(bl, br) = cunzip b+  {-# INLINE [1] cunzip #-}++instance (CUnzip f, CUnzip g) => CUnzip (f :*: g) where+  cunzipWith f (a :*: b)  =+    (al :*: bl, ar :*: br)+    where+      ~(al, ar) = cunzipWith f a+      ~(bl, br) = cunzipWith f b+  {-# INLINE [1] cunzipWith #-}+  cunzip (a :*: b)  =+    (al :*: bl, ar :*: br)+    where+      ~(al, ar) = cunzip a+      ~(bl, br) = cunzip b+  {-# INLINE [1] cunzip #-}++instance (CUnzip f, CUnzip g) => CUnzip (Compose f g) where+  cunzipWith f (Compose a) = (Compose y, Compose z) where+    ~(y, z) = cunzipWith (cunzipWith f) a+  {-# INLINE [1] cunzipWith #-}++instance (CUnzip f, CUnzip g) => CUnzip (f :.: g) where+  cunzipWith f (Comp1 a) = (Comp1 y, Comp1 z) where+    ~(y, z) = cunzipWith (cunzipWith f) a+  {-# INLINE [1] cunzipWith #-}++instance (MT.IsSequence mono, MonoZip mono)+  => CZip (WrapMono mono) where+    czipWith f = coerce $ ozipWith @mono f+    {-# INLINE [1] czipWith #-}++instance (MT.IsSequence mono, MonoZip mono)+  => CUnzip (WrapMono mono) where+    cunzipWith f = coerce $ omap @mono (fst . f) &&& omap @mono (snd . f)

@@ -0,0 +1,112 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 06bb5130d08da403db0bdee15f708a050dca4d9ba1adb757dd932c9586b3b0c2++name:           subcategories+version:        0.1.0.0+synopsis:       Subcategories induced by class constraints+description:    Please see the README on GitHub at <https://github.com/konn/subcategories#readme>+category:       Data+homepage:       https://github.com/konn/subcategories#readme+bug-reports:    https://github.com/konn/subcategories/issues+author:         Hiromi ISHII+maintainer:     konn.jinro _at_ gmail.com+copyright:      2018 (c) Hiromi ISHII+license:        BSD3+license-file:   LICENSE+tested-with:    GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/konn/subcategories++library+  exposed-modules:+      Control.Subcategory+      Control.Subcategory.Alternative+      Control.Subcategory.Alternative.Class+      Control.Subcategory.Applicative+      Control.Subcategory.Applicative.Class+      Control.Subcategory.Bind+      Control.Subcategory.Foldable+      Control.Subcategory.Functor+      Control.Subcategory.Pointed+      Control.Subcategory.RebindableSyntax+      Control.Subcategory.Semialign+      Control.Subcategory.Zip+  other-modules:+      Control.Subcategory.Wrapper.Internal+  hs-source-dirs:+      src+  default-extensions: ConstraintKinds DataKinds DefaultSignatures DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures MultiParamTypeClasses PolyKinds ScopedTypeVariables TypeApplications TypeFamilies TypeInType UndecidableInstances+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , containers+    , data-default+    , foldl+    , hashable+    , mono-traversable+    , pointed+    , primitive+    , reflection+    , semialign+    , template-haskell+    , text+    , these+    , unordered-containers+    , vector+    , vector-algorithms+    , vector-builder+  default-language: Haskell2010++test-suite subcategories-test+  type: exitcode-stdio-1.0+  main-is: spec.hs+  other-modules:+      Control.Subcategory.FoldableSpec+      Control.Subcategory.FunctorSpec+      Control.Subcategory.ZipSpec+      Shared+      Paths_subcategories+  hs-source-dirs:+      test+  default-extensions: ConstraintKinds DataKinds DefaultSignatures DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures MultiParamTypeClasses PolyKinds ScopedTypeVariables TypeApplications TypeFamilies TypeInType UndecidableInstances+  ghc-options: -Wall -fno-hpc+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , bytestring+    , containers+    , data-default+    , foldl+    , hashable+    , inspection-testing+    , mono-traversable+    , pointed+    , primitive+    , reflection+    , semialign+    , subcategories+    , tasty+    , tasty-expected-failure+    , tasty-hunit+    , tasty-quickcheck+    , template-haskell+    , text+    , these+    , unordered-containers+    , vector+    , vector-algorithms+    , vector-builder+  default-language: Haskell2010

@@ -0,0 +1,208 @@+{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions+      -dsuppress-type-applications+      -dsuppress-module-prefixes -dsuppress-type-signatures+      -dsuppress-uniques #-}+module Control.Subcategory.FoldableSpec where+import Control.Subcategory.Foldable+import Control.Subcategory.Functor++import           Data.MonoTraversable+import qualified Data.Vector           as V+import qualified Data.Vector.Generic   as G+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Storable  as S+import qualified Data.Vector.Unboxed   as U+import           Shared+import           Test.Inspection+import           Test.Tasty++cfoldr_uvec :: (Int -> b -> b) -> b -> U.Vector Int -> b+cfoldr_uvec = cfoldr++cfoldr_uvec_poly :: U.Unbox a => (a -> b -> b) -> b -> U.Vector a -> b+cfoldr_uvec_poly = cfoldr++foldr_uvec :: (Int -> b -> b) -> b -> U.Vector Int -> b+foldr_uvec = U.foldr++cfoldr_svec :: (Int -> b -> b) -> b -> S.Vector Int -> b+cfoldr_svec = cfoldr++cfoldr_svec_poly :: S.Storable a => (a -> b -> b) -> b -> S.Vector a -> b+cfoldr_svec_poly = cfoldr++foldr_svec :: (Int -> b -> b) -> b -> S.Vector Int -> b+foldr_svec = S.foldr++cfoldr_pvec :: (Int -> b -> b) -> b -> P.Vector Int -> b+cfoldr_pvec = cfoldr++cfoldr_pvec_poly :: P.Prim a => (a -> b -> b) -> b -> P.Vector a -> b+cfoldr_pvec_poly = cfoldr++foldr_pvec :: (Int -> b -> b) -> b -> P.Vector Int -> b+foldr_pvec = P.foldr++cfoldr_bvec :: (a -> b -> b) -> b -> V.Vector a -> b+cfoldr_bvec = cfoldr++foldr_bvec :: (a -> b -> b) -> b -> V.Vector a -> b+foldr_bvec = V.foldr++cfoldr_list :: (a -> b -> b) -> b -> [a] -> b+cfoldr_list = cfoldr++foldr_list :: (a -> b -> b) -> b -> [a] -> b+foldr_list = foldr++test_cfoldr :: TestTree+test_cfoldr = testGroup "cfoldr"+  [ testGroup "List"+    [ $(inspecting "has the same representation as V.foldr"+        $ 'cfoldr_list ==- 'foldr_list+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cfoldr_list+      )+    ]+  , testGroup "BVector"+    [ $(inspecting "has the same representation as V.foldr"+        $ 'cfoldr_bvec ==- 'foldr_bvec+      )+    , $(inspecting "has no instance dictionary except G.Vector"+      $ 'cfoldr_bvec `hasNoTypeClassesExcept` [''G.Vector]+      )+    ]+  , testGroup "UVector"+    [ $(inspecting "has the same representation as U.foldr (if an element is concrete)"+        $ 'cfoldr_uvec ==- 'foldr_uvec+      )+    , $(inspecting "has no instance dictionary other than Unbox (if polymorphic)"+      $ 'cfoldr_uvec_poly `hasNoTypeClassesExcept` [''U.Unbox]+      )+    ]+  , testGroup "SVector"+    [ $(inspecting "has the same representation as S.foldr (if an element is concrete)"+        $ 'cfoldr_svec ==- 'foldr_svec+      )+    , $(inspecting "has no instance dictionary other than Storable (if polymorphic)"+      $ 'cfoldr_svec_poly `hasNoTypeClassesExcept` [''S.Storable]+      )+    ]+  , testGroup "PVector"+    [ $(inspecting "has the same representation as P.foldr (if an element is concrete)"+        $ 'cfoldr_pvec ==- 'foldr_pvec+      )+    , $(inspecting "has no instance dictionary other than Storable (if polymorphic)"+      $ 'cfoldr_pvec_poly `hasNoTypeClassesExcept` [''P.Prim]+      )+    ]+  ]++cfoldMap_uvec :: Monoid w => (Int -> w) -> U.Vector Int -> w+cfoldMap_uvec = cfoldMap++ofoldMap_uvec :: Monoid w => (Int -> w) -> U.Vector Int -> w+ofoldMap_uvec = ofoldMap++test_cfoldMap :: TestTree+test_cfoldMap = testGroup "cfoldMap"+    [ testGroup "UVector"+      [ $(inspecting "has the same rep as ofoldMap (if elements concrete)"+        $ 'cfoldMap_uvec ==- 'ofoldMap_uvec+        )+      ]+    ]++cinit_list :: [a] -> [a]+cinit_list = cinit++init_list :: [a] -> [a]+{-# INLINE init_list #-}+init_list = init++test_cinit :: TestTree+test_cinit = testGroup "cinit"+  [ testGroup "List"+    [ $(inspecting "has the same represeitation as Prelude.init"+      $ 'cinit_list ==- 'init_list+      )+    ]+  ]++ctoList_list :: [a] -> [a]+ctoList_list = ctoList++list_id :: [a] -> [a]+list_id = id++list_id_lam :: [a] -> [a]+list_id_lam = \x -> x++cfromList_list :: [a] -> [a]+cfromList_list = cfromList++test_ctoList :: TestTree+test_ctoList = testGroup "ctoList"+  [ testGroup "List"+    [ $(inspecting "has the same represeitation as Prelude.id"+      $ 'ctoList_list ==- 'list_id+      )+    ]+  ]++test_cfromList :: TestTree+test_cfromList = testGroup "cfromList"+  [ testGroup "List"+    [ $(inspecting "has the same represeitation as Prelude.id"+      $ 'cfromList_list ==- 'list_id+      )+    ]+  ]+++ctoFromList_list :: [a] -> [a]+ctoFromList_list = ctoList . cfromList @[]++ctoFromList_bvec :: [a] -> [a]+ctoFromList_bvec xs = ctoList (cfromList @V.Vector xs)++ctoFromList_poly :: forall f a. (CFreeMonoid f, Dom f a) => [a] -> [a]+ctoFromList_poly xs = ctoList (cfromList @f xs)++list_id_with_constr :: forall f a. (CFreeMonoid f, Dom f a) => [a] -> [a]+list_id_with_constr = \xs -> xs++test_rules :: TestTree+test_rules = testGroup "Rewrite rules"+  [ testGroup "ctoList . cfromList = ctoList"+    [ $(inspecting "List"+        $ 'ctoFromList_list ==- 'list_id_lam+      )+    , $(inspecting "Boxed vector"+        $ 'ctoFromList_bvec ==- 'list_id_lam+      )+    , $(inspecting "Polymorphic (up to dictionary leftover)"+        $ 'ctoFromList_poly ==- 'list_id_with_constr+      )+    ]+  ]++cgen_bvec, gen_bvec :: Int -> (Int -> a) -> V.Vector a+cgen_bvec = cgenerate+gen_bvec = V.generate++test_generate :: TestTree+test_generate = testGroup "cgenerate"+  [ $(inspecting "Boxed Vector" $ 'cgen_bvec ==- 'gen_bvec)+  ]++crev_list, rev_list :: [a] -> [a]+crev_list = creverse+rev_list = reverse++test_reverse :: TestTree+test_reverse = testGroup "creverse"+  [ $(inspecting "List" $ 'crev_list ==- 'rev_list)+  ]

@@ -0,0 +1,231 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions+      -dsuppress-type-applications+      -dsuppress-module-prefixes -dsuppress-type-signatures+      -dsuppress-uniques #-}+module Control.Subcategory.FunctorSpec where+import Control.Subcategory.Functor++import qualified Data.ByteString           as BS+import           Data.Hashable             (Hashable)+import           Data.HashSet              (HashSet)+import qualified Data.HashSet              as HS+import           Data.IntSet               (IntSet)+import qualified Data.IntSet               as IS+import qualified Data.Primitive.Array      as A+import qualified Data.Primitive.PrimArray  as PA+import qualified Data.Primitive.SmallArray as SA+import qualified Data.Sequence             as Seq+import           Data.Set                  (Set)+import qualified Data.Set                  as Set+import qualified Data.Text                 as T+import qualified Data.Vector               as V+import qualified Data.Vector.Primitive     as P+import qualified Data.Vector.Storable      as S+import qualified Data.Vector.Unboxed       as U+import           Data.Word                 (Word8)+import           Shared+import           Test.Inspection+import           Test.Tasty++cmap_list :: (a -> b) -> [a] -> [b]+cmap_list = cmap++map_list :: (a -> b) -> [a] -> [b]+map_list = map++cmap_seq :: (a -> b) -> Seq.Seq a -> Seq.Seq b+cmap_seq = cmap++map_seq :: (a -> b) -> Seq.Seq a -> Seq.Seq b+map_seq = fmap++cmap_intset :: (Int -> Int) -> WrapMono IntSet Int -> WrapMono IntSet Int+cmap_intset = cmap++map_intset :: (Int -> Int) -> IntSet -> IntSet+map_intset = IS.map++cmap_uvec :: (Int -> Bool) -> U.Vector Int -> U.Vector Bool+cmap_uvec = cmap++map_uvec :: (Int -> Bool) -> U.Vector Int -> U.Vector Bool+map_uvec = U.map++cmap_bvec :: (a -> b) -> V.Vector a -> V.Vector b+cmap_bvec = cmap++map_bvec :: (a -> b) -> V.Vector a -> V.Vector b+map_bvec = V.map++cmap_svec :: (Int -> Bool) -> S.Vector Int -> S.Vector Bool+cmap_svec = cmap++map_svec :: (Int -> Bool) -> S.Vector Int -> S.Vector Bool+map_svec = S.map++cmap_pvec :: (Int -> Word) -> P.Vector Int -> P.Vector Word+cmap_pvec = cmap++map_pvec :: (Int -> Word) -> P.Vector Int -> P.Vector Word+map_pvec = P.map++cmap_smallarray :: (Int -> Word) -> SA.SmallArray Int -> SA.SmallArray Word+cmap_smallarray = cmap++map_smallarray :: (Int -> Word) -> SA.SmallArray Int -> SA.SmallArray Word+map_smallarray = fmap++cmap_array :: (Int -> Word) -> A.Array Int -> A.Array Word+cmap_array = cmap++map_array :: (Int -> Word) -> A.Array Int -> A.Array Word+map_array = fmap++cmap_primarray :: (Int -> Word) -> PA.PrimArray Int -> PA.PrimArray Word+cmap_primarray = cmap++map_primarray :: (Int -> Word) -> PA.PrimArray Int -> PA.PrimArray Word+map_primarray = PA.mapPrimArray++cmap_Maybe :: (a -> b) -> Maybe a -> Maybe b+cmap_Maybe = cmap++map_Maybe :: (a -> b) -> Maybe a -> Maybe b+map_Maybe = fmap++cmap_Set :: (Ord b) => (Int -> b) -> Set Int -> Set b+cmap_Set = cmap++map_Set :: Ord b => (Int -> b) -> Set Int -> Set b+map_Set = Set.map++cmap_HashSet+  :: (Hashable b, Eq b)+  => (String -> Maybe b) -> HashSet String -> HashSet (Maybe b)+cmap_HashSet = cmap++map_HashSet+  :: (Hashable b, Eq b) => (String -> Maybe b) -> HashSet String -> HashSet (Maybe b)+{-# INLINE map_HashSet #-}+map_HashSet = HS.map++cmap_MonoBS :: (Word8 -> Word8) -> WrapMono BS.ByteString Word8 -> WrapMono BS.ByteString Word8+cmap_MonoBS = cmap++map_BS :: (Word8 -> Word8) -> BS.ByteString -> BS.ByteString+{-# INLINE map_BS #-}+map_BS = BS.map++cmap_MonoText :: (Char -> Char) -> WrapMono T.Text Char -> WrapMono T.Text Char+cmap_MonoText = cmap++map_Text :: (Char -> Char) -> T.Text -> T.Text+{-# INLINE map_Text #-}+map_Text = T.map++test_cmap :: TestTree+test_cmap = testGroup "cmap"+  [ testGroup "list"+    [ $(inspecting "has the same representation as Prelude.map"+        $ 'cmap_list ==- 'map_list+      )+    ]+  , testGroup "Seq"+    [ $(inspecting "has the same representation as fmap"+        $ 'cmap_seq ==- 'map_seq+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_seq+      )+    ]+  , testGroup "IntSet"+    [ $(inspecting "has the same representation as IntSet.map"+        $ 'cmap_intset ==- 'map_intset+      )+    ]+  , testGroup "BVector"+    [ $(inspecting "has the same representation as V.map"+        $ 'cmap_bvec ==- 'map_bvec+      )+    ]+  , testGroup "UVector"+    [ $(inspecting "has the same representation as U.map"+        $ 'cmap_uvec ==- 'map_uvec+      )+    ]+  , testGroup "SVector"+    [ $(inspecting "has the same representation as S.map"+        $ 'cmap_svec ==- 'map_svec+      )+    ]+  , testGroup "PVector"+    [ $(inspecting "has the same representation as P.map"+        $ 'cmap_pvec ==- 'map_pvec+      )+    ]+  , testGroup "SmallArray"+    [ $(inspecting "has the same representation as fmap"+        $ 'cmap_smallarray ==- 'map_smallarray+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_smallarray+      )+    ]+  , testGroup "Array"+    [ $(inspecting "has the same representation as fmap"+        $ 'cmap_array ==- 'map_array+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_array+      )+    ]+  , testGroup "PrimArray"+    [ $(inspecting "has the same representation as PA.mapPrimArray"+        $ 'cmap_primarray ==- 'map_primarray+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_primarray+      )+    ]+  , testGroup "Maybe"+    [ $(inspecting "has the same representation as fmap"+      $ 'cmap_Maybe ==- 'map_Maybe+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_Maybe+      )+    ]+  , testGroup "Set"+    [ $(inspecting "has the same representation as Set.map"+      $ 'cmap_Set ==- 'map_Set+      )+    , $(inspecting "has no instance dictionary except Ord"+      $ 'cmap_Set `hasNoTypeClassesExcept` [''Ord]+      )+    ]+  , testGroup "HashSet"+    [ $(inspecting "has the same representation as HS.map, if the first argument is concrete"+      $ 'cmap_HashSet ==- 'map_HashSet+      )+    , $(inspecting "has no instance dictionary except EQ and Hashable"+      $ 'cmap_HashSet `hasNoTypeClassesExcept` [''Eq, ''Hashable]+      )+    ]+  , testGroup "WrapMono ByteString"+    [ $(inspecting "has the same representation as Data.ByteString.map"+      $ 'cmap_MonoBS ==- 'map_BS+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_MonoBS+      )+    ]+  , testGroup "WrapMono Text"+    [ $(inspecting "has the same representation as Data.Text.map"+      $ 'cmap_MonoText ==- 'map_Text+      )+    , $(inspecting "has no instance dictionary"+      $ hasNoTypeClasses 'cmap_MonoText+      )+    ]+  ]

@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions+      -dsuppress-type-applications+      -dsuppress-module-prefixes -dsuppress-type-signatures+      -dsuppress-uniques #-}+module Control.Subcategory.ZipSpec where+import Control.Subcategory.Zip++import qualified Data.Vector     as V+import           Shared+import           Test.Inspection+import           Test.Tasty++czipWith_vec :: (a -> b -> c) -> V.Vector a -> V.Vector b -> V.Vector c+czipWith_vec = czipWith++zipWith_vec :: (a -> b -> c) -> V.Vector a -> V.Vector b -> V.Vector c+zipWith_vec = V.zipWith++czipWith_list :: (a -> b -> c) -> [a] -> [b] -> [c]+czipWith_list = czipWith++zipWith_list :: (a -> b -> c) -> [a] -> [b] -> [c]+zipWith_list = Prelude.zipWith++test_czipWith :: TestTree+test_czipWith = testGroup "czipWith"+  [ testGroup "list"+    [ $(inspecting "has the same representation as Prelude.zipWith"+        $ 'czipWith_list ==- 'zipWith_list+      )+    ]+  , testGroup "vector"+    [ $(inspecting "has the same representation as Prelude.zipWith"+        $ 'czipWith_vec ==- 'zipWith_vec+      )+    ]+  ]

@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+module Shared where+import Control.Exception+import Data.Maybe          (listToMaybe)+import GHC.Stack           (callStack)+import GHC.Stack.Types     (getCallStack)+import Language.Haskell.TH+import Test.Inspection+import Test.Tasty.HUnit++checkInspection+  :: HasCallStack => Result -> Assertion+checkInspection Success{} = pure ()+checkInspection (Failure msg) =+  throwIO $ HUnitFailure (fmap snd $ listToMaybe $ getCallStack callStack) msg++inspecting :: String -> Obligation -> Q Exp+inspecting desc reg =+  [|testCase desc $ checkInspection $(inspectTest reg)|]

@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}+module Main where