compactable 0.1.2.4 → 0.2.0.0

raw patch · 12 files changed

+1646/−631 lines, 12 filesdep +QuickCheckdep +aesondep +base-compatdep ~basedep ~bifunctorsdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, base-compat, compactable, contravariant, data-default-class, deepseq, genvalidity, genvalidity-sydtest, hashable, keys, lens, semigroupoids, sydtest, sydtest-discover, these, transformers-compat, unordered-containers, vector-instances

Dependency ranges changed: base, bifunctors, containers, transformers, vector

API changes (from Hackage documentation)

Files

• compactable.cabal +63/−22
• src/Control/Compactable.hs +0/−609
• src/Control/Functor/Compactable.hs +438/−0
• src/Control/Functor/Dichotomous.hs +330/−0
• src/Control/Functor/Elastic.hs +20/−0
• src/Control/Functor/Expansive.hs +212/−0
• test/CompactableSpec.hs +185/−0
• test/Core.hs +143/−0
• test/DichotomousSpec.hs +49/−0
• test/ElasticSpec.hs +50/−0
• test/ExpansiveSpec.hs +155/−0
• test/Main.hs +1/−0

@@ -1,43 +1,84 @@ name:                compactable-version:             0.1.2.4+version:             0.2.0.0 synopsis:            A typeclass for structures which can be catMaybed, filtered, and partitioned. description:         This provides polymorphic implementations for filter, compact (catMaybes), and separate. It allows for higher performance implementations to be used in place of defaults for all data structures, and endeavors to centerally document those implementations. Compactable aims to be as general and unconstrained as possible, providing instances for non-Functors like Set, as well as some Contravariants (though not published here). Compactable fully subsumes Data.Witherable, offers more laws, and is more general. license:             BSD3 license-file:        LICENSE author:              Isaac Shapira-maintainer:          fresheyeball@gmail.com--- copyright:+maintainer:          fresheyeball@protonmail.com category:            Control build-type:          Simple extra-source-files:  ChangeLog.md cabal-version:       >=1.10-tested-with:         GHC == 9.0.1-                   , GHC == 8.10.4-                   , GHC == 8.8.4-                   , GHC == 8.6.1-                   , GHC == 8.4.4-                   , GHC == 8.2.2-                   , GHC == 8.0.2+tested-with:         GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.1  source-repository head   type: git   location: https://gitlab.com/fresheyeball/Compactable.git  library-  exposed-modules:     Control.Compactable--  ghc-options:         -Wall-                       -Wincomplete-record-updates-                       -Wincomplete-uni-patterns-                       -Wredundant-constraints+  exposed-modules:+      Control.Functor.Compactable+    , Control.Functor.Dichotomous+    , Control.Functor.Elastic+    , Control.Functor.Expansive -  build-depends:       base         >= 4.9    && < 4.16-                     , containers   >= 0.5.7  && < 0.7-                     , transformers >= 0.5.2  && < 0.6-                     , vector       >= 0.11   && < 0.13+  ghc-options:+    -Wall+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints -  if impl(ghc < 8.2.2)-    build-depends: bifunctors >= 5.4+  build-depends:+      base >= 4.9 && < 4.16+    , containers+    , transformers+    , vector+    , aeson+    , base-compat+    , bifunctors+    , contravariant+    , data-default-class+    , deepseq+    , hashable+    , keys+    , lens+    , these+    , QuickCheck+    , semigroupoids+    , transformers-compat+    , unordered-containers+    , vector+    , vector-instances    hs-source-dirs:      src   default-language:    Haskell2010+++test-suite props+  type: exitcode-stdio-1.0+  other-modules:+     Core+   , CompactableSpec+   , ElasticSpec+   , ExpansiveSpec+   , DichotomousSpec+  main-is: Main.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N +RTS -H2G -A32M -RTS+  default-language:    Haskell2010+  hs-source-dirs:+    test+  build-depends:+    base+    , QuickCheck+    , sydtest+    , sydtest-discover+    , genvalidity+    , genvalidity-sydtest+    , compactable+    , containers+    , vector+    , these

@@ -1,609 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE ConstrainedClassMethods    #-}-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeOperators              #-}--module Control.Compactable-  (-  -- * Compact-    Compactable (..)-  -- * Compact Fold-  , CompactFold (..)-  -- * Handly flips-  , fforMaybe-  , fforFold-  , fforEither-  , fforBifold-  -- * More general lefts and rights-  , mfold'-  , mlefts-  , mrights-  -- * Monad Transformer utils-  , fmapMaybeM-  , fmapEitherM-  , fforMaybeM-  , fforEitherM-  , applyMaybeM-  , bindMaybeM-  , traverseMaybeM-  -- * Alternative Defaults-  , altDefaultCompact-  , altDefaultSeparate-  ) where--import           Control.Applicative-import           Control.Arrow-import           Control.Monad                   (MonadPlus, join)-import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Maybe-import           Data.Bifoldable-import           Data.Bifunctor                  (bimap)-import           Data.Either                     (partitionEithers)-import           Data.Foldable                   as F (foldl', toList)-import           Data.Functor.Compose-import qualified Data.Functor.Product            as FP-import qualified Data.IntMap                     as IntMap-import qualified Data.List                       as List-import qualified Data.Map                        as Map-import           Data.Maybe-import           Data.Monoid-import           Data.Proxy-import           Data.Semigroup-import qualified Data.Sequence                   as Seq-import qualified Data.Set                        as Set-import qualified Data.Vector                     as V-import           GHC.Conc-import           GHC.Generics-import           Text.ParserCombinators.ReadP-import           Text.ParserCombinators.ReadPrec--{-|-Class 'Compactable' provides two methods which can be writen in terms of each other, compact and separate.--is generalization of catMaybes as a new function. Compact-has relations with Functor, Applicative, Monad, Alternative, and Traversable.-In that we can use these class to provide the ability to operate on a data type-by throwing away intermediate Nothings. This is useful for representing-stripping out values or failure.--To be compactable alone, no laws must be satisfied other than the type signature.--If the data type is also a Functor the following should hold:--[/Kleisli composition/]--    @fmapMaybe (l <=< r) = fmapMaybe l . fmapMaybe r@--[/Functor identity 1/]--    @compact . fmap Just = id@--[/Functor identity 2/]--    @fmapMaybe Just = id@--[/Functor relation/]--    @compact = fmapMaybe id@--According to Kmett, (Compactable f, Functor f) is a functor from the-kleisli category of Maybe to the category of haskell data types.-@Kleisli Maybe -> Hask@.--If the data type is also Applicative the following should hold:--[/Applicative left identity/]--    @compact . (pure Just \<*\>) = id@--[/Applicative right identity/]--    @applyMaybe (pure Just) = id@--[/Applicative relation/]--    @compact = applyMaybe (pure id)@--If the data type is also a Monad the following should hold:--[/Monad left identity/]--    @flip bindMaybe (return . Just) = id@--[/Monad right identity/]--    @compact . (return . Just =<<) = id@--[/Monad relation/]--    @compact = flip bindMaybe return@--If the data type is also Alternative the following should hold:--[/Alternative identity/]--    @compact empty = empty@--[/Alternative annihilation/]--    @compact (const Nothing \<$\> xs) = empty@--If the data type is also Traversable the following should hold:--[/Traversable Applicative relation/]--    @traverseMaybe (pure . Just) = pure@--[/Traversable composition/]--    @Compose . fmap (traverseMaybe f) . traverseMaybe g = traverseMaybe (Compose . fmap (traverseMaybe f) . g)@--[/Traversable Functor relation/]--    @traverse f = traverseMaybe (fmap Just . f)@--[/Traversable naturality/]--    @t . traverseMaybe f = traverseMaybe (t . f)@--= Separate and filter-have recently elevated roles in this typeclass, and is not as well explored as compact. Here are the laws known today:--[/Functor identity 3/]--    @fst . separate . fmap Right = id@--[/Functor identity 4/]--    @snd . separate . fmap Left = id@--[/Applicative left identity 2/]--    @snd . separate . (pure Right \<*\>) = id@--[/Applicative right identity 2/]--    @fst . separate . (pure Left \<*\>) = id@--[/Alternative annihilation left/]--    @snd . separate . fmap (const Left) = empty@--[/Alternative annihilation right/]--    @fst , separate . fmap (const Right) = empty@--Docs for relationships between these functions and, a cleanup of laws will happen at some point.--If you know of more useful laws, or have better names for the ones above-(especially those marked "name me"). Please let me know.--}--class Compactable (f :: * -> *) where-    {-# MINIMAL compact | separate #-}--    compact :: f (Maybe a) -> f a-    default compact :: Functor f => f (Maybe a) -> f a-    compact = snd . separate . fmap (\case Just x -> Right x; _ -> Left ())-    {-# INLINABLE compact #-}--    separate :: f (Either l r) -> (f l, f r)-    default separate :: Functor f => f (Either l r) -> (f l, f r)-    separate xs = (compact $ hush . flipEither <$> xs, compact $ hush <$> xs)-    {-# INLINABLE separate #-}--    filter :: (a -> Bool) -> f a -> f a-    default filter :: Functor f => (a -> Bool) -> f a -> f a-    filter f = fmapMaybe $ \a -> if f a then Just a else Nothing-    {-# INLINABLE filter #-}--    partition :: (a -> Bool) -> f a -> (f a, f a)-    default partition :: Functor f => (a -> Bool) -> f a -> (f a, f a)-    partition f = fmapEither $ \a -> if f a then Right a else Left a-    {-# INLINEABLE partition #-}--    fmapMaybe :: Functor f => (a -> Maybe b) -> f a -> f b-    fmapMaybe f = compact . fmap f-    {-# INLINABLE fmapMaybe #-}--    fmapEither :: Functor f => (a -> Either l r) -> f a -> (f l, f r)-    fmapEither f = separate . fmap f-    {-# INLINABLE fmapEither #-}--    applyMaybe :: Applicative f => f (a -> Maybe b) -> f a -> f b-    applyMaybe fa = compact . (fa <*>)-    {-# INLINABLE applyMaybe #-}--    applyEither :: Applicative f => f (a -> Either l r) -> f a -> (f l, f r)-    applyEither fa = separate . (fa <*>)-    {-# INLINABLE applyEither #-}--    bindMaybe :: Monad f => f a -> (a -> f (Maybe b)) -> f b-    bindMaybe x = compact . (x >>=)-    {-# INLINABLE bindMaybe #-}--    bindEither :: Monad f => f a -> (a -> f (Either l r)) -> (f l, f r)-    bindEither x = separate . (x >>=)-    {-# INLINABLE bindEither #-}--    traverseMaybe :: (Applicative g, Traversable f)-                  => (a -> g (Maybe b)) -> f a -> g (f b)-    traverseMaybe f = fmap compact . traverse f-    {-# INLINABLE traverseMaybe #-}--    traverseEither :: (Applicative g, Traversable f)-                   => (a -> g (Either l r)) -> f a -> g (f l, f r)-    traverseEither f = fmap separate . traverse f-    {-# INLINABLE traverseEither #-}---instance Compactable Maybe where-    compact = join-    {-# INLINABLE compact #-}-    fmapMaybe = (=<<)-    {-# INLINABLE fmapMaybe #-}-    separate = \case-      Just x -> case x of-         Left l  -> (Just l, Nothing)-         Right r -> (Nothing, Just r)-      _ -> (Nothing, Nothing)-    {-# INLINABLE separate #-}--instance Monoid m => Compactable (Either m) where-    compact (Right (Just x)) = Right x-    compact (Right _)        = Left mempty-    compact (Left x)         = Left x-    {-# INLINABLE compact #-}-    fmapMaybe f (Right x) = maybe (Left mempty) Right (f x)-    fmapMaybe _ (Left x)  = Left x-    {-# INLINABLE fmapMaybe #-}-    separate = \case-      Right (Left l) -> (Right l, Left mempty)-      Right (Right r) -> (Left mempty, Right r)-      Left x -> (Left x, Left x)-    {-# INLINABLE separate #-}--instance Compactable [] where-    compact = catMaybes-    {-# INLINABLE compact #-}-    fmapMaybe _ []    = []-    fmapMaybe f (h:t) = maybe (fmapMaybe f t) (: fmapMaybe f t) (f h)-    {-# INLINABLE fmapMaybe #-}-    filter = Prelude.filter-    {-# INLINABLE filter #-}-    partition = List.partition-    {-# INLINABLE partition #-}-    separate = partitionEithers-    {-# INLINABLE separate #-}-    fmapEither f = foldl' (deal f) ([],[])-      where deal g ~(bs, cs) a = case g a of-             Left b  -> (b:bs, cs)-             Right c -> (bs, c:cs)-    {-# INLINABLE fmapEither #-}-    traverseMaybe f = go where-      go (x:xs) = maybe id (:) <$> f x <*> go xs-      go []     = pure []-    {-# INLINE traverseMaybe #-}--instance Compactable ZipList where-  compact (ZipList xs) = ZipList $ compact xs--instance Compactable IO where-    compact = altDefaultCompact-    {-# INLINABLE compact #-}--instance Compactable STM where-    compact = altDefaultCompact-    {-# INLINABLE compact #-}--instance Compactable Proxy where-    compact _ = Proxy-    {-# INLINABLE compact #-}-    separate _ = (Proxy, Proxy)-    {-# INLINABLE separate #-}-    filter _ _ = Proxy-    {-# INLINABLE filter #-}-    partition _ _ = (Proxy, Proxy)-    {-# INLINABLE partition #-}-    fmapMaybe _ _ = Proxy-    {-# INLINABLE fmapMaybe #-}-    applyMaybe _ _ = Proxy-    {-# INLINABLE applyMaybe #-}-    bindMaybe _ _ = Proxy-    {-# INLINABLE bindMaybe #-}-    fmapEither _ _ = (Proxy, Proxy)-    {-# INLINABLE fmapEither #-}-    applyEither _ _ = (Proxy, Proxy)-    {-# INLINABLE applyEither #-}-    bindEither _ _ = (Proxy, Proxy)-    {-# INLINABLE bindEither #-}--instance Compactable U1--instance Compactable Option where-    compact (Option x) = Option (join x)-    {-# INLINABLE compact #-}-    fmapMaybe f (Option (Just x)) = Option (f x)-    fmapMaybe _ _                 = Option Nothing-    {-# INLINABLE fmapMaybe #-}-    separate = altDefaultSeparate-    {-# INLINABLE separate #-}--instance Compactable ReadP--instance Compactable ReadPrec--instance ( Functor f, Functor g, Compactable f, Compactable g )-         => Compactable (FP.Product f g) where-    compact (FP.Pair x y) = FP.Pair (compact x) (compact y)-    {-# INLINABLE compact #-}--instance ( Functor f, Functor g, Compactable g )-         => Compactable (Compose f g) where-    compact = fmapMaybe id-    {-# INLINABLE compact #-}-    fmapMaybe f (Compose fg) = Compose $ fmapMaybe f <$> fg-    {-# INLINABLE fmapMaybe #-}--instance Compactable IntMap.IntMap where-    compact = IntMap.mapMaybe id-    {-# INLINABLE compact #-}-    fmapMaybe = IntMap.mapMaybe-    {-# INLINABLE fmapMaybe #-}-    filter = IntMap.filter-    {-# INLINABLE filter #-}-    partition = IntMap.partition-    {-# INLINABLE partition #-}-    separate = IntMap.mapEither id-    {-# INLINABLE separate #-}-    fmapEither = IntMap.mapEither-    {-# INLINABLE fmapEither #-}--instance Compactable (Map.Map k) where-    compact = Map.mapMaybe id-    {-# INLINABLE compact #-}-    fmapMaybe = Map.mapMaybe-    {-# INLINABLE fmapMaybe #-}-    filter = Map.filter-    {-# INLINABLE filter #-}-    partition = Map.partition-    {-# INLINABLE partition #-}-    separate = Map.mapEither id-    {-# INLINABLE separate #-}-    fmapEither = Map.mapEither-    {-# INLINABLE fmapEither #-}--instance Compactable Seq.Seq where-    compact = fmap fromJust . Seq.filter isJust-    {-# INLINABLE compact #-}-    separate = altDefaultSeparate-    {-# INLINABLE separate #-}-    filter = Seq.filter-    {-# INLINABLE filter #-}-    partition = Seq.partition-    {-# INLINABLE partition #-}---instance Compactable V.Vector where-    compact = altDefaultCompact-    {-# INLINABLE compact #-}-    separate = altDefaultSeparate-    {-# INLINABLE separate #-}-    filter = V.filter-    {-# INLINABLE filter #-}-    partition = V.partition-    {-# INLINABLE partition #-}--instance Compactable (Const r) where-    compact (Const r) = Const r-    {-# INLINABLE compact #-}-    fmapMaybe _ (Const r) = Const r-    {-# INLINABLE fmapMaybe #-}-    applyMaybe _ (Const r) = Const r-    {-# INLINABLE applyMaybe #-}-    bindMaybe (Const r) _ = Const r-    {-# INLINABLE bindMaybe #-}-    fmapEither _ (Const r) = (Const r, Const r)-    {-# INLINABLE fmapEither #-}-    applyEither _ (Const r) = (Const r, Const r)-    {-# INLINABLE applyEither #-}-    bindEither (Const r) _ = (Const r, Const r)-    {-# INLINABLE bindEither #-}-    filter _ (Const r) = Const r-    {-# INLINABLE filter #-}-    partition _ (Const r) = (Const r, Const r)-    {-# INLINABLE partition #-}--instance Compactable Set.Set where-    compact = Set.fromDistinctAscList . compact . Set.toAscList-    {-# INLINABLE compact #-}-    separate = bimap Set.fromDistinctAscList Set.fromDistinctAscList . separate . Set.toAscList-    {-# INLINABLE separate #-}-    filter = Set.filter-    {-# INLINABLE filter #-}-    partition = Set.partition-    {-# INLINABLE partition #-}--instance (ArrowPlus a, ArrowApply a) => Compactable (ArrowMonad a) where-instance Monad a => Compactable (WrappedMonad a) where-instance Functor a => Compactable (Rec1 a) where-instance Functor a => Compactable (Alt a) where-instance (Functor a, Functor b) => Compactable (a :*: b)-instance Functor f => Compactable (M1 i c f)-instance (Functor f, Functor g) => Compactable (f :.: g)--newtype AltSum f a = AltSum { unAltSum :: f a }-    deriving (Functor, Applicative, Alternative)-#if __GLASGOW_HASKELL__ > 840-instance Alternative f => Monoid (AltSum f a) where-    mempty = empty-    AltSum a `mappend` AltSum b = AltSum (a <|> b)-#else-instance Alternative f => Semigroup (AltSum f a) where-    AltSum a <> AltSum b = AltSum (a <|> b)-instance Alternative f => Monoid (AltSum f a) where-    mappend = (Data.Semigroup.<>)-    mempty = empty-#endif---{-|-class `CompactFold` provides the same methods as `Compactable` but generalized to work on any `Foldable`.--When a type has Alternative (or similar) properties, we can extract the Maybe and the Either, and generalize to Foldable and Bifoldable.--Compactable can always be described in terms of CompactFold, because--  @compact = compactFold@--and--  @separate = separateFold@--as it's just a specialization. More exploration is needed on the relationship here.--}-class Compactable f => CompactFold (f :: * -> *) where-    compactFold :: Foldable g => f (g a) -> f a-    default compactFold :: (Monad f, Alternative f, Foldable g) => f (g a) -> f a-    compactFold = (>>= mfold')-    {-# INLINEABLE compactFold #-}--    separateFold :: Bifoldable g => f (g a b) -> (f a, f b)-    default separateFold :: (Monad f, Alternative f, Bifoldable g) => f (g a b) -> (f a, f b)-    separateFold xs = (xs >>= mlefts, xs >>= mrights)-    {-# INLINEABLE separateFold #-}--    fmapFold :: (Functor f, Foldable g) => (a -> g b) -> f a -> f b-    fmapFold f = compactFold . fmap f-    {-# INLINABLE fmapFold #-}--    fmapBifold :: (Functor f, Bifoldable g) => (a -> g l r) -> f a -> (f l, f r)-    fmapBifold f = separateFold . fmap f-    {-# INLINABLE fmapBifold #-}--    applyFold :: (Applicative f, Foldable g) => f (a -> g b) -> f a -> f b-    applyFold f = compactFold . (f <*>)-    {-# INLINABLE applyFold #-}--    applyBifold :: (Applicative f, Bifoldable g) => f (a -> g l r) -> f a -> (f l, f r)-    applyBifold fa = separateFold . (fa <*>)-    {-# INLINABLE applyBifold #-}--    bindFold :: (Monad f, Foldable g) => f a -> (a -> f (g b)) -> f b-    bindFold f = compactFold . (f >>=)-    {-# INLINABLE bindFold #-}--    bindBifold :: (Monad f, Bifoldable g) => f a -> (a -> f (g l r)) -> (f l, f r)-    bindBifold f = separateFold . (f >>=)-    {-# INLINABLE bindBifold  #-}--    traverseFold :: (Applicative h, Foldable g, Traversable f) => (a -> h (g b)) -> f a -> h (f b)-    traverseFold f = fmap compactFold . traverse f-    {-# INLINABLE traverseFold #-}--    traverseBifold :: (Applicative h, Bifoldable g, Traversable f) => (a -> h (g l r)) -> f a -> h (f l, f r)-    traverseBifold f = fmap separateFold . traverse f-    {-# INLINABLE traverseBifold #-}---mfold' :: (Foldable f, Alternative m) => f a -> m a-mfold' = unAltSum . foldMap (AltSum . pure)--mlefts :: (Bifoldable f, Alternative m) => f a b -> m a-mlefts = unAltSum . bifoldMap (AltSum . pure) (const mempty)--mrights :: (Bifoldable f, Alternative m) => f a b -> m b-mrights = unAltSum . bifoldMap (const mempty) (AltSum . pure)---instance CompactFold [] where-    compactFold = (>>= F.toList)-    {-# INLINEABLE compactFold #-}--instance CompactFold Maybe-instance CompactFold IO-instance CompactFold ReadP-instance CompactFold ReadPrec-instance CompactFold STM-instance CompactFold ZipList where-  compactFold (ZipList xs) = ZipList $ compactFold xs-  separateFold (ZipList xs) = bimap ZipList ZipList $ separateFold xs-instance CompactFold Option-instance CompactFold U1-instance CompactFold Proxy-instance (ArrowPlus a, ArrowApply a) => CompactFold (ArrowMonad a)-instance MonadPlus a => CompactFold (WrappedMonad a)-instance (Alternative a, Monad a) => CompactFold (Rec1 a)-instance (Alternative a, Monad a) => CompactFold (Alt a)-instance (Alternative f, Monad f, Alternative g, Monad g) => CompactFold (f :*: g)-instance (Compactable f, Alternative f, Monad f, Compactable g, Alternative g, Monad g) => CompactFold (FP.Product f g)-instance (Alternative f, Monad f) => CompactFold (M1 i c f)---fforMaybe :: (Compactable f, Functor f) => f a -> (a -> Maybe b) -> f b-fforMaybe = flip fmapMaybe---fforFold :: (CompactFold f, Functor f, Foldable g) => f a -> (a -> g b) -> f b-fforFold = flip fmapFold---fforEither :: (Compactable f, Functor f) => f a -> (a -> Either l r) -> (f l, f r)-fforEither = flip fmapEither---fforBifold :: (CompactFold f, Functor f, Bifoldable g) => f a -> (a -> g l r) -> (f l, f r)-fforBifold = flip fmapBifold---fmapMaybeM :: (Compactable f, Monad f) => (a -> MaybeT f b) -> f a -> f b-fmapMaybeM f = (>>= compact . runMaybeT . f)---fforMaybeM :: (Compactable f, Monad f) => f a -> (a -> MaybeT f b) -> f b-fforMaybeM = flip fmapMaybeM---fmapEitherM :: (Compactable f, Monad f) => (a -> ExceptT l f r) -> f a -> (f l, f r)-fmapEitherM f x = separate $ runExceptT . f =<< x---fforEitherM :: (Compactable f, Monad f) => f a -> (a -> ExceptT l f r) -> (f l, f r)-fforEitherM = flip fmapEitherM---applyMaybeM :: (Compactable f, Monad f) => f (a -> MaybeT f b) -> f a -> f b-applyMaybeM fa = compact . join . fmap runMaybeT . (fa <*>)---bindMaybeM :: (Compactable f, Monad f) => f a -> (a -> f (MaybeT f b)) -> f b-bindMaybeM x = compact . join . fmap runMaybeT . (x >>=)---traverseMaybeM :: (Monad m, Compactable t, Traversable t) => (a -> MaybeT m b) -> t a -> m (t b)-traverseMaybeM f = unwrapMonad . traverseMaybe (WrapMonad . runMaybeT . f)---- | While more constrained, when available, this default is going to be faster than the one provided in the typeclass-altDefaultCompact :: (Alternative f, Monad f) => f (Maybe a) -> f a-altDefaultCompact = (>>= maybe empty return)-{-# INLINABLE altDefaultCompact #-}---- | While more constrained, when available, this default is going to be faster than the one provided in the typeclass-altDefaultSeparate :: (Alternative f, Foldable f) => f (Either l r) -> (f l, f r)-altDefaultSeparate = foldl' (\(l', r') -> \case-  Left l  -> (l' <|> pure l ,r')-  Right r -> (l', r' <|> pure r)) (empty, empty)-{-# INLINABLE altDefaultSeparate #-}---hush :: Either l r -> Maybe r-hush = \case (Right x) -> Just x; _ -> Nothing---flipEither :: Either a b -> Either b a-flipEither = \case (Right x) -> Left x; (Left x) -> Right x

@@ -0,0 +1,438 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstrainedClassMethods    #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeOperators              #-}+++module Control.Functor.Compactable+  (+  -- * Compact+    Compactable (..)+  , separate+  -- * Handly flips+  , fforMaybe+  , fforThese+  -- * More general lefts and rights+  , mfold'+  , mlefts+  , mrights+  -- * Monad Transformer utils+  , mapMaybeM+  , mapTheseM+  , fforMaybeM+  , fforTheseM+  , applyMaybeM+  , bindMaybeM+  , traverseMaybeM+  -- * Alternative Defaults+  , altDefaultCompact+  , altDefaultSeparate++  ) where+++import           Control.Applicative         (Alternative (empty, (<|>)),+                                              Const (Const), WrappedMonad (..),+                                              ZipList (ZipList))+import           Control.Monad               (join, (<=<))+import           Control.Monad.Trans.Except  (ExceptT, runExceptT)+import           Control.Monad.Trans.Maybe   (MaybeT (runMaybeT))+import           Data.Bifunctor              (bimap)+import           Data.Foldable               as F (foldl', foldr')+import           Data.Functor.Compose        (Compose (Compose))+import           Data.Functor.Contravariant  (Contravariant (contramap))+import qualified Data.Functor.Product        as FP+import           Data.Kind                   (Type)+import qualified Data.List                   as List+import qualified Data.Map                    as Map+import qualified Data.Maybe                  as May+import           Data.Monoid                 (Alt (Alt))+import           Data.Proxy                  (Proxy (..))+import qualified Data.Sequence               as Seq+import qualified Data.Set                    as Set+import qualified Data.Vector                 as V+import           GHC.Conc                    (STM)+import           GHC.Generics                (M1 (M1), Rec1 (Rec1), U1 (U1),+                                              type (:*:) ((:*:)),+                                              type (:.:) (Comp1))++import           Data.These                  (These (..), these)++import           Control.Functor.Dichotomous (Dichotomous (dichotomy), hushLeft,+                                              hushRight, mfold', mlefts,+                                              mrights)+import qualified Data.IntMap                 as IntMap+#if __GLASGOW_HASKELL__ < 900+import           Data.Semigroup              (Option (Option))+#endif+++separateMap :: (Dichotomous g, Functor f, Compactable f) => (a -> g l r) -> f a -> (f l, f r)+separateMap f = separate . mapMaybe (dichotomy . f)+{-# INLINABLE separateMap #-}+++separate :: (Dichotomous g, Functor f, Compactable f) => f (g l r) -> (f l, f r)+separate = separateThese . mapMaybe dichotomy+{-# INLINABLE separate #-}+++-- | A generalization of catMaybes+--+-- prop> compact . map Just = id+-- prop> compact . mapMaybe id+-- prop> compact (pure Just <*> a) = a+-- prop> applyMaybe (pure Just) = id+-- prop> applyMaybe (pure id) = compact+-- prop> bindMaybe (return . Just) = id+-- prop> bindMaybe return = compact+-- prop> compact (return . Just =<< a) = a+-- prop> mapMaybe (l <=< r) = mapMaybe l . mapMaybe r+-- prop> compact (Nothing <$ a) = empty+-- prop> compact (Nothing <$ a) = mempty+-- prop> compact empty = empty+-- prop> compact mempty = mempty+-- prop> traverseMaybe (Just . Just) = Just+-- prop> traverseMaybe (map Just . f) = traverse f+class Compactable (f :: Type -> Type) where+  {-# MINIMAL compact | separateThese #-}++  compact :: f (Maybe a) -> f a+  default compact :: Functor f => f (Maybe a) -> f a+  compact = snd . separate . fmap (\case Just x -> That x; _ -> This ())+  {-# INLINABLE compact #-}++  separateThese :: f (These l r) -> (f l, f r)+  default separateThese :: Functor f => f (These l r) -> (f l, f r)+  separateThese xs = (compact $ hushRight <$> xs, compact $ hushLeft <$> xs)+  {-# INLINABLE separateThese #-}++  filter :: (a -> Bool) -> f a -> f a+  default filter :: Functor f => (a -> Bool) -> f a -> f a+  filter f = mapMaybe $ \a -> if f a then Just a else Nothing+  {-# INLINABLE filter #-}++  partition :: (a -> Bool) -> f a -> (f a, f a)+  default partition :: Functor f => (a -> Bool) -> f a -> (f a, f a)+  partition f = separateMap $ \a -> if f a then Right a else Left a+  {-# INLINEABLE partition #-}++  mapMaybe :: Functor f => (a -> Maybe b) -> f a -> f b+  mapMaybe f = compact . fmap f+  {-# INLINABLE mapMaybe #-}++  contramapMaybe :: Contravariant f => (Maybe b -> a) -> f a -> f b+  contramapMaybe f = compact . contramap f+  {-# INLINABLE contramapMaybe #-}++  mapThese :: Functor f => (a -> These l r) -> f a -> (f l, f r)+  mapThese f = separate . fmap f+  {-# INLINABLE mapThese #-}++  contramapThese :: Contravariant f => (These l r -> a) -> f a -> (f l, f r)+  contramapThese f = separateThese . contramap f+  {-# INLINEABLE contramapThese #-}++  applyMaybe :: Applicative f => f (a -> Maybe b) -> f a -> f b+  applyMaybe fa = compact . (fa <*>)+  {-# INLINABLE applyMaybe #-}++  applyThese :: Applicative f => f (a -> These l r) -> f a -> (f l, f r)+  applyThese fa = separate . (fa <*>)+  {-# INLINABLE applyThese #-}++  bindMaybe :: Monad f => (a -> f (Maybe b)) -> f a -> f b+  bindMaybe f x = compact $ x >>= f+  {-# INLINABLE bindMaybe #-}++  bindThese :: Monad f => (a -> f (These l r)) -> f a -> (f l, f r)+  bindThese f x = separate $ x >>= f+  {-# INLINABLE bindThese #-}++  traverseMaybe :: (Applicative g, Traversable f)+                => (a -> g (Maybe b)) -> f a -> g (f b)+  traverseMaybe f = fmap compact . traverse f+  {-# INLINABLE traverseMaybe #-}++  traverseThese :: (Applicative g, Traversable f)+                 => (a -> g (These l r)) -> f a -> g (f l, f r)+  traverseThese f = fmap separate . traverse f+  {-# INLINABLE traverseThese #-}+++instance Compactable Maybe where+    compact = join+    {-# INLINABLE compact #-}+    mapMaybe = (=<<)+    {-# INLINABLE mapMaybe #-}+    separateThese = \case+      Just x -> case x of+        This  l   -> (Just l, Nothing)+        That    r -> (Nothing, Just r)+        These l r -> (Just l, Just r)+      _ -> (Nothing, Nothing)+    {-# INLINABLE separateThese #-}+++instance Monoid m => Compactable (Either m) where+    compact (Right (Just x)) = Right x+    compact (Right _)        = Left mempty+    compact (Left x)         = Left x+    {-# INLINABLE compact #-}+    mapMaybe f (Right x) = maybe (Left mempty) Right (f x)+    mapMaybe _ (Left x)  = Left x+    {-# INLINABLE mapMaybe #-}+    separateThese = \case+      Right (This  l)   -> (Right l, Left mempty)+      Right (That    r) -> (Left mempty, Right r)+      Right (These l r) -> (Right l, Right r)+      Left x            -> (Left x, Left x)+    {-# INLINABLE separateThese #-}++instance Monoid m => Compactable (These m) where+  compact = \case+    This x           -> This x+    That (Just x)    -> That x+    That Nothing     -> This mempty+    These x (Just y) -> These x y+    These x Nothing  -> This x+  {-# INLINABLE compact #-}++instance Compactable [] where+    compact = May.catMaybes+    {-# INLINABLE compact #-}+    mapMaybe _ []    = []+    mapMaybe f (h:t) = maybe (mapMaybe f t) (: mapMaybe f t) (f h)+    {-# INLINABLE mapMaybe #-}+    filter = Prelude.filter+    {-# INLINABLE filter #-}+    partition = List.partition+    {-# INLINABLE partition #-}+    separateThese = foldr (these l_ r_ lr_) ([],[])+      where+      l_  a   ~(l, r) = (a:l,   r)+      r_    b ~(l, r) = (  l, b:r)+      lr_ a b ~(l, r) = (a:l, b:r)+    {-# INLINABLE separateThese #-}+    mapThese f = foldr' deal ([],[])+      where deal a ~(bs, cs) = case f a of+             This  b   -> (b:bs,   cs)+             That    c -> (  bs, c:cs)+             These b c -> (b:bs, c:cs)+    {-# INLINABLE mapThese #-}+    traverseMaybe f = go where+      go (x:xs) = maybe id (:) <$> f x <*> go xs+      go []     = pure []+    {-# INLINE traverseMaybe #-}++instance Compactable ZipList where+  compact (ZipList xs) = ZipList $ compact xs++instance Compactable IO where+    compact x = x >>= maybe (error "compact called on (x :: IO (Maybe _)) where x = return Nothing") return+    {-# NOINLINE compact #-}++instance Compactable STM where+    compact = altDefaultCompact+    {-# INLINABLE compact #-}++instance Compactable Proxy where+    compact _ = Proxy+    {-# INLINABLE compact #-}+    separateThese _ = (Proxy, Proxy)+    {-# INLINABLE separateThese #-}+    filter _ _ = Proxy+    {-# INLINABLE filter #-}+    partition _ _ = (Proxy, Proxy)+    {-# INLINABLE partition #-}+    mapMaybe _ _ = Proxy+    {-# INLINABLE mapMaybe #-}+    applyMaybe _ _ = Proxy+    {-# INLINABLE applyMaybe #-}+    bindMaybe _ _ = Proxy+    {-# INLINABLE bindMaybe #-}+    mapThese _ _ = (Proxy, Proxy)+    {-# INLINABLE mapThese #-}+    applyThese _ _ = (Proxy, Proxy)+    {-# INLINABLE applyThese #-}+    bindThese _ _ = (Proxy, Proxy)+    {-# INLINABLE bindThese #-}+++instance Compactable U1+  where compact U1 = U1+++#if __GLASGOW_HASKELL__ < 900+instance Compactable Option where+    compact (Option x) = Option (join x)+    {-# INLINABLE compact #-}+    mapMaybe f (Option (Just x)) = Option (f x)+    mapMaybe _ _                 = Option Nothing+    {-# INLINABLE mapMaybe #-}+    separateThese = altDefaultSeparate+    {-# INLINABLE separateThese #-}+#endif+++instance ( Functor f, Functor g, Compactable f, Compactable g )+         => Compactable (FP.Product f g) where+    compact (FP.Pair x y) = FP.Pair (compact x) (compact y)+    {-# INLINABLE compact #-}++instance (Functor f, Functor g, Compactable f, Compactable g)+         => Compactable (Compose f g) where+    compact (Compose fg) = Compose $ compact <$> fg+    {-# INLINABLE compact #-}+++instance Compactable IntMap.IntMap where+    compact = IntMap.mapMaybe id+    {-# INLINABLE compact #-}+    mapMaybe = IntMap.mapMaybe+    {-# INLINABLE mapMaybe #-}+    filter = IntMap.filter+    {-# INLINABLE filter #-}+    partition = IntMap.partition+    {-# INLINABLE partition #-}++instance Compactable (Map.Map k) where+    compact = Map.mapMaybe id+    {-# INLINABLE compact #-}+    mapMaybe = Map.mapMaybe+    {-# INLINABLE mapMaybe #-}+    filter = Map.filter+    {-# INLINABLE filter #-}+    partition = Map.partition+    {-# INLINABLE partition #-}++instance Compactable Seq.Seq where+    compact = fmap May.fromJust . Seq.filter May.isJust+    {-# INLINABLE compact #-}+    separateThese = altDefaultSeparate+    {-# INLINABLE separateThese #-}+    filter = Seq.filter+    {-# INLINABLE filter #-}+    partition = Seq.partition+    {-# INLINABLE partition #-}++instance Compactable V.Vector where+    compact = altDefaultCompact+    {-# INLINABLE compact #-}+    separateThese = altDefaultSeparate+    {-# INLINABLE separateThese #-}+    filter = V.filter+    {-# INLINABLE filter #-}+    partition = V.partition+    {-# INLINABLE partition #-}++instance Compactable (Const r) where+    compact (Const r) = Const r+    {-# INLINABLE compact #-}+    mapMaybe _ (Const r) = Const r+    {-# INLINABLE mapMaybe #-}+    applyMaybe _ (Const r) = Const r+    {-# INLINABLE applyMaybe #-}+    bindMaybe _ (Const r) = Const r+    {-# INLINABLE bindMaybe #-}+    mapThese _ (Const r) = (Const r, Const r)+    {-# INLINABLE mapThese #-}+    applyThese _ (Const r) = (Const r, Const r)+    {-# INLINABLE applyThese #-}+    bindThese _ (Const r) = (Const r, Const r)+    {-# INLINABLE bindThese #-}+    filter _ (Const r) = Const r+    {-# INLINABLE filter #-}+    partition _ (Const r) = (Const r, Const r)+    {-# INLINABLE partition #-}++instance Compactable Set.Set where+    compact = Set.fromDistinctAscList . compact . Set.toAscList+    {-# INLINABLE compact #-}+    separateThese = bimap Set.fromDistinctAscList Set.fromDistinctAscList . separate . Set.toAscList+    {-# INLINABLE separateThese #-}+    filter = Set.filter+    {-# INLINABLE filter #-}+    partition = Set.partition+    {-# INLINABLE partition #-}+++instance (Compactable a, Monad a) => Compactable (WrappedMonad a)+  where compact (WrapMonad x) = WrapMonad $ compact x++instance (Compactable a, Functor a) => Compactable (Rec1 a)+  where compact (Rec1 x) = Rec1 $ compact x++instance (Compactable a, Functor a) => Compactable (Alt a)+  where compact (Alt a) = Alt $ compact a++instance (Compactable a, Functor a, Compactable b, Functor b) => Compactable (a :*: b)+  where compact (a :*: b) = compact a :*: compact b++instance (Compactable f, Functor f) => Compactable (M1 i c f)+  where compact (M1 x) = M1 $ compact x++instance (Functor f, Compactable g, Functor g) => Compactable (f :.: g)+  where compact (Comp1 x) = Comp1 $ compact <$> x+++fforMaybe :: (Compactable f, Functor f) => f a -> (a -> Maybe b) -> f b+fforMaybe = flip mapMaybe+++fforThese :: (Compactable f, Functor f) => f a -> (a -> These l r) -> (f l, f r)+fforThese = flip mapThese+++mapMaybeM :: (Compactable f, Monad f) => (a -> MaybeT f b) -> f a -> f b+mapMaybeM f = (>>= compact . runMaybeT . f)+++fforMaybeM :: (Compactable f, Monad f) => f a -> (a -> MaybeT f b) -> f b+fforMaybeM = flip mapMaybeM+++mapTheseM :: (Compactable f, Monad f) => (a -> ExceptT l f r) -> f a -> (f l, f r)+mapTheseM f x = separate $ runExceptT . f =<< x+++fforTheseM :: (Compactable f, Monad f) => f a -> (a -> ExceptT l f r) -> (f l, f r)+fforTheseM = flip mapTheseM+++applyMaybeM :: (Compactable f, Monad f) => f (a -> MaybeT f b) -> f a -> f b+applyMaybeM fa = compact . runMaybeT <=< (fa <*>)+++bindMaybeM :: (Compactable f, Monad f) => f a -> (a -> f (MaybeT f b)) -> f b+bindMaybeM x = compact . runMaybeT <=< (x >>=)+++traverseMaybeM :: (Monad m, Compactable t, Traversable t) => (a -> MaybeT m b) -> t a -> m (t b)+traverseMaybeM f = unwrapMonad . traverseMaybe (WrapMonad . runMaybeT . f)+++-- | While more constrained, when available, this default is going to be faster than the one provided in the typeclass+altDefaultCompact :: (Alternative f, Monad f) => f (Maybe a) -> f a+altDefaultCompact = (>>= maybe empty return)+{-# INLINABLE altDefaultCompact #-}+++-- | While more constrained, when available, this default is going to be faster than the one provided in the typeclass+altDefaultSeparate :: (Dichotomous d, Alternative f, Foldable f) => f (d l r) -> (f l, f r)+altDefaultSeparate = foldl' (\(l', r') d -> case dichotomy d of+  Nothing          -> (l', r')+  Just (This l)    -> (l' <|> pure l ,r')+  Just (That r)    -> (l', r' <|> pure r)+  Just (These l r) -> (l' <|> pure l, r' <|> pure r)) (empty, empty)+{-# INLINABLE altDefaultSeparate #-}

@@ -0,0 +1,330 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstrainedClassMethods    #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeSynonymInstances       #-}+++module Control.Functor.Dichotomous+  (+  -- Dichotomy+    Dichotomous (..)+  , hushLeft, hushRight, swap+  -- AltSum+  , AltSum (..)+  , mfold', mlefts, mrights+  , flipThese+  -- All types+  , LeftOnly(..)+  , LeftOrBoth(..)+  , RightOnly(..)+  , RightOrBoth(..)+  , These(..)+  , None (..)+  , MaybeBoth(..)+  , MaybeRight(..)+  , MaybeRightOrBoth(..)+  , MaybeLeft(..)+  , MaybeLeftOrBoth(..)+  , MaybeEither(..)+  , TheseOrNot(..)+  ) where+++import           Control.Applicative (Alternative (empty, (<|>)))+import           Data.Bifoldable     (Bifoldable (bifoldMap))+import           Data.Kind           (Type)++import           Data.These          (These (..))+import           GHC.Generics        (Generic)+++{-| Dichotomous is about types that are injective to (Maybe (These a b))+   In other words a + b + (a * b) + 1. Therefore+         ab          (,)+     b               LeftOnly+     b   ab          LeftOrBoth+     a               RightOnly+     a   ab          RightOrBoth+     a b             Either+     a b ab          These+   1                 None+   1     ab          MaybeBoth+   1   b             MaybeRight+   1   b ab          MaybeRightOrBoth+   1 a               MaybeLeft+   1 a   ab          MaybeLeftOrBoth+   1 a b             MaybeEither+   1 a b ab          TheseOrNot+-}+++class Dichotomous (f :: Type -> Type -> Type) where+  dichotomy :: f a b -> Maybe (These a b)+  ymotohcid :: Maybe (These a b) -> Maybe (f a b)+++instance Dichotomous (,) where+  dichotomy (x,y) = Just $ These x y+  {-# INLINE dichotomy #-}+  ymotohcid = \case Just (These x y) -> Just (x, y); _ -> Nothing+  {-# INLINE ymotohcid #-}+++newtype LeftOnly a b = LeftOnly { unLeftOnly :: a }+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous LeftOnly where+  dichotomy (LeftOnly l) = Just (This l)+  {-# INLINE dichotomy #-}+  ymotohcid = \case+    Just (This l)    -> Just (LeftOnly l)+    Just (These l _) -> Just (LeftOnly l)+    _                -> Nothing+  {-# INLINE ymotohcid #-}+++data LeftOrBoth a b = Left' a | LBoth a b+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous LeftOrBoth where+  dichotomy (Left' l)   = Just (This l)+  dichotomy (LBoth l r) = Just (These l r)+  {-# INLINE dichotomy #-}+  ymotohcid = \case+    Just (This l)    -> Just (Left' l)+    Just (These l r) -> Just (LBoth l r)+    _                -> Nothing+  {-# INLINE ymotohcid #-}+++newtype RightOnly a b = RightOnly { unRightOnly :: b }+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous RightOnly where+  dichotomy (RightOnly r) = Just (That r)+  {-# INLINE dichotomy #-}+  ymotohcid = \case+    Just (That r)    -> Just (RightOnly r)+    Just (These _ r) -> Just (RightOnly r)+    _                -> Nothing+  {-# INLINE ymotohcid #-}+++data RightOrBoth a b = Right' b | RBoth a b+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous RightOrBoth where+  dichotomy (Right' r)  = Just (That r)+  dichotomy (RBoth l r) = Just (These l r)+  {-# INLINE dichotomy #-}+  ymotohcid = \case+    Just (That r)    -> Just (Right' r)+    Just (These l r) -> Just (RBoth l r)+    _                -> Nothing+  {-# INLINE ymotohcid #-}+++instance Dichotomous Either where+  dichotomy = Just . \case Left l -> This l; Right r -> That r+  {-# INLINABLE dichotomy #-}+  ymotohcid = \case Just (This l) -> Just (Left l)+                    Just (That r) -> Just (Right r)+                    _             -> Nothing+  {-# INLINEABLE ymotohcid #-}+++instance Dichotomous These where+  dichotomy = Just+  {-# INLINE dichotomy #-}+  ymotohcid = id+  {-# INLINE ymotohcid #-}+++data None a b = None+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous None where+  dichotomy _ = Nothing+  {-# INLINE dichotomy #-}+  ymotohcid _ = Just None+  {-# INLINE ymotohcid #-}+++newtype MaybeBoth a b = MaybeBoth { unMaybeOrBoth :: Maybe (a,b) }+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous MaybeBoth where+  dichotomy x = case unMaybeOrBoth x of+    Nothing    -> Nothing+    Just (a,b) -> Just (These a b)+  {-# INLINE dichotomy #-}+  ymotohcid = Just . MaybeBoth . \case+    Just (These a b) -> Just (a,b)+    _                -> Nothing+  {-# INLINE ymotohcid #-}+++data MaybeRight a b = MRNothing | MRight b+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous MaybeRight where+  dichotomy = \case+    MRNothing -> Nothing+    MRight b  -> Just (That b)+  {-# INLINE dichotomy #-}+  ymotohcid = Just . \case+    Just (That b)    -> MRight b+    Just (These _ b) -> MRight b+    _                -> MRNothing+  {-# INLINE ymotohcid #-}+++data MaybeRightOrBoth a b = MRBNothing | MRBRight b | MRBoth a b+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous MaybeRightOrBoth where+  dichotomy = \case+    MRBNothing -> Nothing+    MRBRight b -> Just (That b)+    MRBoth a b -> Just (These a b)+  {-# INLINE dichotomy #-}+  ymotohcid = Just . \case+    Just (That b)    -> MRBRight b+    Just (These a b) -> MRBoth a b+    _                -> MRBNothing+  {-# INLINE ymotohcid #-}+++data MaybeLeft a b = MLNothing | MLeft a+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous MaybeLeft where+  dichotomy = \case+    MLNothing -> Nothing+    MLeft b   -> Just (This b)+  {-# INLINE dichotomy #-}+  ymotohcid = Just . \case+    Just (This a)    -> MLeft a+    Just (These a _) -> MLeft a+    _                -> MLNothing+  {-# INLINE ymotohcid #-}+++data MaybeLeftOrBoth a b = MLBNothing | MLBLeft a | MLBoth a b+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous MaybeLeftOrBoth where+  dichotomy = \case+    MLBNothing -> Nothing+    MLBLeft a  -> Just (This a)+    MLBoth a b -> Just (These a b)+  {-# INLINE dichotomy #-}+  ymotohcid = Just . \case+    Just (This a)    -> MLBLeft a+    Just (These a b) -> MLBoth a b+    _                -> MLBNothing+  {-# INLINE ymotohcid #-}+++data MaybeEither a b = MENothing | MELeft a | MERight b+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous MaybeEither where+  dichotomy = \case+    MELeft a  -> Just (This a)+    MERight b -> Just (That b)+    _         -> Nothing+  {-# INLINE dichotomy #-}+  ymotohcid = Just . \case+    Just (This a) -> MELeft a+    Just (That a) -> MERight a+    _             -> MENothing+  {-# INLINE ymotohcid #-}+++data TheseOrNot a b = This' a | That' b | These' a b | Not+  deriving (Eq, Ord, Show, Read, Generic)+++instance Dichotomous TheseOrNot where+  dichotomy = \case+    This' a    -> Just (This a)+    That' b    -> Just (That b)+    These' a b -> Just (These a b)+    Not        -> Nothing+  {-# INLINE dichotomy #-}+  ymotohcid = Just . \case+    Nothing          -> Not+    Just (This a)    -> This' a+    Just (That a)    -> That' a+    Just (These a b) -> These' a b+  {-# INLINE ymotohcid #-}+++newtype AltSum f a = AltSum { unAltSum :: f a }+    deriving (Functor, Applicative, Alternative)+instance Alternative f => Semigroup (AltSum f a) where+    AltSum a <> AltSum b = AltSum (a <|> b)+instance Alternative f => Monoid (AltSum f a) where+    mempty = empty+    AltSum a `mappend` AltSum b = AltSum (a <|> b)+++mfold' :: (Foldable f, Alternative m) => f a -> m a+mfold' = unAltSum . foldMap (AltSum . pure)+++mlefts :: (Bifoldable f, Alternative m) => f a b -> m a+mlefts = unAltSum . bifoldMap (AltSum . pure) (const mempty)+++mrights :: (Bifoldable f, Alternative m) => f a b -> m b+mrights = unAltSum . bifoldMap (const mempty) (AltSum . pure)+++hushRight :: Dichotomous g => g l r -> Maybe l+hushRight d = case dichotomy d of+  Just (This x)    -> Just x+  Just (These x _) -> Just x+  _                -> Nothing+++hushLeft :: Dichotomous g => g l r -> Maybe r+hushLeft d = case dichotomy d of+  Just (That x)    -> Just x+  Just (These _ x) -> Just x+  _                -> Nothing+++flipThese :: These a b -> These b a+flipThese = \case This x -> That x; That x -> This x; These x y -> These y x+{-# INLINABLE flipThese #-}+++swap :: Dichotomous g => g a b -> Maybe (g b a)+swap g = ymotohcid $ case dichotomy g of+  Nothing          -> Nothing+  Just (This a)    -> Just (That a)+  Just (That b)    -> Just (This b)+  Just (These a b) -> Just (These b a)+{-# INLINABLE swap #-}

@@ -0,0 +1,20 @@+module Control.Functor.Elastic+  ( module Control.Functor.Expansive+  , module Control.Functor.Compactable+  , Elastic+  ) where+++import           Control.Functor.Compactable (Compactable)+import           Control.Functor.Expansive   (Expansive)+import           Data.IntMap                 (IntMap)+import           Data.Map                    (Map)+++class (Compactable f, Expansive f) => Elastic f+++instance Elastic Maybe+instance Elastic IntMap+instance Ord k => Elastic (Map k)+

@@ -0,0 +1,212 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstrainedClassMethods    #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}+++module Control.Functor.Expansive+  (+  -- * Expand+    Expansive (..)+  , uniteDichotomy+  ) where+++import           Control.Applicative               (ZipList (ZipList))+import           Control.Functor.Dichotomous       (Dichotomous (ymotohcid),+                                                    These (..))+import           Data.Foldable                     (toList)+import           Data.Functor.Contravariant        (Contravariant (contramap))+import           Data.Functor.Product              (Product (..))+import qualified Data.IntMap                       as IntMap+import           Data.Kind                         (Type)+import qualified Data.Map                          as Map+import           Data.Maybe                        (isJust)+import           Data.Proxy                        (Proxy (Proxy))+import           Data.Semigroup                    (Option (..))+import qualified Data.Sequence                     as Seq+import qualified Data.Sequence.Internal            as Seq+import qualified Data.Vector                       as V+import           Data.Vector.Fusion.Bundle.Monadic (Bundle (..))+import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle+import qualified Data.Vector.Fusion.Bundle.Size    as Bundle+import           Data.Vector.Fusion.Stream.Monadic (Step (..), Stream (..))+import           Data.Vector.Generic               (stream, unstream)+++uniteDichotomy+  :: (Functor f, Expansive f, Dichotomous g)+  => f l -> f r -> f (Maybe (g l r))+uniteDichotomy x y = ymotohcid . Just <$> unite x y+++-- | Partial inverse of Compactable+--+-- prop> expand (unite x y) = uniteDichotomy x y+-- prop> unite = emapThese id+-- prop> map Just = expand+-- prop> (\x -> unite x x) = map (\x -> These x x)+-- prop> emapThese f a b = map f (unite a b)+-- prop> unite (f <$> x) (g <$> y) = bimap f g <$> unite x y+-- prop> expand (unite x y) = swap <$> unite y x+-- prop> emapThese f a b = f <$> unite a b+-- prop> unite empty = map That+-- prop> flip unite empty = map This+-- prop> unite mempty = map That+-- prop> flip unite mempty = map This+class Expansive (f :: Type -> Type) where+  {-# MINIMAL unite | emapThese #-}++  expand :: f a -> f (Maybe a)+  default expand :: Functor f => f a -> f (Maybe a)+  expand = fmap Just+  {-# INLINABLE expand #-}++  unite :: f l -> f r -> f (These l r)+  unite = emapThese id+  {-# INLINABLE unite #-}++  unfilter :: (Bool -> a) -> f a -> f a+  unfilter f = emapMaybe $ f . isJust+  {-# INLINABLE unfilter #-}++  emapMaybe :: (Maybe b -> a) -> f b -> f a+  default emapMaybe :: Functor f => (Maybe b -> a) -> f b -> f a+  emapMaybe f = fmap f . expand+  {-# INLINABLE emapMaybe #-}++  econtramapMaybe :: Contravariant f => (a -> Maybe b) -> f b -> f a+  econtramapMaybe f = contramap f . expand+  {-# INLINABLE econtramapMaybe #-}++  emapThese :: (These l r -> a) -> f l -> f r -> f a+  default emapThese :: Functor f => (These l r -> a) -> f l -> f r -> f a+  emapThese f a b = f <$> unite a b+  {-# INLINABLE emapThese #-}++  econtramapThese :: Contravariant f => (a -> These l r) -> f l -> f r -> f a+  econtramapThese f l r = contramap f $ unite l r+  {-# INLINABLE econtramapThese #-}++  eapplyMaybe :: Applicative f => f (Maybe a -> b) -> f a -> f b+  eapplyMaybe fa = (fa <*>) . expand+  {-# INLINABLE eapplyMaybe #-}++  eapplyThese :: Applicative f => f (These l r -> a) -> f l -> f r -> f a+  eapplyThese fa = fmap (fa <*>) . unite+  {-# INLINABLE eapplyThese #-}++  ebindMaybe :: Applicative f => (f (Maybe b) -> a) -> f b -> f a+  ebindMaybe f x = pure . f $ expand x+  {-# INLINABLE ebindMaybe #-}++  ebindThese :: Applicative f => (f (These l r) -> a) -> f l -> f r -> f a+  ebindThese f x y = pure . f $ unite x y+  {-# INLINABLE ebindThese #-}+++instance Expansive Maybe where+  unite (Just x) (Just y) = Just $ These x y+  unite (Just x) _        = Just $ This x+  unite _ (Just y)        = Just $ That y+  unite _ _               = Nothing+  {-# INLINABLE unite #-}+++instance Expansive [] where+  unite xs []         = This <$> xs+  unite [] ys         = That <$> ys+  unite (x:xs) (y:ys) = These x y : unite xs ys+  {-# INLINABLE unite #-}+++instance Expansive ZipList where+  unite (ZipList xs) (ZipList ys) = ZipList $ unite xs ys+  {-# INLINABLE unite #-}+++instance Expansive Proxy where+  unite _ _ = Proxy+  {-# INLINABLE unite #-}+++instance Expansive Option where+  unite (Option a) (Option b) = Option $ unite a b+  {-# INLINABLE unite #-}+++-- instance (Applicative f, Applicative g) => Expansive (FP.Product f g) where+-- instance (Applicative f, Applicative g) => Expansive (Compose f g) where++instance Expansive Seq.Seq where+  unite xs (Seq.Seq Seq.EmptyT) = fmap This xs+  unite (Seq.Seq Seq.EmptyT) ys = fmap That ys+  unite xs ys                   = Seq.fromList $ unite (toList xs) (toList ys)+  {-# INLINABLE unite #-}+++instance Monad m => Expansive (Bundle m v) where+  emapThese f Bundle{sElems = sa, sSize = na} Bundle{sElems = sb, sSize = nb}+    = Bundle.fromStream (emapThese f sa sb) (Bundle.larger na nb)+  {-# INLINABLE emapThese #-}+++instance Monad m => Expansive (Stream m) where+  emapThese  f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing, False)+    where+    step (sa, sb, Nothing, False) = do+      r <- stepa sa+      return $ case r of+        Yield x sa' -> Skip (sa', sb, Just x,  False)+        Skip    sa' -> Skip (sa', sb, Nothing, False)+        Done        -> Skip (sa,  sb, Nothing, True)++    step (sa, sb, av, adone) = do+      r <- stepb sb+      return $ case r of+        Yield y sb' -> Yield (f $ maybe (That y) (`These` y) av)+                             (sa, sb', Nothing, adone)+        Skip sb'    -> Skip (sa, sb', av, adone)+        Done -> case (av, adone) of+          (Just x, False) -> Yield (f $ This x) (sa, sb, Nothing, adone)+          (_, True)       -> Done+          _               -> Skip (sa, sb, Nothing, False)+++instance Expansive V.Vector where+  emapThese = emapThese'+    where+    emapThese' :: (These a b -> c) -> V.Vector a -> V.Vector b -> V.Vector c+    emapThese' f x y = unstream $ emapThese f (stream x) (stream y)+  {-# INLINABLE emapThese #-}+++instance Expansive IntMap.IntMap where+  unite m n = IntMap.unionWith merge (IntMap.map This m) (IntMap.map That n)+    where merge (This a) (That b) = These a b+          merge _ _               = error "kimpossible"+  {-# INLINE unite #-}+++instance Ord k => Expansive (Map.Map k) where+  unite m n = Map.unionWith merge (Map.map This m) (Map.map That n)+    where merge (This a) (That b) = These a b+          merge _ _               = error "kimpossible"+  {-# INLINE unite #-}+++instance (Functor f, Functor g, Expansive f, Expansive g)+  => Expansive (Product f g) where+  unite (Pair a b) (Pair c d) = Pair (unite a c) (unite b d)+  {-# INLINE unite #-}

@@ -0,0 +1,185 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeApplications           #-}++module CompactableSpec where+++import           Control.Applicative             (Alternative (empty), Const,+                                                  WrappedMonad, ZipList)+import           Control.Arrow                   (ArrowMonad)+import           Control.Functor.Compactable     (Compactable (applyMaybe, bindMaybe, compact, mapMaybe, traverseMaybe))+import           Control.Monad                   ((<=<))+import           Data.Functor.Compose            (Compose)+import qualified Data.Functor.Product            as FP+import           Data.IntMap                     (IntMap)+import           Data.Map                        (Map)+import           Data.Monoid                     (Alt, Sum)+import           Data.Proxy                      (Proxy (..))+import           Data.Semigroup                  (Option (Option), Sum)+import           Data.Sequence                   (Seq)+import           Data.These                      ()+import qualified Data.Vector                     as Vector+import           GHC.Generics                    (Rec1)+import           Text.ParserCombinators.ReadPrec ()++import           Core                            (Case', limitSize)+import           Test.QuickCheck                 (Arbitrary (..),+                                                  Arbitrary1 (..),+                                                  Args (maxSize, maxSuccess),+                                                  Fun, Testable (property),+                                                  applyFun, arbitrary1,+                                                  quickCheckWith, shrink1,+                                                  stdArgs)+import           Test.Syd                        (SpecWith, describe, it,+                                                  modifyMaxSize, parallel)+++type Case g f = Case' Compactable g f+++sweetFunctor :: forall f. Case Functor f => SpecWith ()+sweetFunctor = describe "functor" $ do+  limitSize 50 . it "mapMaybe (l <=< r) a = mapMaybe l (mapMaybe r a)" . property $ \(a :: f Int) (l :: Fun Int (Maybe Int)) (r :: Fun Int (Maybe Int)) ->+    mapMaybe (applyFun l <=< applyFun r) a == mapMaybe (applyFun l) (mapMaybe (applyFun r) a)+  it "compact . map Just = id" . property $ \(a :: f Int) -> compact (Just <$> a) == a+  it "compact = mapMaybe id" . property $ \(a :: f (Maybe Int)) -> compact a == mapMaybe id a+++sweetApplicative :: forall f. Case Applicative f => SpecWith ()+sweetApplicative = describe "applicative" $ do+  it "compact (pure Just <*> a) = a" . property $ \(a :: f Int) -> compact (pure Just <*> a) == a+  it "applyMaybe (pure Just) = id" . property $ \(a :: f Int) -> applyMaybe (pure Just) a == a+  it "compact = applyMaybe (pure id)" . property $ \(a :: f (Maybe Int)) -> compact a == applyMaybe (pure id) a+++sweetMonad :: forall f. Case Monad f => SpecWith ()+sweetMonad = describe "monad" $ do+  it "bindMaybe (return . Just) = id" . property $ \(a :: f Int) -> bindMaybe (return . Just) a == a+  it "compact (return . Just =<< a) = a" . property $ \(a :: f Int) -> compact (return . Just =<< a) == a+  it "bindMaybe return = compact" . property $ \(a :: f (Maybe Int)) -> bindMaybe return a == compact a+++sweetAlternative :: forall f. Case Alternative f => SpecWith ()+sweetAlternative = describe "alternative" $ do+  it "compact empty = empty" $ compact (empty :: f (Maybe Int)) == empty+  it "compact (Nothing <$ a) = empty" . property $ \(a :: f Int) -> compact (Nothing <$ a) == (empty :: f Int)+++sweetMonoid :: forall f.+  ( Eq (f (Sum Int))+  , Arbitrary (f (Sum Int))+  , Show (f (Sum Int))+  , Compactable f+  , Functor f+  , Monoid (f (Sum Int))+  , Monoid (f (Maybe (Sum Int)))) => SpecWith ()+sweetMonoid = describe "monoid" $ do+  it "compact mempty = mempty" $ compact (mempty :: f (Maybe (Sum Int))) == mempty+  it "compact (Nothing <$ a) = mempty" . property $ \(a :: f (Sum Int)) -> compact (Nothing <$ a) == (mempty :: f (Sum Int))+++pure' :: a -> [a]+pure' = pure+++sweetTraversable :: forall f. (Case Traversable f) => SpecWith ()+sweetTraversable = describe  "traverse" $ do+  limitSize 50 . it "traverseMaybe (Just . Just) = Just" . property $ \(a :: f Int) -> traverseMaybe (Just . Just) a == Just a+  limitSize 4 . it "traverse f = traverseMaybe (map Just . f)" . property $ \(a :: f Int) (f' :: Fun Int [Int]) -> let f = applyFun f' in+    traverse f a == traverseMaybe (fmap Just . f) a+++valuePack :: forall f.+  ( Case Functor f+  , Case Applicative f+  , Case Monad f+  , Case Alternative f+  , Case Traversable f+  ) => SpecWith ()+valuePack = describe "pack" . parallel $ do+  sweetFunctor @f+  sweetApplicative @f+  sweetMonad @f+  sweetAlternative @f+  sweetTraversable @f+++spec :: SpecWith ()+spec = describe "Compactable" $ do+  describe "Maybe" $ do+    valuePack @Maybe+    sweetMonoid @Maybe++  describe "[]" $ do+     valuePack @[]+     sweetMonoid @[]++#if __GLASGOW_HASKELL__ < 900+  describe "Option" $ do+    valuePack @Option+    sweetMonoid @Option+#endif++  describe "ZipList" $ do+    sweetFunctor @ZipList+    sweetApplicative @ZipList+    sweetAlternative @ZipList+    sweetTraversable @ZipList++  describe "IntMap" $ do+    sweetFunctor @IntMap+-- THIS IS NOT LAWFUL, Due to a bug in IntMap+-- λ. traverse Just $ fromList [(-1,0),(0,0)]+-- Just (fromList [(0,0),(-1,0)])+-- λ. fromList [(0,0),(-1,0)]+-- fromList [(-1,0),(0,0)]+-- sweetTraversable @IntMap+    sweetMonoid @IntMap++  describe "Seq" $ do+    valuePack @Seq+    sweetMonoid @Seq++  describe "Vector" $ do+    valuePack @Vector.Vector+    sweetMonoid @Vector.Vector++  describe "Map" $ do+    sweetFunctor @(Map String)+    sweetTraversable @(Map Int)+    sweetMonoid @(Map String)++    sweetFunctor @(Map Int)+    sweetTraversable @(Map Int)+    sweetMonoid @(Map Int)++  describe "Proxy" $ do+    valuePack @Proxy+    sweetMonoid @Proxy++  describe "Const" $ do+    sweetFunctor @(Const ())+    sweetApplicative @(Const ())+    sweetMonoid @(Const ())++  describe "Alt" $ do+    valuePack @(Alt [])+    sweetMonoid @(Alt [])++  describe "WrappedMonad" $+    valuePack @(WrappedMonad [])++  describe "Rec1" $+    valuePack @(Rec1 [])++  describe "Product" $+    valuePack @(FP.Product [] Maybe)++  describe "Compose" $+    sweetFunctor @(Compose [] Maybe)

@@ -0,0 +1,143 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE UndecidableInstances       #-}+++module Core where+++import           Control.Applicative         (WrappedMonad (..))+import           Control.Functor.Dichotomous+import           Data.Proxy                  (Proxy (..))+import           Data.Semigroup              (Option (Option), Sum)+import           Data.These                  (These (..))+import qualified Data.Vector                 as Vector+import           Debug.Trace                 (trace)+import           GHC.Generics                (Rec1 (Rec1))+import           Test.QuickCheck             (CoArbitrary, choose)+import           Test.QuickCheck.Arbitrary   (Arbitrary (..), Arbitrary1 (..),+                                              arbitrary1, shrink1)+import           Test.QuickCheck.Function    (Function)+import           Test.QuickCheck.Gen         (elements)+import           Test.Syd                    (TestDefM, modifyMaxSize)+++type Case' w g f =+  ( Arbitrary (f Int)+  , Arbitrary (f String)+  , Show (f Int)+  , Show (f String)+  , Arbitrary (f (Maybe Int))+  , Arbitrary (f (These String Int))+  , Show (f (Maybe Int))+  , Show (f (These String Int))+  , Eq (f Int)+  , Eq (f (Maybe Int))+  , Eq (f (These Int Int))+  , Eq (f (These String Int))+  , Eq (f (These Int String))+  , Eq (f (Maybe (These Int Int)))+  , Eq (f (Maybe (TheseOrNot Int Int)))+  , w f+  , g f+  )+++limitSize :: Int -> TestDefM a b c -> TestDefM a b c+limitSize x = modifyMaxSize $ \y -> y * x `div` 100+++#if __GLASGOW_HASKELL__ < 900+deriving instance Arbitrary a => Arbitrary (Option a)+#endif+instance Arbitrary1 Vector.Vector where+  liftArbitrary = fmap Vector.fromList . liftArbitrary+  liftShrink shr = fmap Vector.fromList . liftShrink shr . Vector.toList+instance Arbitrary a => Arbitrary (Vector.Vector a) where+  arbitrary = arbitrary1+  shrink = shrink1+instance Arbitrary (Proxy a) where+  arbitrary = return Proxy++instance Arbitrary (a b) => Arbitrary (Rec1 a b) where+  arbitrary = Rec1 <$> arbitrary+++instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where+  arbitrary = do+    x <- arbitrary+    y <- arbitrary+    elements [This x, That y, These x y]+++deriving instance Show (m a) => Show (WrappedMonad m a)+deriving instance Eq (m a) => Eq (WrappedMonad m a)+deriving instance (Monad m, Foldable m, Foldable (WrappedMonad m), Traversable m) => Traversable (WrappedMonad m)+deriving instance Foldable (WrappedMonad [])+++instance Arbitrary (None a b) where+  arbitrary = pure None++instance (Arbitrary a, Arbitrary b) => Arbitrary (MaybeBoth a b) where+  arbitrary = MaybeBoth <$> arbitrary++instance Arbitrary a => Arbitrary (MaybeLeft a b) where+  arbitrary = do+    x <- arbitrary+    elements [ MLNothing, MLeft x ]++instance Arbitrary b => Arbitrary (MaybeRight a b) where+  arbitrary = do+    x <- arbitrary+    elements [ MRNothing, MRight x ]++instance (Arbitrary a, Arbitrary b) => Arbitrary (TheseOrNot a b) where+  arbitrary = do+    a <- arbitrary+    b <- arbitrary+    elements [ Not, This' a, That' b, These' a b ]++instance Arbitrary a => Arbitrary (LeftOnly a b) where+  arbitrary = LeftOnly <$> arbitrary++instance ( Arbitrary a, Arbitrary b ) => Arbitrary (LeftOrBoth a b) where+  arbitrary = do+    l <- arbitrary+    r <- arbitrary+    elements [Left' l, LBoth l r]++instance Arbitrary b => Arbitrary (RightOnly a b) where+  arbitrary = RightOnly <$> arbitrary++instance ( Arbitrary a, Arbitrary b ) => Arbitrary (RightOrBoth a b) where+  arbitrary = do+    l <- arbitrary+    r <- arbitrary+    elements [Right' r, RBoth l r]++instance ( Arbitrary a, Arbitrary b ) => Arbitrary (MaybeRightOrBoth a b) where+  arbitrary = do+    l <- arbitrary+    r <- arbitrary+    elements [MRBRight r, MRBoth l r, MRBNothing]++instance ( Arbitrary a, Arbitrary b ) => Arbitrary (MaybeLeftOrBoth a b) where+  arbitrary = do+    l <- arbitrary+    r <- arbitrary+    elements [MLBLeft l, MLBoth l r, MLBNothing]++instance ( Arbitrary a, Arbitrary b ) => Arbitrary (MaybeEither a b) where+  arbitrary = do+    l <- arbitrary+    r <- arbitrary+    elements [MELeft l, MERight r, MENothing]++instance Function (These Int Int)+instance CoArbitrary (These Int Int)

@@ -0,0 +1,49 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+++module DichotomousSpec where+++import           Control.Functor.Dichotomous (Dichotomous (..), LeftOnly,+                                              LeftOrBoth, MaybeBoth,+                                              MaybeEither, MaybeLeft,+                                              MaybeLeftOrBoth, MaybeRight,+                                              MaybeRightOrBoth, None, RightOnly,+                                              RightOrBoth, These, TheseOrNot)+import           Core                        ()+import           Data.These                  (These)+import           Test.QuickCheck             (Arbitrary, Testable (property))+import           Test.Syd                    (SpecWith, describe, it, parallel)+++sweetIsomorphism+  :: forall g+   . ( Eq (g Int String)+     , Show (g Int String)+     , Arbitrary (g Int String)+     , Dichotomous g+   ) => SpecWith ()+sweetIsomorphism = do+  it "ymotohcid . dichotomy = Just" . property $ \(g :: g Int String) -> ymotohcid (dichotomy g) == Just g+++spec :: SpecWith ()+spec = describe "Dichotomous" $ do+  describe "(,)" $ sweetIsomorphism @(,)+  describe "LeftOnly" $ sweetIsomorphism @LeftOnly+  describe "LeftOrBoth" $ sweetIsomorphism @LeftOrBoth+  describe "RightOnly" $ sweetIsomorphism @RightOnly+  describe "RightOrBoth" $ sweetIsomorphism @RightOrBoth+  describe "Either" $ sweetIsomorphism @Either+  describe "These" $ sweetIsomorphism @These+  describe "None" $ sweetIsomorphism @None+  describe "MaybeBoth" $ sweetIsomorphism @MaybeBoth+  describe "MaybeRight" $ sweetIsomorphism @MaybeRight+  describe "MaybeRightOrBoth" $ sweetIsomorphism @MaybeRightOrBoth+  describe "MaybeLeft" $ sweetIsomorphism @MaybeLeft+  describe "MaybeLeftOrBoth" $ sweetIsomorphism @MaybeLeftOrBoth+  describe "MaybeEither" $ sweetIsomorphism @MaybeEither+  describe "TheseOrNot" $ sweetIsomorphism @TheseOrNot+

@@ -0,0 +1,50 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+++module ElasticSpec where+++import           Control.Applicative         (ZipList)+import           Control.Functor.Compactable (Compactable (compact, mapThese),+                                              separate)+import           Control.Functor.Elastic     (Elastic)+import           Control.Functor.Expansive   (Expansive (emapThese, expand, unite))+import           Data.Functor.Product        (Product)+import           Data.IntMap                 (IntMap)+import           Data.Map                    (Map)+import           Data.Sequence               (Seq)+import           Data.These                  (These)+import           Data.Vector                 (Vector)++import           Core                        (Case')+import           Test.QuickCheck             (Testable (property), applyFun)+import           Test.Syd                    (SpecWith, describe, it, parallel)+++type Case f = (Case' Compactable Functor f, Elastic f)+++dual :: forall f. Case f => SpecWith ()+dual = describe "Elastic" $ do++  it "compact . expand = id" . property $+    \(x :: f Int) -> compact (expand x) == x++  it "separate . uncurry unite = id" . property $+    \(xy :: (f Int, f Int)) ->+    separate (uncurry unite xy) == xy++  it "uncurry (emapThese id) . mapThese id = id" . property $+    \(xs :: f (These String Int)) ->+    uncurry (emapThese id) (mapThese id xs) == xs+++spec :: SpecWith ()+spec = describe "Elastic" $ do+  describe "Maybe"      $ dual @Maybe+  describe "IntMap"     $ dual @IntMap+  describe "Map String" $ dual @(Map String)

@@ -0,0 +1,155 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+++module ExpansiveSpec where+++import           Control.Functor.Compactable (Compactable (..), separate)+import           Control.Functor.Dichotomous (Dichotomous (ymotohcid),+                                              These (..), TheseOrNot, swap)+import           Control.Functor.Expansive   (Expansive (..), unite,+                                              uniteDichotomy)++import           Control.Applicative         (Alternative (empty), ZipList)+import           Data.Bifunctor              (bimap)+import           Data.Functor.Product        (Product)+import           Data.IntMap                 (IntMap)+import           Data.Map                    (Map)+import           Data.Proxy                  (Proxy)+import           Data.Semigroup              (Option)+import           Data.Sequence               (Seq)+import           Data.Vector                 (Vector)++import           Core                        (Case', limitSize)+import           Test.QuickCheck             (Fun, Testable (property),+                                              applyFun)+import           Test.Syd                    (SpecWith, describe, it)+++type Case g f = Case' Expansive g f+++sweetAxiom :: forall f. Case Functor f => SpecWith ()+sweetAxiom = describe "Minimal" $ do++  it "expand (unite x y) = uniteDichotomy x y" . property  $ \(x :: f Int) (y :: f Int) ->+    expand (unite x y) == uniteDichotomy x y++  it "unite = emapThese id" . property $ \(x :: f Int) (y :: f Int) ->+    unite x y == emapThese id x y+++sweetFunctor :: forall f. Case Functor f => SpecWith ()+sweetFunctor = describe "Functor" $ do++  it "map Just = expand" . property $ \(x :: f Int) -> fmap Just x == expand x++  it "(\\x -> unite x x) = fmap (\\x -> These x x)" . property $ \(x :: f Int) ->+    unite x x == fmap (\y -> These y y) x++  it "emapThese f a b = map f (unite a b)" . property $+    \(f :: Fun (These Int Int) Int)+     (x :: f Int)+     (y :: f Int) ->+    emapThese (applyFun f) x y == fmap (applyFun f) (unite x y)++  limitSize 20 . it "unite (f <$> x) (g <$> y) = bimap f g <$> unite x y" . property $+    \(f' :: Fun Int String)+     (g' :: Fun String Int)+     (x  :: f Int)+     (y  :: f String) -> let f = applyFun f'; g = applyFun g' in+    unite (f <$> x) (g <$> y) == (bimap f g <$> unite x y)++  it "expand (unite x y) = swap <$> unite y x" . property $ \(x :: f Int) (y :: f Int) ->+    expand (unite x y) == (swap <$> unite y x)++  it "emapThese f a b = f <$> unite a b" . property $+    \(f :: Fun (These Int Int) Int)+     (x :: f Int)+     (y :: f Int) ->+    emapThese (applyFun f) x y == fmap (applyFun f) (unite x y)+++sweetAlternative :: forall f. Case Alternative f => SpecWith ()+sweetAlternative = describe "Alternative" $ do++  it "unite empty = map That" . property $ \(x :: f Int) ->+    unite (empty :: f Int) x == (That <$> x)++  it "unite x empty = map This x" . property $ \(x :: f Int) ->+    unite x (empty :: f Int) == (This <$> x)+++sweetMonoid :: forall f. (Case Functor f, Monoid (f Int)) => SpecWith ()+sweetMonoid = describe "Monoid" $ do++  it "unite mempty = map That" . property $ \(x :: f Int) ->+    unite (mempty :: f Int) x == (That <$> x)++  it "unite x mempty = map This x" . property $ \(x :: f Int) ->+    unite x (mempty :: f Int) == (This <$> x)+++spec :: SpecWith ()+spec = describe "Exapansive" $ do++  describe "Maybe" $ do+    sweetAxiom @Maybe+    sweetFunctor @Maybe+    sweetAlternative @Maybe++  describe "[]" $ do+    sweetAxiom @[]+    sweetFunctor @[]+    sweetAlternative @[]++  describe "ZipList" $ do+    sweetAxiom @ZipList+    sweetFunctor @ZipList+    sweetAlternative @ZipList++  describe "Proxy" $ do+    sweetAxiom @Proxy+    sweetFunctor @Proxy+    sweetAlternative @Proxy++#if __GLASGOW_HASKELL__ < 900+  describe "Option" $ do+    sweetAxiom @Option+    sweetFunctor @Option+    sweetAlternative @Option+#endif++  describe "Seq" $ do+    sweetAxiom @Seq+    sweetFunctor @Seq+    sweetAlternative @Seq++  describe "Vector" $ do+    sweetAxiom @Vector+    sweetFunctor @Vector+    sweetAlternative @Vector++  describe "IntMap" $ do+    sweetAxiom @IntMap+    sweetFunctor @IntMap+    sweetMonoid @IntMap++  describe "Map" $ do+    sweetAxiom @(Map Int)+    sweetFunctor @(Map Int)+    sweetMonoid @(Map Int)++    sweetAxiom @(Map String)+    sweetFunctor @(Map String)+    sweetMonoid @(Map String)++  describe "Product [] Maybe" $ do+    sweetAxiom @(Product [] Maybe)+    sweetFunctor @(Product [] Maybe)+    sweetAlternative @(Product [] Maybe)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}