these 0.8.1 → 1
raw patch · 19 files changed
+1090/−2633 lines, 19 filesdep −containersdep −data-default-classdep −keysdep ~QuickCheckdep ~aesondep ~basesetup-changed
Dependencies removed: containers, data-default-class, keys, lens, mtl, quickcheck-instances, tagged, tasty, tasty-quickcheck, these, vector, vector-instances
Dependency ranges changed: QuickCheck, aeson, base, base-compat, bifunctors, binary, hashable, semigroupoids, semigroups, transformers, transformers-compat, unordered-containers
Files
- CHANGELOG.md +16/−0
- Control/Monad/Chronicle.hs +0/−23
- Control/Monad/Chronicle/Class.hs +0/−225
- Control/Monad/Trans/Chronicle.hs +0/−213
- Data/Align.hs +0/−532
- Data/Align/Indexed.hs +0/−43
- Data/Align/Key.hs +0/−43
- Data/Functor/These.hs +0/−259
- Data/These.hs +0/−346
- Data/These/Combinators.hs +0/−247
- Data/These/Lens.hs +0/−73
- LICENSE +1/−1
- README.md +0/−68
- Setup.hs +0/−2
- src/Data/Functor/These.hs +281/−0
- src/Data/These.hs +446/−0
- src/Data/These/Combinators.hs +278/−0
- test/Tests.hs +0/−480
- these.cabal +68/−78
CHANGELOG.md view
@@ -1,3 +1,19 @@+# 1++This is major package reogranisation. Old `these` were split into++- `these` providing only `These` type and some combinators+- `these-lens` providing *lens* combinators+- `semialign` providing `Semialign`, `Align`, `Zip`, `Unalign` and `Unzip` classes+- `semialign-indexed` providing `SemialignWithIndex` (`izipWith` and `ialignWith` members).+- `monad-chronicle` providing `ChronicleT` and `MonadChronicle`++Also noticeable change is `unalign :: f (These a b) -> (f a, f b)`.+For the old `f (These a b) -> (f (Maybe a), f (Maybe b))` use `unzipWith (unalign . Just)`.++- Many instances are added.+- Since annotations are removed for all but `these` package.+ # 0.8.1 - Add `Semialign` `Tree`, `Tagged`, `(->) e`; `Align` `Compose` and `Proxy` instances
− Control/Monad/Chronicle.hs
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- | Module : Control.Monad.Trans.Chronicle------ The 'ChronicleT' monad, a hybrid error/writer monad that allows--- both accumulating outputs and aborting computation with a final--- output.-------------------------------------------------------------------------------module Control.Monad.Chronicle ( - -- * Type class for Chronicle-style monads- MonadChronicle(..)- -- * The ChronicleT monad transformer- , Chronicle, runChronicle, ChronicleT(..)- , module Data.Monoid- , module Control.Monad- , module Control.Monad.Trans- ) where--import Data.Monoid (Monoid(..))--import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Chronicle (Chronicle)-import Control.Monad.Chronicle.Class
− Control/Monad/Chronicle/Class.hs
@@ -1,225 +0,0 @@-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- for the ErrorT instances-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}--------------------------------------------------------------------------------- | Module : Control.Monad.Chronicle.Class------ Hybrid error/writer monad class that allows both accumulating outputs and --- aborting computation with a final output.------ The expected use case is for computations with a notion of fatal vs. --- non-fatal errors.----------------------------------------------------------------------------------module Control.Monad.Chronicle.Class (- MonadChronicle(..),- ChronicleT(..), runChronicle- ) where--import Data.These-import Data.These.Combinators-import Control.Applicative-import Control.Monad.Trans.Chronicle (ChronicleT, runChronicle)-import qualified Control.Monad.Trans.Chronicle as Ch--import Control.Monad.Trans.Identity as Identity-import Control.Monad.Trans.Maybe as Maybe-import Control.Monad.Trans.Error as Error-import Control.Monad.Trans.Except as Except-import Control.Monad.Trans.Reader as Reader-import Control.Monad.Trans.RWS.Lazy as LazyRWS-import Control.Monad.Trans.RWS.Strict as StrictRWS-import Control.Monad.Trans.State.Lazy as LazyState-import Control.Monad.Trans.State.Strict as StrictState-import Control.Monad.Trans.Writer.Lazy as LazyWriter-import Control.Monad.Trans.Writer.Strict as StrictWriter--import Control.Monad.Trans.Class (lift)-import Control.Monad (liftM)-import Data.Default.Class-import Data.Semigroup-import Prelude -- Fix redundant import warnings---class (Monad m) => MonadChronicle c m | m -> c where- -- | @'dictate' c@ is an action that records the output @c@.- -- - -- Equivalent to 'tell' for the 'Writer' monad.- dictate :: c -> m ()- - -- | @'disclose' c@ is an action that records the output @c@ and returns a- -- @'Default'@ value.- --- -- This is a convenience function for reporting non-fatal errors in one- -- branch a @case@, or similar scenarios when there is no meaningful - -- result but a placeholder of sorts is needed in order to continue.- disclose :: (Default a) => c -> m a- disclose c = dictate c >> return def-- -- | @'confess' c@ is an action that ends with a final record @c@.- -- - -- Equivalent to 'throwError' for the 'Error' monad.- confess :: c -> m a- - -- | @'memento' m@ is an action that executes the action @m@, returning either- -- its record if it ended with 'confess', or its final value otherwise, with- -- any record added to the current record.- --- -- Similar to 'catchError' in the 'Error' monad, but with a notion of - -- non-fatal errors (which are accumulated) vs. fatal errors (which are caught- -- without accumulating).- memento :: m a -> m (Either c a)-- -- | @'absolve' x m@ is an action that executes the action @m@ and discards any- -- record it had. The default value @x@ will be used if @m@ ended via - -- 'confess'.- absolve :: a -> m a -> m a-- -- | @'condemn' m@ is an action that executes the action @m@ and keeps its value- -- only if it had no record. Otherwise, the value (if any) will be discarded- -- and only the record kept.- --- -- This can be seen as converting non-fatal errors into fatal ones.- condemn :: m a -> m a-- -- | @'retcon' f m@ is an action that executes the action @m@ and applies the- -- function @f@ to its output, leaving the return value unchanged.- -- - -- Equivalent to 'censor' for the 'Writer' monad.- retcon :: (c -> c) -> m a -> m a- - -- | @'chronicle' m@ lifts a plain 'These c a' value into a 'MonadChronicle' instance.- chronicle :: These c a -> m a---instance (Semigroup c) => MonadChronicle c (These c) where- dictate c = These c ()- confess c = This c- memento (This c) = That (Left c)- memento m = mapThere Right m- absolve x (This _) = That x- absolve _ (That x) = That x- absolve _ (These _ x) = That x- condemn (These c _) = This c- condemn m = m- retcon = mapHere- chronicle = id--instance (Semigroup c, Monad m) => MonadChronicle c (ChronicleT c m) where- dictate = Ch.dictate- confess = Ch.confess- memento = Ch.memento- absolve = Ch.absolve- condemn = Ch.condemn- retcon = Ch.retcon- chronicle = Ch.ChronicleT . return--instance (MonadChronicle c m) => MonadChronicle c (IdentityT m) where- dictate = lift . dictate- confess = lift . confess- memento (IdentityT m) = lift $ memento m- absolve x (IdentityT m) = lift $ absolve x m- condemn (IdentityT m) = lift $ condemn m- retcon f (IdentityT m) = lift $ retcon f m- chronicle = lift . chronicle--instance (MonadChronicle c m) => MonadChronicle c (MaybeT m) where- dictate = lift . dictate- confess = lift . confess- memento (MaybeT m) = MaybeT $ either (Just . Left) (Right <$>) `liftM` memento m- absolve x (MaybeT m) = MaybeT $ absolve (Just x) m- condemn (MaybeT m) = MaybeT $ condemn m- retcon f (MaybeT m) = MaybeT $ retcon f m- chronicle = lift . chronicle--instance (Error e, MonadChronicle c m) => MonadChronicle c (ErrorT e m) where- dictate = lift . dictate- confess = lift . confess- memento (ErrorT m) = ErrorT $ either (Right . Left) (Right <$>) `liftM` memento m- absolve x (ErrorT m) = ErrorT $ absolve (Right x) m- condemn (ErrorT m) = ErrorT $ condemn m- retcon f (ErrorT m) = ErrorT $ retcon f m- chronicle = lift . chronicle--instance (MonadChronicle c m) => MonadChronicle c (ExceptT e m) where- dictate = lift . dictate- confess = lift . confess- memento (ExceptT m) = ExceptT $ either (Right . Left) (Right <$>) `liftM` memento m- absolve x (ExceptT m) = ExceptT $ absolve (Right x) m- condemn (ExceptT m) = ExceptT $ condemn m- retcon f (ExceptT m) = ExceptT $ retcon f m- chronicle = lift . chronicle--instance (MonadChronicle c m) => MonadChronicle c (ReaderT r m) where- dictate = lift . dictate- confess = lift . confess- memento (ReaderT m) = ReaderT $ memento . m- absolve x (ReaderT m) = ReaderT $ absolve x . m- condemn (ReaderT m) = ReaderT $ condemn . m- retcon f (ReaderT m) = ReaderT $ retcon f . m- chronicle = lift . chronicle--instance (MonadChronicle c m) => MonadChronicle c (LazyState.StateT s m) where- dictate = lift . dictate- confess = lift . confess- memento (LazyState.StateT m) = LazyState.StateT $ \s -> do- either (\c -> (Left c, s)) (\(a, s') -> (Right a, s')) `liftM` memento (m s)- absolve x (LazyState.StateT m) = LazyState.StateT $ \s -> absolve (x, s) $ m s- condemn (LazyState.StateT m) = LazyState.StateT $ condemn . m- retcon f (LazyState.StateT m) = LazyState.StateT $ retcon f . m- chronicle = lift . chronicle--instance (MonadChronicle c m) => MonadChronicle c (StrictState.StateT s m) where- dictate = lift . dictate- confess = lift . confess- memento (StrictState.StateT m) = StrictState.StateT $ \s -> do- either (\c -> (Left c, s)) (\(a, s') -> (Right a, s')) `liftM` memento (m s)- absolve x (StrictState.StateT m) = StrictState.StateT $ \s -> absolve (x, s) $ m s- condemn (StrictState.StateT m) = StrictState.StateT $ condemn . m- retcon f (StrictState.StateT m) = StrictState.StateT $ retcon f . m- chronicle = lift . chronicle--instance (Monoid w, MonadChronicle c m) => MonadChronicle c (LazyWriter.WriterT w m) where- dictate = lift . dictate- confess = lift . confess- memento (LazyWriter.WriterT m) = LazyWriter.WriterT $ - either (\c -> (Left c, mempty)) (\(a, w) -> (Right a, w)) `liftM` memento m- absolve x (LazyWriter.WriterT m) = LazyWriter.WriterT $ absolve (x, mempty) m- condemn (LazyWriter.WriterT m) = LazyWriter.WriterT $ condemn m- retcon f (LazyWriter.WriterT m) = LazyWriter.WriterT $ retcon f m- chronicle = lift . chronicle--instance (Monoid w, MonadChronicle c m) => MonadChronicle c (StrictWriter.WriterT w m) where- dictate = lift . dictate- confess = lift . confess- memento (StrictWriter.WriterT m) = StrictWriter.WriterT $ - either (\c -> (Left c, mempty)) (\(a, w) -> (Right a, w)) `liftM` memento m- absolve x (StrictWriter.WriterT m) = StrictWriter.WriterT $ absolve (x, mempty) m- condemn (StrictWriter.WriterT m) = StrictWriter.WriterT $ condemn m- retcon f (StrictWriter.WriterT m) = StrictWriter.WriterT $ retcon f m- chronicle = lift . chronicle--instance (Monoid w, MonadChronicle c m) => MonadChronicle c (LazyRWS.RWST r w s m) where- dictate = lift . dictate- confess = lift . confess- memento (LazyRWS.RWST m) = LazyRWS.RWST $ \r s ->- either (\c -> (Left c, s, mempty)) (\(a, s', w) -> (Right a, s', w)) `liftM` memento (m r s)- absolve x (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> absolve (x, s, mempty) $ m r s- condemn (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> condemn $ m r s- retcon f (LazyRWS.RWST m) = LazyRWS.RWST $ \r s -> retcon f $ m r s- chronicle = lift . chronicle--instance (Monoid w, MonadChronicle c m) => MonadChronicle c (StrictRWS.RWST r w s m) where- dictate = lift . dictate- confess = lift . confess- memento (StrictRWS.RWST m) = StrictRWS.RWST $ \r s ->- either (\c -> (Left c, s, mempty)) (\(a, s', w) -> (Right a, s', w)) `liftM` memento (m r s)- absolve x (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> absolve (x, s, mempty) $ m r s- condemn (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> condemn $ m r s- retcon f (StrictRWS.RWST m) = StrictRWS.RWST $ \r s -> retcon f $ m r s- chronicle = lift . chronicle---
− Control/Monad/Trans/Chronicle.hs
@@ -1,213 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--------------------------------------------------------------------------------- | Module : Control.Monad.Chronicle------ Hybrid error/writer monad class that allows both accumulating outputs and --- aborting computation with a final output.------ The expected use case is for computations with a notion of fatal vs. --- non-fatal errors.--------------------------------------------------------------------------------module Control.Monad.Trans.Chronicle ( - -- * The Chronicle monad- Chronicle, chronicle, runChronicle- -- * The ChronicleT monad transformer- , ChronicleT(..)- -- * Chronicle operations- , dictate, disclose, confess- , memento, absolve, condemn- , retcon- ) where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Trans-import Data.Default.Class-import Data.Functor.Apply (Apply(..))-import Data.Functor.Bind (Bind(..))-import Data.Functor.Identity-import Data.Semigroup--import Control.Monad.Error.Class-import Control.Monad.Reader.Class-import Control.Monad.RWS.Class-import Prelude-import Data.These-import Data.These.Combinators (mapHere)---- ----------------------------------------------------------------------------- | A chronicle monad parameterized by the output type @c@.------ The 'return' function produces a computation with no output, and '>>='--- combines multiple outputs with 'mappend'.-type Chronicle c = ChronicleT c Identity--chronicle :: These c a -> Chronicle c a-chronicle = ChronicleT . Identity--runChronicle :: Chronicle c a -> These c a-runChronicle = runIdentity . runChronicleT---- ----------------------------------------------------------------------------- | The `ChronicleT` monad transformer.------ The 'return' function produces a computation with no output, and '>>='--- combines multiple outputs with 'mappend'.-newtype ChronicleT c m a = ChronicleT { runChronicleT :: m (These c a) }--instance (Functor m) => Functor (ChronicleT c m) where- fmap f (ChronicleT c) = ChronicleT (fmap f <$> c)--instance (Semigroup c, Apply m) => Apply (ChronicleT c m) where- ChronicleT f <.> ChronicleT x = ChronicleT ((<.>) <$> f <.> x)--instance (Semigroup c, Applicative m) => Applicative (ChronicleT c m) where- pure = ChronicleT . pure . pure- ChronicleT f <*> ChronicleT x = ChronicleT (liftA2 (<*>) f x)--instance (Semigroup c, Apply m, Monad m) => Bind (ChronicleT c m) where- (>>-) = (>>=)--instance (Semigroup c, Monad m) => Monad (ChronicleT c m) where- return = ChronicleT . return . return- m >>= k = ChronicleT $ - do cx <- runChronicleT m- case cx of - This a -> return (This a)- That x -> runChronicleT (k x)- These a x -> do cy <- runChronicleT (k x)- return $ case cy of- This b -> This (a <> b)- That y -> These a y- These b y -> These (a <> b) y--instance (Semigroup c) => MonadTrans (ChronicleT c) where- lift m = ChronicleT (That `liftM` m)--instance (Semigroup c, MonadIO m) => MonadIO (ChronicleT c m) where- liftIO = lift . liftIO---instance (Semigroup c, Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where- empty = mzero- (<|>) = mplus--instance (Semigroup c, Monoid c, Monad m) => MonadPlus (ChronicleT c m) where- mzero = confess mempty- mplus x y = do x' <- memento x- case x' of- Left _ -> y- Right r -> return r---instance (Semigroup c, MonadError e m) => MonadError e (ChronicleT c m) where- throwError = lift . throwError- catchError (ChronicleT m) c = ChronicleT $ catchError m (runChronicleT . c)---instance (Semigroup c, MonadReader r m) => MonadReader r (ChronicleT c m) where- ask = lift ask- local f (ChronicleT m) = ChronicleT $ local f m- reader = lift . reader--instance (Semigroup c, MonadRWS r w s m) => MonadRWS r w s (ChronicleT c m) where--instance (Semigroup c, MonadState s m) => MonadState s (ChronicleT c m) where- get = lift get- put = lift . put- state = lift . state--instance (Semigroup c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where- tell = lift . tell- listen (ChronicleT m) = ChronicleT $ do- (m', w) <- listen m- return $ case m' of- This c -> This c- That x -> That (x, w)- These c x -> These c (x, w)- pass (ChronicleT m) = ChronicleT $ do- pass $ these (\c -> (This c, id)) - (\(x, f) -> (That x, f)) - (\c (x, f) -> (These c x, f)) `liftM` m- writer = lift . writer---- this is basically copied from the instance for Either in transformers--- need to test this to make sure it's actually sensible...?-instance (Semigroup c, MonadFix m) => MonadFix (ChronicleT c m) where- mfix f = ChronicleT (mfix (runChronicleT . f . these (const bomb) id (flip const)))- where bomb = error "mfix (ChronicleT): inner compuation returned This value"----- | @'dictate' c@ is an action that records the output @c@.--- --- Equivalent to 'tell' for the 'Writer' monad.-dictate :: (Semigroup c, Monad m) => c -> ChronicleT c m ()-dictate c = ChronicleT $ return (These c ())---- | @'disclose' c@ is an action that records the output @c@ and returns a--- @'Default'@ value.------ This is a convenience function for reporting non-fatal errors in one--- branch a @case@, or similar scenarios when there is no meaningful --- result but a placeholder of sorts is needed in order to continue.-disclose :: (Default a, Semigroup c, Monad m) => c -> ChronicleT c m a-disclose c = dictate c >> return def---- | @'confess' c@ is an action that ends with a final output @c@.--- --- Equivalent to 'throwError' for the 'Error' monad.-confess :: (Semigroup c, Monad m) => c -> ChronicleT c m a-confess c = ChronicleT $ return (This c)---- | @'memento' m@ is an action that executes the action @m@, returning either--- its record if it ended with 'confess', or its final value otherwise, with--- any record added to the current record.------ Similar to 'catchError' in the 'Error' monad, but with a notion of --- non-fatal errors (which are accumulated) vs. fatal errors (which are caught--- without accumulating).-memento :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m (Either c a)-memento m = ChronicleT $ - do cx <- runChronicleT m- return $ case cx of- This a -> That (Left a)- That x -> That (Right x)- These a x -> These a (Right x)---- | @'absolve' x m@ is an action that executes the action @m@ and discards any--- record it had. The default value @x@ will be used if @m@ ended via --- 'confess'.-absolve :: (Semigroup c, Monad m) => a -> ChronicleT c m a -> ChronicleT c m a-absolve x m = ChronicleT $ - do cy <- runChronicleT m- return $ case cy of- This _ -> That x- That y -> That y- These _ y -> That y----- | @'condemn' m@ is an action that executes the action @m@ and keeps its value--- only if it had no record. Otherwise, the value (if any) will be discarded--- and only the record kept.------ This can be seen as converting non-fatal errors into fatal ones.-condemn :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m a-condemn (ChronicleT m) = ChronicleT $ do - m' <- m- return $ case m' of- This x -> This x- That y -> That y- These x _ -> This x----- | @'retcon' f m@ is an action that executes the action @m@ and applies the--- function @f@ to its output, leaving the return value unchanged.--- --- Equivalent to 'censor' for the 'Writer' monad.-retcon :: (Semigroup c, Monad m) => (c -> c) -> ChronicleT c m a -> ChronicleT c m a-retcon f m = ChronicleT $ mapHere f `liftM` runChronicleT m-
− Data/Align.hs
@@ -1,532 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- | Module : Data.Align------ 'These'-based zipping and unzipping of functors with non-uniform--- shapes, plus traversal of (bi)foldable (bi)functors through said--- functors.-module Data.Align (- Semialign (..)- , Align(..)- -- * Specialized aligns- , malign, salign, padZip, padZipWith- , lpadZip, lpadZipWith- , rpadZip, rpadZipWith- , alignVectorWith-- -- * Unalign- , Unalign(..)-- -- * Crosswalk- , Crosswalk(..)-- -- * Bicrosswalk- , Bicrosswalk(..)- ) where---- TODO: More instances..--import Prelude ()-import Prelude.Compat--import Control.Applicative (ZipList (..))-import Data.Bifoldable (Bifoldable (..))-import Data.Bifunctor (Bifunctor (..))-import Data.Functor.Compose (Compose (..))-import Data.Functor.Identity (Identity (..))-import Data.Functor.Product (Product (..))-import Data.Hashable (Hashable (..))-import Data.HashMap.Strict (HashMap)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (catMaybes)-import Data.Proxy (Proxy (..))-import Data.Semigroup (Semigroup (..))-import Data.Sequence (Seq)-import Data.Tagged (Tagged (..))-import Data.Vector.Fusion.Stream.Monadic (Step (..), Stream (..))-import Data.Vector.Generic (Vector, empty, stream, unstream)--import qualified Data.HashMap.Strict as HashMap-import qualified Data.Sequence as Seq-import qualified Data.Tree as T-import qualified Data.Vector as V-import qualified Data.Vector.Fusion.Stream.Monadic as Stream-import qualified Data.Vector.Generic as VG (foldr, fromList)--#if MIN_VERSION_vector(0,11,0)-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-#else-import qualified Data.Vector.Fusion.Stream.Size as Stream-#endif--#if MIN_VERSION_containers(0,5,0)-import Data.Map.Lazy (Map)-import qualified Data.Map.Lazy as Map--import Data.IntMap.Lazy (IntMap)-import qualified Data.IntMap.Lazy as IntMap--#if MIN_VERSION_containers(0,5,9)-import qualified Data.IntMap.Merge.Lazy as IntMap-import qualified Data.Map.Merge.Lazy as Map-#endif---- containers <0.5-#else-import Data.Map (Map)-import qualified Data.Map as Map--import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-#endif--import Data.These--oops :: String -> a-oops = error . ("Data.Align: internal error: " ++)---- ----------------------------------------------------------------------------- | Functors supporting a zip operation that takes the union of--- non-uniform shapes.------ If your functor is actually a functor from @Kleisli Maybe@ to--- @Hask@ (so it supports @maybeMap :: (a -> Maybe b) -> f a -> f--- b@), then an @Align@ instance is making your functor lax monoidal--- w.r.t. the cartesian monoidal structure on @Kleisli Maybe@,--- because @These@ is the cartesian product in that category @(a ->--- Maybe (These b c) ~ (a -> Maybe b, a -> Maybe c))@. This insight--- is due to rwbarton.------ Minimal definition: either @align@ or @alignWith@.------ == Laws:------ @--- join align = fmap (join These)--- align (f \<$> x) (g \<$> y) = bimap f g \<$> align x y--- alignWith f a b = f \<$> align a b--- align x (align y z) = fmap assoc (align (align x y) z)--- @------ /Note:/ @'join' f x = f x x@------ And an addition property if @f@ is 'Foldable',--- which tries to enforce 'align'-feel:--- neither values are duplicated nor lost.------ @--- toList x = toListOf (folded . here) (align x y)--- = mapMaybe justHere (toList (align x y))--- @----class Functor f => Semialign f where- -- | Analogous to @'zip'@, combines two structures by taking the union of- -- their shapes and using @'These'@ to hold the elements.- align :: f a -> f b -> f (These a b)- align = alignWith id-- -- | Analogous to @'zipWith'@, combines two structures by taking the union of- -- their shapes and combining the elements with the given function.- alignWith :: (These a b -> c) -> f a -> f b -> f c- alignWith f a b = f <$> align a b--#if __GLASGOW_HASKELL__ >= 707- {-# MINIMAL align | alignWith #-}-#endif---- | A unit of 'align'.------ == Laws:------ @--- (\`align` nil) = fmap This--- (nil \`align`) = fmap That--- @----class Semialign f => Align f where- -- | An empty structure. @'align'@ing with @'nil'@ will produce a structure with- -- the same shape and elements as the other input, modulo @'This'@ or @'That'@.- nil :: f a--{-# RULES--"align nil nil" align nil nil = nil-"align x x" forall x. align x x = fmap (\y -> These y y) x--"alignWith f nil nil" forall f. alignWith f nil nil = nil-"alignWith f x x" forall f x. alignWith f x x = fmap (\y -> f (These y y)) x-- #-}------------------------------------------------------------------------------------ Instances------------------------------------------------------------------------------------ | @since 0.8.1-instance Semialign ((->) e) where- align f g x = These (f x) (g x)- alignWith h f g x = h (These (f x) (g x))--instance Align Maybe where- nil = Nothing--instance Semialign Maybe where- align Nothing Nothing = Nothing- align (Just a) Nothing = Just (This a)- align Nothing (Just b) = Just (That b)- align (Just a) (Just b) = Just (These a b)--instance Align [] where- nil = []--instance Semialign [] where- align xs [] = This <$> xs- align [] ys = That <$> ys- align (x:xs) (y:ys) = These x y : align xs ys---- @since 0.8-instance Semialign NonEmpty where- align (x :| xs) (y :| ys) = These x y :| align xs ys--instance Align ZipList where- nil = ZipList []--instance Semialign ZipList where- alignWith f (ZipList xs) (ZipList ys) = ZipList (alignWith f xs ys)--instance Align Seq where- nil = Seq.empty--instance Semialign Seq where- align xs ys = case compare xn yn of- EQ -> Seq.zipWith fc xs ys- LT -> case Seq.splitAt xn ys of- (ysl, ysr) -> Seq.zipWith These xs ysl `mappend` fmap That ysr- GT -> case Seq.splitAt yn xs of- (xsl, xsr) -> Seq.zipWith These xsl ys `mappend` fmap This xsr- where- xn = Seq.length xs- yn = Seq.length ys- fc = These-- alignWith f xs ys = case compare xn yn of- EQ -> Seq.zipWith fc xs ys- LT -> case Seq.splitAt xn ys of- (ysl, ysr) -> Seq.zipWith fc xs ysl `mappend` fmap (f . That) ysr- GT -> case Seq.splitAt yn xs of- (xsl, xsr) -> Seq.zipWith fc xsl ys `mappend` fmap (f . This) xsr- where- xn = Seq.length xs- yn = Seq.length ys- fc x y = f (These x y)---- | @since 0.8.1-instance Semialign T.Tree where- align (T.Node x xs) (T.Node y ys) = T.Node (These x y) (alignWith (these (fmap This) (fmap That) align) xs ys)--instance (Ord k) => Align (Map k) where- nil = Map.empty--instance (Ord k) => Semialign (Map k) where-#if MIN_VERSION_containers(0,5,9)- alignWith f = Map.merge (Map.mapMissing (\_ x -> f (This x)))- (Map.mapMissing (\_ y -> f (That y)))- (Map.zipWithMatched (\_ x y -> f (These x y)))-#elif MIN_VERSION_containers(0,5,0)- alignWith f = Map.mergeWithKey (\_ x y -> Just $ f $ These x y) (fmap (f . This)) (fmap (f . That))-#else- align m n = Map.unionWith merge (Map.map This m) (Map.map That n)- where merge (This a) (That b) = These a b- merge _ _ = oops "Align Map: merge"-#endif--instance Align IntMap where- nil = IntMap.empty--instance Semialign IntMap where-#if MIN_VERSION_containers(0,5,9)- alignWith f = IntMap.merge (IntMap.mapMissing (\_ x -> f (This x)))- (IntMap.mapMissing (\_ y -> f (That y)))- (IntMap.zipWithMatched (\_ x y -> f (These x y)))-#elif MIN_VERSION_containers(0,5,0)- alignWith f = IntMap.mergeWithKey (\_ x y -> Just $ f $ These x y) (fmap (f . This)) (fmap (f . That))-#else- align m n = IntMap.unionWith merge (IntMap.map This m) (IntMap.map That n)- where merge (This a) (That b) = These a b- merge _ _ = oops "Align IntMap: merge"-#endif---- @since 0.8-instance Semialign Identity where- alignWith f (Identity a) (Identity b) = Identity (f (These a b))--instance (Align f, Align g) => Align (Product f g) where- nil = Pair nil nil--instance (Semialign f, Semialign g) => Semialign (Product f g) where- align (Pair a b) (Pair c d) = Pair (align a c) (align b d)- alignWith f (Pair a b) (Pair c d) = Pair (alignWith f a c) (alignWith f b d)---- | @since 0.8.1-instance (Align f, Semialign g) => Align (Compose f g) where- nil = Compose nil---- | @since 0.8.1-instance (Semialign f, Semialign g) => Semialign (Compose f g) where- align (Compose x) (Compose y) = Compose (alignWith (these (fmap This) (fmap That) align) x y)---- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation-instance Monad m => Align (Stream m) where- nil = Stream.empty--instance Monad m => Semialign (Stream m) where-#if MIN_VERSION_vector(0,11,0)- alignWith f (Stream stepa ta) (Stream stepb tb)- = Stream step (ta, tb, Nothing, False)-#else- alignWith f (Stream stepa ta na) (Stream stepb tb nb)- = Stream step (ta, tb, Nothing, False) (Stream.larger na nb)-#endif- 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)--#if MIN_VERSION_vector(0,11,0)-instance Monad m => Align (Bundle m v) where- nil = Bundle.empty--instance Monad m => Semialign (Bundle m v) where- alignWith f Bundle{sElems = sa, sSize = na} Bundle{sElems = sb, sSize = nb}- = Bundle.fromStream (alignWith f sa sb) (Bundle.larger na nb)-#endif--instance Align V.Vector where- nil = Data.Vector.Generic.empty--instance Semialign V.Vector where- alignWith = alignVectorWith--alignVectorWith :: (Vector v a, Vector v b, Vector v c)- => (These a b -> c) -> v a -> v b -> v c-alignVectorWith f x y = unstream $ alignWith f (stream x) (stream y)--instance (Eq k, Hashable k) => Align (HashMap k) where- nil = HashMap.empty--instance (Eq k, Hashable k) => Semialign (HashMap k) where- align m n = HashMap.unionWith merge (HashMap.map This m) (HashMap.map That n)- where merge (This a) (That b) = These a b- merge _ _ = oops "Align HashMap: merge"---- | @since 0.8.1-instance Semialign (Tagged b) where- alignWith f (Tagged x) (Tagged y) = Tagged (f (These x y))---- | @since 0.8.1-instance Semialign Proxy where- alignWith _ _ _ = Proxy- align _ _ = Proxy---- | @since 0.8.1-instance Align Proxy where- nil = Proxy---- | Align two structures and combine with 'mappend'.------ See `salign`. `malign` will be deprecated after `Semigroup` becomes a super--- class of `Monoid`-malign :: (Align f, Monoid a) => f a -> f a -> f a-malign = alignWith (mergeThese mappend)---- | Align two structures and combine with '<>'.------ @since 0.7.3-salign :: (Align f, Semigroup a) => f a -> f a -> f a-salign = alignWith (mergeThese (<>))---- | Align two structures as in 'zip', but filling in blanks with 'Nothing'.-padZip :: (Align f) => f a -> f b -> f (Maybe a, Maybe b)-padZip = alignWith (fromThese Nothing Nothing . bimap Just Just)---- | Align two structures as in 'zipWith', but filling in blanks with 'Nothing'.-padZipWith :: (Align f) => (Maybe a -> Maybe b -> c) -> f a -> f b -> f c-padZipWith f xs ys = uncurry f <$> padZip xs ys---- | Left-padded 'zipWith'.-lpadZipWith :: (Maybe a -> b -> c) -> [a] -> [b] -> [c]-lpadZipWith f xs ys = catMaybes $ padZipWith (\x y -> f x <$> y) xs ys---- | Left-padded 'zip'.-lpadZip :: [a] -> [b] -> [(Maybe a, b)]-lpadZip = lpadZipWith (,)---- | Right-padded 'zipWith'.-rpadZipWith :: (a -> Maybe b -> c) -> [a] -> [b] -> [c]-rpadZipWith f xs ys = lpadZipWith (flip f) ys xs---- | Right-padded 'zip'.-rpadZip :: [a] -> [b] -> [(a, Maybe b)]-rpadZip = rpadZipWith (,)----- ----------------------------------------------------------------------------- | Alignable functors supporting an \"inverse\" to 'align': splitting--- a union shape into its component parts.------ Minimal definition: nothing; a default definition is provided,--- but it may not have the desired definition for all functors. See--- the source for more information.------ Laws:------ @--- unalign nil = (nil, nil)--- unalign (This \<$> x) = (Just \<$> x, Nothing \<$ x)--- unalign (That \<$> y) = (Nothing \<$ y, Just \<$> y)--- unalign (join These \<$> x) = (Just \<$> x, Just \<$> x)--- unalign ((x \`These`) \<$> y) = (Just x \<$ y, Just \<$> y)--- unalign ((\`These` y) \<$> x) = (Just \<$> x, Just y \<$ x)--- @-class (Align f) => Unalign f where- -- This might need more laws. Specifically, some notion of not- -- duplicating the effects would be nice, and a way to express its- -- relationship with align.- unalign :: f (These a b) -> (f (Maybe a), f (Maybe b))- unalign x = (fmap left x, fmap right x)- where left = these Just (const Nothing) (\a _ -> Just a)- right = these (const Nothing) Just (\_ b -> Just b)--instance Unalign Maybe--instance Unalign [] where- unalign = foldr (these a b ab) ([],[])- where a l ~(ls,rs) = (Just l :ls, Nothing:rs)- b r ~(ls,rs) = (Nothing:ls, Just r :rs)- ab l r ~(ls,rs) = (Just l :ls, Just r :rs)--instance Unalign ZipList where- unalign (ZipList xs) = (ZipList ys, ZipList zs)- where (ys, zs) = unalign xs--instance (Unalign f, Unalign g) => Unalign (Product f g) where- unalign (Pair a b) = (Pair al bl, Pair ar br)- where (al, ar) = unalign a- (bl, br) = unalign b--instance Monad m => Unalign (Stream m)---- ----------------------------------------------------------------------------- | Foldable functors supporting traversal through an alignable--- functor.------ Minimal definition: @crosswalk@ or @sequenceL@.------ Laws:------ @--- crosswalk (const nil) = const nil--- crosswalk f = sequenceL . fmap f--- @-class (Functor t, Foldable t) => Crosswalk t where- crosswalk :: (Align f) => (a -> f b) -> t a -> f (t b)- crosswalk f = sequenceL . fmap f-- sequenceL :: (Align f) => t (f a) -> f (t a)- sequenceL = crosswalk id--#if __GLASGOW_HASKELL__ >= 707- {-# MINIMAL crosswalk | sequenceL #-}-#endif--instance Crosswalk Identity where- crosswalk f (Identity a) = fmap Identity (f a)--instance Crosswalk Maybe where- crosswalk _ Nothing = nil- crosswalk f (Just a) = Just <$> f a--instance Crosswalk [] where- crosswalk _ [] = nil- crosswalk f (x:xs) = alignWith cons (f x) (crosswalk f xs)- where cons = these pure id (:)--instance Crosswalk Seq.Seq where- crosswalk f = foldr (alignWith cons . f) nil where- cons = these Seq.singleton id (Seq.<|)--instance Crosswalk (These a) where- crosswalk _ (This _) = nil- crosswalk f (That x) = That <$> f x- crosswalk f (These a x) = These a <$> f x--crosswalkVector :: (Vector v a, Vector v b, Align f)- => (a -> f b) -> v a -> f (v b)-crosswalkVector f = fmap VG.fromList . VG.foldr (alignWith cons . f) nil where- cons = these pure id (:)--instance Crosswalk V.Vector where- crosswalk = crosswalkVector---- | @since 0.7.5-instance Crosswalk ((,) a) where- crosswalk fun (a, x) = fmap ((,) a) (fun x)---- can't (shouldn't) do longer tuples until there are Functor and Foldable--- instances for them---- | @since 0.7.5-instance (Crosswalk f, Crosswalk g) => Crosswalk (Compose f g) where- crosswalk f = id- . fmap Compose -- can't coerce: maybe the Align-able thing has role nominal- . crosswalk (crosswalk f)- . getCompose---- ----------------------------------------------------------------------------- | Bifoldable bifunctors supporting traversal through an alignable--- functor.------ Minimal definition: @bicrosswalk@ or @bisequenceL@.------ Laws:------ @--- bicrosswalk (const empty) (const empty) = const empty--- bicrosswalk f g = bisequenceL . bimap f g--- @-class (Bifunctor t, Bifoldable t) => Bicrosswalk t where- bicrosswalk :: (Align f) => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)- bicrosswalk f g = bisequenceL . bimap f g-- bisequenceL :: (Align f) => t (f a) (f b) -> f (t a b)- bisequenceL = bicrosswalk id id--#if __GLASGOW_HASKELL__ >= 707- {-# MINIMAL bicrosswalk | bisequenceL #-}-#endif---instance Bicrosswalk Either where- bicrosswalk f _ (Left x) = Left <$> f x- bicrosswalk _ g (Right x) = Right <$> g x--instance Bicrosswalk These where- bicrosswalk f _ (This x) = This <$> f x- bicrosswalk _ g (That x) = That <$> g x- bicrosswalk f g (These x y) = align (f x) (g y)
− Data/Align/Indexed.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}--------------------------------------------------------------------------------- | Module : Data.Align.Indexed------ 'These'-based zipping and unzipping of indexed functors.------ @since 0.7.6-module Data.Align.Indexed (- AlignWithIndex (..),- ) where--import Control.Lens (FunctorWithIndex (imap))-import Data.Vector.Instances ()--import Data.Align-import Data.These---- Instances-import Control.Applicative (ZipList)-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import Data.IntMap (IntMap)-import Data.Map (Map)-import Data.Sequence (Seq)-import Data.Vector (Vector)---- | Keyed version of 'Align'.------ @since 0.7.6-class (FunctorWithIndex i f, Semialign f) => AlignWithIndex i f | f -> i where- -- | Analogous to @'alignWith'@, but also provides an index.- ialign :: (i -> These a b -> c) -> f a -> f b -> f c- ialign f a b = imap f (align a b)--instance AlignWithIndex () Maybe-instance AlignWithIndex Int []-instance AlignWithIndex Int ZipList-instance AlignWithIndex Int Seq-instance AlignWithIndex Int IntMap-instance Ord k => AlignWithIndex k (Map k)-instance (Eq k, Hashable k) => AlignWithIndex k (HashMap k)-instance AlignWithIndex Int Vector
− Data/Align/Key.hs
@@ -1,43 +0,0 @@--------------------------------------------------------------------------------- | Module : Data.Align.Key------ 'These'-based zipping and unzipping of indexed functors.------ @since 0.7.1-module Data.Align.Key (- AlignWithKey (..),- ) where--import Data.Key (Key, Keyed (..))-import Data.Vector.Instances ()--import Data.Align-import Data.These---- Instances-import Control.Applicative (ZipList)-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import Data.IntMap (IntMap)-import Data.Map (Map)-import Data.Sequence (Seq)-import Data.Vector (Vector)---- | Keyed version of 'Align'.------ @since 0.7.1-class (Keyed f, Semialign f) => AlignWithKey f where- -- | Analogous to @'alignWith'@, but also provides an index.- alignWithKey :: (Key f -> These a b -> c) -> f a -> f b -> f c- alignWithKey f a b = mapWithKey f (align a b)--instance AlignWithKey Maybe-instance AlignWithKey []---- | @since 0.7.6-instance AlignWithKey ZipList-instance AlignWithKey Seq-instance AlignWithKey IntMap-instance Ord k => AlignWithKey (Map k)-instance (Eq k, Hashable k) => AlignWithKey (HashMap k)-instance AlignWithKey Vector
− Data/Functor/These.hs
@@ -1,259 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--#if MIN_VERSION_base(4,9,0)-#define LIFTED_FUNCTOR_CLASSES 1-#else-#if MIN_VERSION_transformers(0,5,0)-#define LIFTED_FUNCTOR_CLASSES 1-#else-#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)-#define LIFTED_FUNCTOR_CLASSES 1-#endif-#endif-#endif--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-module Data.Functor.These (- These1 (..),- ) where--import Prelude ()-import Prelude.Compat--import Data.Aeson- (FromJSON (..), FromJSON1 (..), ToJSON (..), ToJSON1 (..), (.=))-import Data.Data (Data)-import Data.Functor.Classes- (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..), compare1, eq1, readsPrec1,- showsPrec1)-import Data.Typeable (Typeable)-import GHC.Generics (Generic, Generic1)-import Test.QuickCheck- (Arbitrary (..), Arbitrary1 (..), arbitrary1, liftShrink2, oneof,- shrink1)--#if MIN_VERSION_deepseq(1,4,3)-import Control.DeepSeq (NFData (..), NFData1 (..), rnf1)-#endif--import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encoding as Aeson (pair)-import qualified Data.HashMap.Strict as HM--data These1 f g a- = This1 (f a)- | That1 (g a)- | These1 (f a) (g a)- deriving (Functor, Foldable, Traversable, Generic-#if __GLASGOW_HASKELL__ >= 706- , Generic1-#endif-#if __GLASGOW_HASKELL__ >= 708- , Typeable, Data-#endif- )------------------------------------------------------------------------------------ Eq1----------------------------------------------------------------------------------instance (Eq1 f, Eq1 g) => Eq1 (These1 f g) where-#ifdef LIFTED_FUNCTOR_CLASSES- liftEq eq (This1 f) (This1 f') = liftEq eq f f'- liftEq eq (That1 g) (That1 g') = liftEq eq g g'- liftEq eq (These1 f g) (These1 f' g') = liftEq eq f f' && liftEq eq g g'-- liftEq _ This1 {} _ = False- liftEq _ That1 {} _ = False- liftEq _ These1 {} _ = False-#else- eq1 (This1 f) (This1 f') = eq1 f f'- eq1 (That1 g) (That1 g') = eq1 g g'- eq1 (These1 f g) (These1 f' g') = eq1 f f' && eq1 g g'-- eq1 This1 {} _ = False- eq1 That1 {} _ = False- eq1 These1 {} _ = False-#endif------------------------------------------------------------------------------------ Ord1----------------------------------------------------------------------------------instance (Ord1 f, Ord1 g) => Ord1 (These1 f g) where-#ifdef LIFTED_FUNCTOR_CLASSES- liftCompare cmp (This1 f) (This1 f') = liftCompare cmp f f'- liftCompare _cmp (This1 _) _ = LT- liftCompare _cmp _ (This1 _) = GT-- liftCompare cmp (That1 g) (That1 g') = liftCompare cmp g g'- liftCompare _cmp (That1 _) _ = LT- liftCompare _cmp _ (That1 _) = GT-- liftCompare cmp (These1 f g) (These1 f' g') =- liftCompare cmp f f' `mappend` liftCompare cmp g g'-#else- compare1 (This1 f) (This1 f') = compare1 f f'- compare1 (This1 _) _ = LT- compare1 _ (This1 _) = GT-- compare1 (That1 g) (That1 g') = compare1 g g'- compare1 (That1 _) _ = LT- compare1 _ (That1 _) = GT-- compare1 (These1 f g) (These1 f' g') =- compare1 f f' `mappend` compare1 g g'-#endif------------------------------------------------------------------------------------- Show1----------------------------------------------------------------------------------instance (Show1 f, Show1 g) => Show1 (These1 f g) where-#ifdef LIFTED_FUNCTOR_CLASSES- liftShowsPrec sp sl d (This1 f) = showParen (d > 10)- $ showString "This1 "- . liftShowsPrec sp sl 11 f- liftShowsPrec sp sl d (That1 g) = showParen (d > 10)- $ showString "That1 "- . liftShowsPrec sp sl 11 g- liftShowsPrec sp sl d (These1 f g) = showParen (d > 10)- $ showString "These1 "- . liftShowsPrec sp sl 11 f- . showChar ' '- . liftShowsPrec sp sl 11 g-#else- showsPrec1 d (This1 f) = showParen (d > 10)- $ showString "This1 "- . showsPrec1 11 f- showsPrec1 d (That1 g) = showParen (d > 10)- $ showString "That1 "- . showsPrec1 11 g- showsPrec1 d (These1 f g) = showParen (d > 10)- $ showString "These1 "- . showsPrec1 11 f- . showChar ' '- . showsPrec1 11 g-#endif------------------------------------------------------------------------------------ Read1----------------------------------------------------------------------------------instance (Read1 f, Read1 g) => Read1 (These1 f g) where-#ifdef LIFTED_FUNCTOR_CLASSES- liftReadsPrec rp rl d = readParen (d > 10) $ \s0 -> do- (t, s1) <- lex s0- case t of- "This1" -> do- (x, s2) <- liftReadsPrec rp rl 11 s1- return (This1 x, s2)- "That1" -> do- (y, s2) <- liftReadsPrec rp rl 11 s1- return (That1 y, s2)- "These1" -> do- (x, s2) <- liftReadsPrec rp rl 11 s1- (y, s3) <- liftReadsPrec rp rl 11 s2- return (These1 x y, s3)- _ -> []-#else- readsPrec1 d = readParen (d > 10) $ \s0 -> do- (t, s1) <- lex s0- case t of- "This1" -> do- (x, s2) <- readsPrec1 11 s1- return (This1 x, s2)- "That1" -> do- (y, s2) <- readsPrec1 11 s1- return (That1 y, s2)- "These1" -> do- (x, s2) <- readsPrec1 11 s1- (y, s3) <- readsPrec1 11 s2- return (These1 x y, s3)- _ -> []-#endif------------------------------------------------------------------------------------ Eq, Ord, Show, Read----------------------------------------------------------------------------------instance (Eq1 f, Eq1 g, Eq a) => Eq (These1 f g a) where (==) = eq1-instance (Ord1 f, Ord1 g, Ord a) => Ord (These1 f g a) where compare = compare1-instance (Show1 f, Show1 g, Show a) => Show (These1 f g a) where showsPrec = showsPrec1-instance (Read1 f, Read1 g, Read a) => Read (These1 f g a) where readsPrec = readsPrec1------------------------------------------------------------------------------------ deepseq----------------------------------------------------------------------------------#if MIN_VERSION_deepseq(1,4,3)--- | This instance is available only with @deepseq >= 1.4.3.0@-instance (NFData1 f, NFData1 g) => NFData1 (These1 f g) where- liftRnf r (This1 x) = liftRnf r x- liftRnf r (That1 y) = liftRnf r y- liftRnf r (These1 x y) = liftRnf r x `seq` liftRnf r y---- | This instance is available only with @deepseq >= 1.4.3.0@-instance (NFData1 f, NFData1 g, NFData a) => NFData (These1 f g a) where- rnf = rnf1-#endif------------------------------------------------------------------------------------ aeson----------------------------------------------------------------------------------instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where- liftToJSON tx tl (This1 a) = Aeson.object [ "This" .= liftToJSON tx tl a ]- liftToJSON tx tl (That1 b) = Aeson.object [ "That" .= liftToJSON tx tl b ]- liftToJSON tx tl (These1 a b) = Aeson.object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ]-- liftToEncoding tx tl (This1 a) = Aeson.pairs $ Aeson.pair "This" (liftToEncoding tx tl a)- liftToEncoding tx tl (That1 b) = Aeson.pairs $ Aeson.pair "That" (liftToEncoding tx tl b)- liftToEncoding tx tl (These1 a b) = Aeson.pairs $- Aeson.pair "This" (liftToEncoding tx tl a) `mappend`- Aeson.pair "That" (liftToEncoding tx tl b)--instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where- liftParseJSON px pl = Aeson.withObject "These1" (p . HM.toList)- where- p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b- p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b- p [("This", a)] = This1 <$> liftParseJSON px pl a- p [("That", b)] = That1 <$> liftParseJSON px pl b- p _ = fail "Expected object with 'This' and 'That' keys only"--instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where- toJSON = Aeson.toJSON1- toEncoding = Aeson.toEncoding1--instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where- parseJSON = Aeson.parseJSON1------------------------------------------------------------------------------------ QuickCheck----------------------------------------------------------------------------------instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (These1 f g) where- liftArbitrary arb = oneof- [ This1 <$> liftArbitrary arb- , That1 <$> liftArbitrary arb- , These1 <$> liftArbitrary arb <*> liftArbitrary arb- ]-- liftShrink shr (This1 x) = This1 <$> liftShrink shr x- liftShrink shr (That1 y) = That1 <$> liftShrink shr y- liftShrink shr (These1 x y) =- [ This1 x, That1 y ] ++- [ These1 x' y'- | (x', y') <- liftShrink2 (liftShrink shr) (liftShrink shr) (x, y)- ]--instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (These1 f g a) where- arbitrary = arbitrary1- shrink = shrink1
− Data/These.hs
@@ -1,346 +0,0 @@--------------------------------------------------------------------------------- | Module : Data.These------ The 'These' type and associated operations. Now enhanced with "Control.Lens" magic!-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-module Data.These (- These(..)-- -- * Functions to get rid of 'These'- , these- , fromThese- , mergeThese- , mergeTheseWith-- -- * Partition- , partitionThese- , partitionHereThere- ) where--import Prelude ()-import Prelude.Compat--import Control.DeepSeq (NFData (..))-import Control.Lens (Swapped (..), iso)-import Data.Aeson (FromJSON (..), ToJSON (..), (.=))-import Data.Bifoldable (Bifoldable (..))-import Data.Bifunctor (Bifunctor (..))-import Data.Bifunctor.Assoc (Assoc (..))-import Data.Bifunctor.Swap (Swap (..))-import Data.Binary (Binary (..))-import Data.Bitraversable (Bitraversable (..))-import Data.Data (Data, Typeable)-import Data.Functor.Bind (Apply (..), Bind (..))-import Data.Hashable (Hashable (..))-import Data.Semigroup (Semigroup (..))-import Data.Semigroup.Bifoldable (Bifoldable1 (..))-import Data.Semigroup.Bitraversable (Bitraversable1 (..))-import GHC.Generics (Generic)-import Test.QuickCheck- (Arbitrary (..), Arbitrary1 (..), Arbitrary2 (..), CoArbitrary (..),- arbitrary1, oneof, shrink1)-import Test.QuickCheck.Function (Function (..), functionMap)--import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encoding as Aeson (pair)-import qualified Data.HashMap.Strict as HM---- $setup--- >>> import Control.Lens---- ----------------------------------------------------------------------------- | The 'These' type represents values with two non-exclusive possibilities.------ This can be useful to represent combinations of two values, where the--- combination is defined if either input is. Algebraically, the type--- @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into--- sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and--- awkward to use.------ 'These' has straightforward instances of 'Functor', 'Monad', &c., and--- behaves like a hybrid error/writer monad, as would be expected.------ For zipping and unzipping of structures with 'These' values, see--- "Data.Align".-data These a b = This a | That b | These a b- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)------------------------------------------------------------------------------------ Eliminators------------------------------------------------------------------------------------ | Case analysis for the 'These' type.-these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c-these l _ _ (This a) = l a-these _ r _ (That x) = r x-these _ _ lr (These a x) = lr a x---- | Takes two default values and produces a tuple.-fromThese :: a -> b -> These a b -> (a, b)-fromThese x y = these (`pair` y) (x `pair`) pair where- pair = (,)---- | Coalesce with the provided operation.-mergeThese :: (a -> a -> a) -> These a a -> a-mergeThese = these id id---- | 'bimap' and coalesce results with the provided operation.-mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c-mergeTheseWith f g op t = mergeThese op $ bimap f g t------------------------------------------------------------------------------------ Partitioning------------------------------------------------------------------------------------ | Select each constructor and partition them into separate lists.-partitionThese :: [These a b] -> ([a], [b], [(a, b)])-partitionThese [] = ([], [], [])-partitionThese (t:ts) = case t of- This x -> (x : xs, ys, xys)- That y -> ( xs, y : ys, xys)- These x y -> ( xs, ys, (x,y) : xys)- where- ~(xs,ys,xys) = partitionThese ts---- | Select 'here' and 'there' elements and partition them into separate lists.------ @since 0.8-partitionHereThere :: [These a b] -> ([a], [b])-partitionHereThere [] = ([], [])-partitionHereThere (t:ts) = case t of- This x -> (x : xs, ys)- That y -> ( xs, y : ys)- These x y -> (x : xs, y : ys)- where- ~(xs,ys) = partitionHereThere ts------------------------------------------------------------------------------------ Instances------------------------------------------------------------------------------------ | @since 0.8-instance Swap These where- swap (This a) = That a- swap (That b) = This b- swap (These a b) = These b a---- | @since 0.8-instance Assoc These where- assoc (This (This a)) = This a- assoc (This (That b)) = That (This b)- assoc (That c) = That (That c)- assoc (These (That b) c) = That (These b c)- assoc (This (These a b)) = These a (This b)- assoc (These (This a) c) = These a (That c)- assoc (These (These a b) c) = These a (These b c)-- unassoc (This a) = This (This a)- unassoc (That (This b)) = This (That b)- unassoc (That (That c)) = That c- unassoc (That (These b c)) = These (That b) c- unassoc (These a (This b)) = This (These a b)- unassoc (These a (That c)) = These (This a) c- unassoc (These a (These b c)) = These (These a b) c--instance (Semigroup a, Semigroup b) => Semigroup (These a b) where- This a <> This b = This (a <> b)- This a <> That y = These a y- This a <> These b y = These (a <> b) y- That x <> This b = These b x- That x <> That y = That (x <> y)- That x <> These b y = These b (x <> y)- These a x <> This b = These (a <> b) x- These a x <> That y = These a (x <> y)- These a x <> These b y = These (a <> b) (x <> y)--instance Functor (These a) where- fmap _ (This x) = This x- fmap f (That y) = That (f y)- fmap f (These x y) = These x (f y)--instance Foldable (These a) where- foldr _ z (This _) = z- foldr f z (That x) = f x z- foldr f z (These _ x) = f x z--instance Traversable (These a) where- traverse _ (This a) = pure $ This a- traverse f (That x) = That <$> f x- traverse f (These a x) = These a <$> f x- sequenceA (This a) = pure $ This a- sequenceA (That x) = That <$> x- sequenceA (These a x) = These a <$> x--instance Bifunctor These where- bimap f _ (This a ) = This (f a)- bimap _ g (That x) = That (g x)- bimap f g (These a x) = These (f a) (g x)--instance Bifoldable These where- bifold = these id id mappend- bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z))- bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y)--instance Bifoldable1 These where- bifold1 = these id id (<>)--instance Bitraversable These where- bitraverse f _ (This x) = This <$> f x- bitraverse _ g (That x) = That <$> g x- bitraverse f g (These x y) = These <$> f x <*> g y--instance Bitraversable1 These where- bitraverse1 f _ (This x) = This <$> f x- bitraverse1 _ g (That x) = That <$> g x- bitraverse1 f g (These x y) = These <$> f x <.> g y---- | @since 0.7.6-instance Swapped These where- swapped = iso swap swap--instance (Semigroup a) => Apply (These a) where- This a <.> _ = This a- That _ <.> This b = This b- That f <.> That x = That (f x)- That f <.> These b x = These b (f x)- These a _ <.> This b = This (a <> b)- These a f <.> That x = These a (f x)- These a f <.> These b x = These (a <> b) (f x)--instance (Semigroup a) => Applicative (These a) where- pure = That- (<*>) = (<.>)--instance (Semigroup a) => Bind (These a) where- This a >>- _ = This a- That x >>- k = k x- These a x >>- k = case k x of- This b -> This (a <> b)- That y -> These a y- These b y -> These (a <> b) y--instance (Semigroup a) => Monad (These a) where- return = pure- (>>=) = (>>-)--instance (Hashable a, Hashable b) => Hashable (These a b)---- | @since 0.7.1-instance (NFData a, NFData b) => NFData (These a b) where- rnf (This a) = rnf a- rnf (That b) = rnf b- rnf (These a b) = rnf a `seq` rnf b---- | @since 0.7.1-instance (Binary a, Binary b) => Binary (These a b) where- put (This a) = put (0 :: Int) >> put a- put (That b) = put (1 :: Int) >> put b- put (These a b) = put (2 :: Int) >> put a >> put b-- get = do- i <- get- case (i :: Int) of- 0 -> This <$> get- 1 -> That <$> get- 2 -> These <$> get <*> get- _ -> fail "Invalid These index"---- | @since 0.7.1-instance (ToJSON a, ToJSON b) => ToJSON (These a b) where- toJSON (This a) = Aeson.object [ "This" .= a ]- toJSON (That b) = Aeson.object [ "That" .= b ]- toJSON (These a b) = Aeson.object [ "This" .= a, "That" .= b ]-- toEncoding (This a) = Aeson.pairs $ "This" .= a- toEncoding (That b) = Aeson.pairs $ "That" .= b- toEncoding (These a b) = Aeson.pairs $ "This" .= a <> "That" .= b---- | @since 0.7.1-instance (FromJSON a, FromJSON b) => FromJSON (These a b) where- parseJSON = Aeson.withObject "These a b" (p . HM.toList)- where- p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b- p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b- p [("This", a)] = This <$> parseJSON a- p [("That", b)] = That <$> parseJSON b- p _ = fail "Expected object with 'This' and 'That' keys only"---- | @since 0.7.2-instance Aeson.ToJSON2 These where- liftToJSON2 toa _ _tob _ (This a) = Aeson.object [ "This" .= toa a ]- liftToJSON2 _toa _ tob _ (That b) = Aeson.object [ "That" .= tob b ]- liftToJSON2 toa _ tob _ (These a b) = Aeson.object [ "This" .= toa a, "That" .= tob b ]-- liftToEncoding2 toa _ _tob _ (This a) = Aeson.pairs $ Aeson.pair "This" (toa a)- liftToEncoding2 _toa _ tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)- liftToEncoding2 toa _ tob _ (These a b) = Aeson.pairs $ Aeson.pair "This" (toa a) <> Aeson.pair "That" (tob b)---- | @since 0.7.2-instance ToJSON a => Aeson.ToJSON1 (These a) where- liftToJSON _tob _ (This a) = Aeson.object [ "This" .= a ]- liftToJSON tob _ (That b) = Aeson.object [ "That" .= tob b ]- liftToJSON tob _ (These a b) = Aeson.object [ "This" .= a, "That" .= tob b ]-- liftToEncoding _tob _ (This a) = Aeson.pairs $ "This" .= a- liftToEncoding tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)- liftToEncoding tob _ (These a b) = Aeson.pairs $ "This" .= a <> Aeson.pair "That" (tob b)---- | @since 0.7.2-instance Aeson.FromJSON2 These where- liftParseJSON2 pa _ pb _ = Aeson.withObject "These a b" (p . HM.toList)- where- p [("This", a), ("That", b)] = These <$> pa a <*> pb b- p [("That", b), ("This", a)] = These <$> pa a <*> pb b- p [("This", a)] = This <$> pa a- p [("That", b)] = That <$> pb b- p _ = fail "Expected object with 'This' and 'That' keys only"---- | @since 0.7.2-instance FromJSON a => Aeson.FromJSON1 (These a) where- liftParseJSON pb _ = Aeson.withObject "These a b" (p . HM.toList)- where- p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b- p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b- p [("This", a)] = This <$> parseJSON a- p [("That", b)] = That <$> pb b- p _ = fail "Expected object with 'This' and 'That' keys only"---- | @since 0.7.4-instance Arbitrary2 These where- liftArbitrary2 arbA arbB = oneof- [ This <$> arbA- , That <$> arbB- , These <$> arbA <*> arbB- ]-- liftShrink2 shrA _shrB (This x) = This <$> shrA x- liftShrink2 _shrA shrB (That y) = That <$> shrB y- liftShrink2 shrA shrB (These x y) =- [This x, That y] ++ [These x' y' | (x', y') <- liftShrink2 shrA shrB (x, y)]---- | @since 0.7.4-instance (Arbitrary a) => Arbitrary1 (These a) where- liftArbitrary = liftArbitrary2 arbitrary- liftShrink = liftShrink2 shrink---- | @since 0.7.1-instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where- arbitrary = arbitrary1- shrink = shrink1---- | @since 0.7.1-instance (Function a, Function b) => Function (These a b) where- function = functionMap g f- where- g (This a) = Left a- g (That b) = Right (Left b)- g (These a b) = Right (Right (a, b))-- f (Left a) = This a- f (Right (Left b)) = That b- f (Right (Right (a, b))) = These a b---- | @since 0.7.1-instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (These a b)
− Data/These/Combinators.hs
@@ -1,247 +0,0 @@--- | This module provides------ * specialised versions of class members e.g. 'bitraverseThese'--- * non-lens variants of "Data.These.Lens" things, e.g 'justHere'-module Data.These.Combinators (- -- * Specialised combinators- -- ** Bifunctor- bimapThese,- mapHere,- mapThere,- -- ** Bitraversable- bitraverseThese,- -- ** Associativity and commutativity- swapThese,- assocThese,- unassocThese,-- -- * Other operations- -- ** preview- --- -- |- -- @- -- 'justThis' = 'Control.Lens.preview' '_This'- -- 'justThat' = 'Control.Lens.preview' '_That'- -- 'justThese' = 'Control.Lens.preview' '_These'- -- 'justHere' = 'Control.Lens.preview' 'here'- -- 'justThere' = 'Control.Lens.preview' 'there'- -- @- justThis,- justThat,- justThese,- justHere,- justThere,-- -- ** toListOf- --- -- |- -- @- -- 'catThis' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_This')- -- 'catThat' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_That')- -- 'catThese' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_These')- -- 'catHere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'here')- -- 'catThere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'there')- -- @- catThis,- catThat,- catThese,- catHere,- catThere,-- -- * is / has- --- -- |- -- @- -- 'isThis' = 'Control.Lens.Extra.is' '_This'- -- 'isThat' = 'Control.Lens.Extra.is' '_That'- -- 'isThese' = 'Control.Lens.Extra.is' '_These'- -- 'hasHere' = 'Control.Lens.has' 'here'- -- 'hasThere' = 'Control.Lens.has' 'there'- -- @- isThis,- isThat,- isThese,- hasHere,- hasThere,-- -- * over / map- --- -- @- -- 'mapThis' = 'Control.Lens.over' '_This'- -- 'mapThat' = 'Control.Lens.over' '_That'- -- 'mapThese' = 'Control.Lens.over' '_These'- -- 'mapHere' = 'Control.Lens.over' 'here'- -- 'mapThere' = 'Control.Lens.over' 'there'- -- @- mapThis,- mapThat,- mapThese,- ) where--import Prelude ()-import Prelude.Compat--import Data.Bifunctor (bimap, first, second)-import Data.Bifunctor.Assoc (assoc, unassoc)-import Data.Bifunctor.Swap (swap)-import Data.Bitraversable (bitraverse)-import Data.Maybe (isJust, mapMaybe)-import Data.These------------------------------------------------------------------------------------ bifunctors------------------------------------------------------------------------------------ | 'Bifunctor' 'bimap'.-bimapThese :: (a -> c) -> (b -> d) -> These a b -> These c d-bimapThese = bimap---- | @'mapHere' = 'Control.Lens.over' 'here'@-mapHere :: (a -> c) -> These a b -> These c b-mapHere = first---- | @'mapThere' = 'Control.Lens.over' 'there'@-mapThere :: (b -> d) -> These a b -> These a d-mapThere = second---- | 'Bitraversable' 'bitraverse'.-bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d)-bitraverseThese = bitraverse------------------------------------------------------------------------------------ assoc------------------------------------------------------------------------------------ | 'These' is commutative.------ @--- 'swapThese' . 'swapThese' = 'id'--- @------ @since 0.8-swapThese :: These a b -> These b a-swapThese = swap---- | 'These' is associative.------ @--- 'assocThese' . 'unassocThese' = 'id'--- 'unassocThese' . 'assocThese' = 'id'--- @------ @since 0.8-assocThese :: These (These a b) c -> These a (These b c)-assocThese = assoc---- | 'These' is associative. See 'assocThese'.------ @since 0.8-unassocThese :: These a (These b c) -> These (These a b) c-unassocThese = unassoc------------------------------------------------------------------------------------ preview------------------------------------------------------------------------------------ |------ >>> justHere (This 'x')--- Just 'x'------ >>> justHere (That 'y')--- Nothing------ >>> justHere (These 'x' 'y')--- Just 'x'----justHere :: These a b -> Maybe a-justHere (This a) = Just a-justHere (That _) = Nothing-justHere (These a _) = Just a---- |------ >>> justThere (This 'x')--- Nothing------ >>> justThere (That 'y')--- Just 'y'------ >>> justThere (These 'x' 'y')--- Just 'y'----justThere :: These a b -> Maybe b-justThere (This _) = Nothing-justThere (That b) = Just b-justThere (These _ b) = Just b--justThis :: These a b -> Maybe a-justThis (This a) = Just a-justThis _ = Nothing--justThat :: These a b -> Maybe b-justThat (That x) = Just x-justThat _ = Nothing--justThese :: These a b -> Maybe (a, b)-justThese (These a x) = Just (a, x)-justThese _ = Nothing------------------------------------------------------------------------------------ toListOf------------------------------------------------------------------------------------ | Select all 'This' constructors from a list.-catThis :: [These a b] -> [a]-catThis = mapMaybe justThis---- | Select all 'That' constructors from a list.-catThat :: [These a b] -> [b]-catThat = mapMaybe justThat---- | Select all 'These' constructors from a list.-catThese :: [These a b] -> [(a, b)]-catThese = mapMaybe justThese--catHere :: [These a b] -> [a]-catHere = mapMaybe justHere--catThere :: [These a b] -> [b]-catThere = mapMaybe justThere------------------------------------------------------------------------------------ is----------------------------------------------------------------------------------isThis, isThat, isThese :: These a b -> Bool--- | @'isThis' = 'isJust' . 'justThis'@-isThis = isJust . justThis---- | @'isThat' = 'isJust' . 'justThat'@-isThat = isJust . justThat---- | @'isThese' = 'isJust' . 'justThese'@-isThese = isJust . justThese--hasHere, hasThere :: These a b -> Bool--- | @'hasHere' = 'isJust' . 'justHere'@-hasHere = isJust . justHere---- | @'hasThere' = 'isJust' . 'justThere'@-hasThere = isJust . justThere------------------------------------------------------------------------------------ over / map----------------------------------------------------------------------------------mapThis :: (a -> a) -> These a b -> These a b-mapThis f (This x) = This (f x)-mapThis _ y = y--mapThat :: (b -> b) -> These a b -> These a b-mapThat f (That x) = That (f x)-mapThat _ y = y--mapThese :: ((a, b) -> (a, b)) -> These a b -> These a b-mapThese f (These x y) = uncurry These (curry f x y)-mapThese _ z = z
− Data/These/Lens.hs
@@ -1,73 +0,0 @@-module Data.These.Lens (- -- * Traversals- here, there,-- -- * Prisms- _This, _That, _These,- ) where--import Prelude ()-import Prelude.Compat--import Control.Lens (Prism', prism)-import Data.These------------------------------------------------------------------------------------ Traversals------------------------------------------------------------------------------------ | A 'Control.Lens.Traversal' of the first half of a 'These', suitable for use with "Control.Lens".------ @--- 'here' :: 'Control.Lens.Traversal' ('These' a t) ('These' b t) a b--- @------ >>> over here show (That 1)--- That 1------ >>> over here show (These 'a' 2)--- These "'a'" 2----here :: (Applicative f) => (a -> f b) -> These a t -> f (These b t)-here f (This x) = This <$> f x-here f (These x y) = flip These y <$> f x-here _ (That x) = pure (That x)---- | A 'Control.Lens.Traversal' of the second half of a 'These', suitable for use with "Control.Lens".------ @--- 'there' :: 'Control.Lens.Traversal' ('These' t b) ('These' t b) a b--- @------ >>> over there show (That 1)--- That "1"------ >>> over there show (These 'a' 2)--- These 'a' "2"----there :: (Applicative f) => (a -> f b) -> These t a -> f (These t b)-there _ (This x) = pure (This x)-there f (These x y) = These x <$> f y-there f (That x) = That <$> f x------------------------------------------------------------------------------------ Prisms------------------------------------------------------------------------------------ | A 'Control.Lens.Prism'' selecting the 'This' constructor.------ /Note:/ cannot change type.-_This :: Prism' (These a b) a-_This = prism This (these Right (Left . That) (\x y -> Left $ These x y))---- | A 'Control.Lens.Prism'' selecting the 'That' constructor.------ /Note:/ cannot change type.-_That :: Prism' (These a b) b-_That = prism That (these (Left . This) Right (\x y -> Left $ These x y))---- | A 'Control.Lens.Prism'' selecting the 'These' constructor. 'These' names are ridiculous!------ /Note:/ cannot change type.-_These :: Prism' (These a b) (a, b)-_These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y)))
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2012, C. McCann+Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus All rights reserved.
− README.md
@@ -1,68 +0,0 @@-These — an either-or-both data type-====================================--[](http://travis-ci.org/isomorphism/these)---The type `These a b` represents having either a value of type `a`, a value of type `b`, or values of both `a` and `b`:--```haskell-data These a b = This a | That b | These a b-```--This is equivalent to `Either (a, b) (Either a b)`. Or equivalent to `Either a (b, Maybe a)`. Or various other equally equivalent types. In terms of "sum" and "product" types, `These a b` is `a + b + ab` which can't be factored cleanly to get a type that mentions `a` and `b` only once each.--The fact that there's no single obvious way to express it as a combination of existing types is one primary motivation for this package.--A variety of functions are provided in `Data.These` akin to those in `Data.Either`, except somewhat more numerous on account of having more cases to consider. Most should be self-explanatory if you're already familiar with the similarly-named functions in `Data.Either` and `Data.Maybe`.--`here` and `there` are traversals over elements of the same type, suitable for use with `Control.Lens`. This has the dramatic benefit that if you're using `lens` you can ignore the dreadfully bland `mapThis` and `mapThat` functions in favor of saying `over here` and `over there`.---Align — structural unions-==========================--There is a notion of "zippy" `Applicative`s where `liftA2 (,)` behaves like `zip` in the sense that if the `Functor` is regarded as a container with distinct locations, each element of the result is a pair of the values that occupied the same location in the two inputs. For this to be possible, the result can only contain values at locations where both inputs also contained values. In a sense, this is the intersection of the "shapes" of the two inputs.--In the case of the `zip` function itself, this means the length of the result is equal to the length of the shorter of the two inputs.--On many occasions it would be more useful to have a "zip with padding", where the length of the result is that of the *longer* input, with the other input extended by some means. The best way to do this is a recurring question, having been asked [at](http://stackoverflow.com/q/21349408/157360) [least](http://stackoverflow.com/q/22403029/157360) [four](http://stackoverflow.com/q/3015962/157360) [times](http://stackoverflow.com/q/9198410/157360) on Stack Overflow. --Probably the most obvious general-purpose solution is use `Maybe` so that the result is of type `[(Maybe a, Maybe b)]`, but this forces any code using that result to consider the possibility of the list containing the value `(Nothing, Nothing)`, which we don't want.--The type class `Align` is here because `f (These a b)` is the natural result type of a generic "zip with padding" operation--i.e. a structural union rather than intersection. --I believe the name "Align" was borrowed from [a blog post by Paul Chiusano](http://pchiusano.blogspot.com/2010/06/alignable-functors-typeclass-for-zippy.html), though he used `Alignable` instead.---Unalign----------`unalign` is to `align` as `unzip` is to `zip`. The `Unalign` class itself does nothing, as `unalign` can be defined for any `Functor`; an instance just documents that `unalign` behaves properly as an inverse to `align`.--Crosswalk------------`Crosswalk` is to `Align` as `Traversable` is to `Applicative`. That's really all there is to say on the matter.---Bicrosswalk--------------```-<cmccann> elliott, you should think of some more instances for Bicrosswalk one of these days-<shachaf> cmccann: Does it have any instances?-<elliott> cmccann: unfortunately it is too perfect an abstraction to be useful.-```--ChronicleT — a.k.a. These as a monad-=====================================--`These a` has an obvious `Monad` instance, provided here in monad transformer form.--The expected use case is for computations with a notion of fatal vs. non-fatal errors, like a hybrid writer/exception monad. While running successfully a computation carries a "record" of type `c`, which accumulates using a `Monoid` instance (as with the writer monad); if a computation fails completely, the result is its record up to the point where it ended.--A more specific example would be something like parsing ill-formed input with the goal of extracting as much as you can and throwing out anything you can't interpret.---
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ src/Data/Functor/These.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}++#if MIN_VERSION_base(4,9,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers(0,5,0)+#define LIFTED_FUNCTOR_CLASSES 1+#else+#if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0)+#define LIFTED_FUNCTOR_CLASSES 1+#endif+#endif+#endif++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+module Data.Functor.These (+ These1 (..),+ ) where++import Prelude ()+import Prelude.Compat++import Data.Functor.Classes+ (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..), compare1, eq1, readsPrec1,+ showsPrec1)+import GHC.Generics (Generic)+++#if MIN_VERSION_deepseq(1,4,3)+import Control.DeepSeq (NFData (..), NFData1 (..), rnf1)+#endif++#if __GLASGOW_HASKELL__ >= 706+import GHC.Generics (Generic1)+#endif++#if __GLASGOW_HASKELL__ >= 708+import Data.Data (Data)+import Data.Typeable (Typeable)+#endif++#ifdef MIN_VERSION_aeson+import Data.Aeson+ (FromJSON (..), FromJSON1 (..), ToJSON (..), ToJSON1 (..), (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson (pair)+import qualified Data.HashMap.Strict as HM+#endif++#ifdef MIN_VERSION_QuickCheck+import Test.QuickCheck+ (Arbitrary (..), Arbitrary1 (..), arbitrary1, liftShrink2, oneof,+ shrink1)+#endif++-------------------------------------------------------------------------------+-- These1+-------------------------------------------------------------------------------++data These1 f g a+ = This1 (f a)+ | That1 (g a)+ | These1 (f a) (g a)+ deriving (Functor, Foldable, Traversable, Generic+#if __GLASGOW_HASKELL__ >= 706+ , Generic1+#endif+#if __GLASGOW_HASKELL__ >= 708+ , Typeable, Data+#endif+ )++-------------------------------------------------------------------------------+-- Eq1+-------------------------------------------------------------------------------++instance (Eq1 f, Eq1 g) => Eq1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftEq eq (This1 f) (This1 f') = liftEq eq f f'+ liftEq eq (That1 g) (That1 g') = liftEq eq g g'+ liftEq eq (These1 f g) (These1 f' g') = liftEq eq f f' && liftEq eq g g'++ liftEq _ This1 {} _ = False+ liftEq _ That1 {} _ = False+ liftEq _ These1 {} _ = False+#else+ eq1 (This1 f) (This1 f') = eq1 f f'+ eq1 (That1 g) (That1 g') = eq1 g g'+ eq1 (These1 f g) (These1 f' g') = eq1 f f' && eq1 g g'++ eq1 This1 {} _ = False+ eq1 That1 {} _ = False+ eq1 These1 {} _ = False+#endif++-------------------------------------------------------------------------------+-- Ord1+-------------------------------------------------------------------------------++instance (Ord1 f, Ord1 g) => Ord1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftCompare cmp (This1 f) (This1 f') = liftCompare cmp f f'+ liftCompare _cmp (This1 _) _ = LT+ liftCompare _cmp _ (This1 _) = GT++ liftCompare cmp (That1 g) (That1 g') = liftCompare cmp g g'+ liftCompare _cmp (That1 _) _ = LT+ liftCompare _cmp _ (That1 _) = GT++ liftCompare cmp (These1 f g) (These1 f' g') =+ liftCompare cmp f f' `mappend` liftCompare cmp g g'+#else+ compare1 (This1 f) (This1 f') = compare1 f f'+ compare1 (This1 _) _ = LT+ compare1 _ (This1 _) = GT++ compare1 (That1 g) (That1 g') = compare1 g g'+ compare1 (That1 _) _ = LT+ compare1 _ (That1 _) = GT++ compare1 (These1 f g) (These1 f' g') =+ compare1 f f' `mappend` compare1 g g'+#endif+++-------------------------------------------------------------------------------+-- Show1+-------------------------------------------------------------------------------++instance (Show1 f, Show1 g) => Show1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftShowsPrec sp sl d (This1 f) = showParen (d > 10)+ $ showString "This1 "+ . liftShowsPrec sp sl 11 f+ liftShowsPrec sp sl d (That1 g) = showParen (d > 10)+ $ showString "That1 "+ . liftShowsPrec sp sl 11 g+ liftShowsPrec sp sl d (These1 f g) = showParen (d > 10)+ $ showString "These1 "+ . liftShowsPrec sp sl 11 f+ . showChar ' '+ . liftShowsPrec sp sl 11 g+#else+ showsPrec1 d (This1 f) = showParen (d > 10)+ $ showString "This1 "+ . showsPrec1 11 f+ showsPrec1 d (That1 g) = showParen (d > 10)+ $ showString "That1 "+ . showsPrec1 11 g+ showsPrec1 d (These1 f g) = showParen (d > 10)+ $ showString "These1 "+ . showsPrec1 11 f+ . showChar ' '+ . showsPrec1 11 g+#endif++-------------------------------------------------------------------------------+-- Read1+-------------------------------------------------------------------------------++instance (Read1 f, Read1 g) => Read1 (These1 f g) where+#ifdef LIFTED_FUNCTOR_CLASSES+ liftReadsPrec rp rl d = readParen (d > 10) $ \s0 -> do+ (t, s1) <- lex s0+ case t of+ "This1" -> do+ (x, s2) <- liftReadsPrec rp rl 11 s1+ return (This1 x, s2)+ "That1" -> do+ (y, s2) <- liftReadsPrec rp rl 11 s1+ return (That1 y, s2)+ "These1" -> do+ (x, s2) <- liftReadsPrec rp rl 11 s1+ (y, s3) <- liftReadsPrec rp rl 11 s2+ return (These1 x y, s3)+ _ -> []+#else+ readsPrec1 d = readParen (d > 10) $ \s0 -> do+ (t, s1) <- lex s0+ case t of+ "This1" -> do+ (x, s2) <- readsPrec1 11 s1+ return (This1 x, s2)+ "That1" -> do+ (y, s2) <- readsPrec1 11 s1+ return (That1 y, s2)+ "These1" -> do+ (x, s2) <- readsPrec1 11 s1+ (y, s3) <- readsPrec1 11 s2+ return (These1 x y, s3)+ _ -> []+#endif++-------------------------------------------------------------------------------+-- Eq, Ord, Show, Read+-------------------------------------------------------------------------------++instance (Eq1 f, Eq1 g, Eq a) => Eq (These1 f g a) where (==) = eq1+instance (Ord1 f, Ord1 g, Ord a) => Ord (These1 f g a) where compare = compare1+instance (Show1 f, Show1 g, Show a) => Show (These1 f g a) where showsPrec = showsPrec1+instance (Read1 f, Read1 g, Read a) => Read (These1 f g a) where readsPrec = readsPrec1++-------------------------------------------------------------------------------+-- deepseq+-------------------------------------------------------------------------------++#if MIN_VERSION_deepseq(1,4,3)+-- | This instance is available only with @deepseq >= 1.4.3.0@+instance (NFData1 f, NFData1 g) => NFData1 (These1 f g) where+ liftRnf r (This1 x) = liftRnf r x+ liftRnf r (That1 y) = liftRnf r y+ liftRnf r (These1 x y) = liftRnf r x `seq` liftRnf r y++-- | This instance is available only with @deepseq >= 1.4.3.0@+instance (NFData1 f, NFData1 g, NFData a) => NFData (These1 f g a) where+ rnf = rnf1+#endif++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++#ifdef MIN_VERSION_aeson+instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where+ liftToJSON tx tl (This1 a) = Aeson.object [ "This" .= liftToJSON tx tl a ]+ liftToJSON tx tl (That1 b) = Aeson.object [ "That" .= liftToJSON tx tl b ]+ liftToJSON tx tl (These1 a b) = Aeson.object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ]++ liftToEncoding tx tl (This1 a) = Aeson.pairs $ Aeson.pair "This" (liftToEncoding tx tl a)+ liftToEncoding tx tl (That1 b) = Aeson.pairs $ Aeson.pair "That" (liftToEncoding tx tl b)+ liftToEncoding tx tl (These1 a b) = Aeson.pairs $+ Aeson.pair "This" (liftToEncoding tx tl a) `mappend`+ Aeson.pair "That" (liftToEncoding tx tl b)++instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where+ liftParseJSON px pl = Aeson.withObject "These1" (p . HM.toList)+ where+ p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b+ p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b+ p [("This", a)] = This1 <$> liftParseJSON px pl a+ p [("That", b)] = That1 <$> liftParseJSON px pl b+ p _ = fail "Expected object with 'This' and 'That' keys only"++instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where+ toJSON = Aeson.toJSON1+ toEncoding = Aeson.toEncoding1++instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where+ parseJSON = Aeson.parseJSON1+#endif++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++#ifdef MIN_VERSION_QuickCheck+instance (Arbitrary1 f, Arbitrary1 g) => Arbitrary1 (These1 f g) where+ liftArbitrary arb = oneof+ [ This1 <$> liftArbitrary arb+ , That1 <$> liftArbitrary arb+ , These1 <$> liftArbitrary arb <*> liftArbitrary arb+ ]++ liftShrink shr (This1 x) = This1 <$> liftShrink shr x+ liftShrink shr (That1 y) = That1 <$> liftShrink shr y+ liftShrink shr (These1 x y) =+ [ This1 x, That1 y ] +++ [ These1 x' y'+ | (x', y') <- liftShrink2 (liftShrink shr) (liftShrink shr) (x, y)+ ]++instance (Arbitrary1 f, Arbitrary1 g, Arbitrary a) => Arbitrary (These1 f g a) where+ arbitrary = arbitrary1+ shrink = shrink1+#endif
+ src/Data/These.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE CPP #-}+-- | The 'These' type and associated operations. Now enhanced with "Control.Lens" magic!+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}+module Data.These (+ These(..)++ -- * Functions to get rid of 'These'+ , these+ , fromThese+ , mergeThese+ , mergeTheseWith++ -- * Partition+ , partitionThese+ , partitionHereThere++ -- * Distributivity+ --+ -- | This distributivity combinators aren't isomorphisms!+ , distrThesePair+ , undistrThesePair+ , distrPairThese+ , undistrPairThese+ ) where++import Prelude ()+import Prelude.Compat++import Control.DeepSeq (NFData (..))+import Data.Bifoldable (Bifoldable (..))+import Data.Bifunctor (Bifunctor (..))+import Data.Binary (Binary (..))+import Data.Bitraversable (Bitraversable (..))+import Data.Data (Data, Typeable)+import Data.Hashable (Hashable (..))+import Data.Semigroup (Semigroup (..))+import GHC.Generics (Generic)++#if __GLASGOW_HASKELL__ >= 706+import GHC.Generics (Generic1)+#endif++#ifdef MIN_VERSION_aeson+import Data.Aeson (FromJSON (..), ToJSON (..), (.=))++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson (pair)+import qualified Data.HashMap.Strict as HM+#endif++#ifdef MIN_VERSION_assoc+import Data.Bifunctor.Assoc (Assoc (..))+import Data.Bifunctor.Swap (Swap (..))+#endif++#ifdef MIN_VERSION_semigroupoids+import Data.Functor.Bind (Apply (..), Bind (..))+import Data.Semigroup.Bifoldable (Bifoldable1 (..))+import Data.Semigroup.Bitraversable (Bitraversable1 (..))+#endif++#ifdef MIN_VERSION_QuickCheck+import Test.QuickCheck+ (Arbitrary (..), Arbitrary1 (..), Arbitrary2 (..), CoArbitrary (..),+ arbitrary1, oneof, shrink1)+import Test.QuickCheck.Function (Function (..), functionMap)+#endif+++-- $setup+-- >>> import Control.Lens++-- --------------------------------------------------------------------------+-- | The 'These' type represents values with two non-exclusive possibilities.+--+-- This can be useful to represent combinations of two values, where the+-- combination is defined if either input is. Algebraically, the type+-- @'These' A B@ represents @(A + B + AB)@, which doesn't factor easily into+-- sums and products--a type like @'Either' A (B, 'Maybe' A)@ is unclear and+-- awkward to use.+--+-- 'These' has straightforward instances of 'Functor', 'Monad', &c., and+-- behaves like a hybrid error/writer monad, as would be expected.+--+-- For zipping and unzipping of structures with 'These' values, see+-- "Data.Align".+data These a b = This a | That b | These a b+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic+#if __GLASGOW_HASKELL__ >= 706+ , Generic1+#endif+ )++-------------------------------------------------------------------------------+-- Eliminators+-------------------------------------------------------------------------------++-- | Case analysis for the 'These' type.+these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c+these l _ _ (This a) = l a+these _ r _ (That x) = r x+these _ _ lr (These a x) = lr a x++-- | Takes two default values and produces a tuple.+fromThese :: a -> b -> These a b -> (a, b)+fromThese x y = these (`pair` y) (x `pair`) pair where+ pair = (,)++-- | Coalesce with the provided operation.+mergeThese :: (a -> a -> a) -> These a a -> a+mergeThese = these id id++-- | 'bimap' and coalesce results with the provided operation.+mergeTheseWith :: (a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c+mergeTheseWith f g op t = mergeThese op $ bimap f g t++-------------------------------------------------------------------------------+-- Partitioning+-------------------------------------------------------------------------------++-- | Select each constructor and partition them into separate lists.+partitionThese :: [These a b] -> ([a], [b], [(a, b)])+partitionThese [] = ([], [], [])+partitionThese (t:ts) = case t of+ This x -> (x : xs, ys, xys)+ That y -> ( xs, y : ys, xys)+ These x y -> ( xs, ys, (x,y) : xys)+ where+ ~(xs,ys,xys) = partitionThese ts++-- | Select 'here' and 'there' elements and partition them into separate lists.+--+-- @since 0.8+partitionHereThere :: [These a b] -> ([a], [b])+partitionHereThere [] = ([], [])+partitionHereThere (t:ts) = case t of+ This x -> (x : xs, ys)+ That y -> ( xs, y : ys)+ These x y -> (x : xs, y : ys)+ where+ ~(xs,ys) = partitionHereThere ts++-------------------------------------------------------------------------------+-- Distributivity+-------------------------------------------------------------------------------++distrThesePair :: These (a, b) c -> (These a c, These b c)+distrThesePair (This (a, b)) = (This a, This b)+distrThesePair (That c) = (That c, That c)+distrThesePair (These (a, b) c) = (These a c, These b c)++undistrThesePair :: (These a c, These b c) -> These (a, b) c+undistrThesePair (This a, This b) = This (a, b)+undistrThesePair (That c, That _) = That c+undistrThesePair (These a c, These b _) = These (a, b) c+undistrThesePair (This _, That c) = That c+undistrThesePair (This a, These b c) = These (a, b) c+undistrThesePair (That c, This _) = That c+undistrThesePair (That c, These _ _) = That c+undistrThesePair (These a c, This b) = These (a, b) c+undistrThesePair (These _ c, That _) = That c+++distrPairThese :: (These a b, c) -> These (a, c) (b, c)+distrPairThese (This a, c) = This (a, c)+distrPairThese (That b, c) = That (b, c)+distrPairThese (These a b, c) = These (a, c) (b, c)++undistrPairThese :: These (a, c) (b, c) -> (These a b, c)+undistrPairThese (This (a, c)) = (This a, c)+undistrPairThese (That (b, c)) = (That b, c)+undistrPairThese (These (a, c) (b, _)) = (These a b, c)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++++instance (Semigroup a, Semigroup b) => Semigroup (These a b) where+ This a <> This b = This (a <> b)+ This a <> That y = These a y+ This a <> These b y = These (a <> b) y+ That x <> This b = These b x+ That x <> That y = That (x <> y)+ That x <> These b y = These b (x <> y)+ These a x <> This b = These (a <> b) x+ These a x <> That y = These a (x <> y)+ These a x <> These b y = These (a <> b) (x <> y)++instance Functor (These a) where+ fmap _ (This x) = This x+ fmap f (That y) = That (f y)+ fmap f (These x y) = These x (f y)++instance Foldable (These a) where+ foldr _ z (This _) = z+ foldr f z (That x) = f x z+ foldr f z (These _ x) = f x z++instance Traversable (These a) where+ traverse _ (This a) = pure $ This a+ traverse f (That x) = That <$> f x+ traverse f (These a x) = These a <$> f x+ sequenceA (This a) = pure $ This a+ sequenceA (That x) = That <$> x+ sequenceA (These a x) = These a <$> x++instance Bifunctor These where+ bimap f _ (This a ) = This (f a)+ bimap _ g (That x) = That (g x)+ bimap f g (These a x) = These (f a) (g x)++instance Bifoldable These where+ bifold = these id id mappend+ bifoldr f g z = these (`f` z) (`g` z) (\x y -> x `f` (y `g` z))+ bifoldl f g z = these (z `f`) (z `g`) (\x y -> (z `f` x) `g` y)++instance Bitraversable These where+ bitraverse f _ (This x) = This <$> f x+ bitraverse _ g (That x) = That <$> g x+ bitraverse f g (These x y) = These <$> f x <*> g y++instance (Semigroup a) => Applicative (These a) where+ pure = That+ This a <*> _ = This a+ That _ <*> This b = This b+ That f <*> That x = That (f x)+ That f <*> These b x = These b (f x)+ These a _ <*> This b = This (a <> b)+ These a f <*> That x = These a (f x)+ These a f <*> These b x = These (a <> b) (f x)+++instance (Semigroup a) => Monad (These a) where+ return = pure+ This a >>= _ = This a+ That x >>= k = k x+ These a x >>= k = case k x of+ This b -> This (a <> b)+ That y -> These a y+ These b y -> These (a <> b) y+instance (Hashable a, Hashable b) => Hashable (These a b)++-------------------------------------------------------------------------------+-- assoc+-------------------------------------------------------------------------------++#ifdef MIN_VERSION_assoc+-- | @since 0.8+instance Swap These where+ swap (This a) = That a+ swap (That b) = This b+ swap (These a b) = These b a++-- | @since 0.8+instance Assoc These where+ assoc (This (This a)) = This a+ assoc (This (That b)) = That (This b)+ assoc (That c) = That (That c)+ assoc (These (That b) c) = That (These b c)+ assoc (This (These a b)) = These a (This b)+ assoc (These (This a) c) = These a (That c)+ assoc (These (These a b) c) = These a (These b c)++ unassoc (This a) = This (This a)+ unassoc (That (This b)) = This (That b)+ unassoc (That (That c)) = That c+ unassoc (That (These b c)) = These (That b) c+ unassoc (These a (This b)) = This (These a b)+ unassoc (These a (That c)) = These (This a) c+ unassoc (These a (These b c)) = These (These a b) c+#endif++-------------------------------------------------------------------------------+-- deepseq+-------------------------------------------------------------------------------++-- | @since 0.7.1+instance (NFData a, NFData b) => NFData (These a b) where+ rnf (This a) = rnf a+ rnf (That b) = rnf b+ rnf (These a b) = rnf a `seq` rnf b++-------------------------------------------------------------------------------+-- binary+-------------------------------------------------------------------------------++-- | @since 0.7.1+instance (Binary a, Binary b) => Binary (These a b) where+ put (This a) = put (0 :: Int) >> put a+ put (That b) = put (1 :: Int) >> put b+ put (These a b) = put (2 :: Int) >> put a >> put b++ get = do+ i <- get+ case (i :: Int) of+ 0 -> This <$> get+ 1 -> That <$> get+ 2 -> These <$> get <*> get+ _ -> fail "Invalid These index"++-------------------------------------------------------------------------------+-- semigroupoids+-------------------------------------------------------------------------------++#ifdef MIN_VERSION_semigroupoids+instance Bifoldable1 These where+ bifold1 = these id id (<>)++instance Bitraversable1 These where+ bitraverse1 f _ (This x) = This <$> f x+ bitraverse1 _ g (That x) = That <$> g x+ bitraverse1 f g (These x y) = These <$> f x <.> g y++instance (Semigroup a) => Bind (These a) where+ This a >>- _ = This a+ That x >>- k = k x+ These a x >>- k = case k x of+ This b -> This (a <> b)+ That y -> These a y+ These b y -> These (a <> b) y++instance (Semigroup a) => Apply (These a) where+ This a <.> _ = This a+ That _ <.> This b = This b+ That f <.> That x = That (f x)+ That f <.> These b x = These b (f x)+ These a _ <.> This b = This (a <> b)+ These a f <.> That x = These a (f x)+ These a f <.> These b x = These (a <> b) (f x)+#endif++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++#ifdef MIN_VERSION_aeson++-- | @since 0.7.1+instance (ToJSON a, ToJSON b) => ToJSON (These a b) where+ toJSON (This a) = Aeson.object [ "This" .= a ]+ toJSON (That b) = Aeson.object [ "That" .= b ]+ toJSON (These a b) = Aeson.object [ "This" .= a, "That" .= b ]++ toEncoding (This a) = Aeson.pairs $ "This" .= a+ toEncoding (That b) = Aeson.pairs $ "That" .= b+ toEncoding (These a b) = Aeson.pairs $ "This" .= a <> "That" .= b++-- | @since 0.7.1+instance (FromJSON a, FromJSON b) => FromJSON (These a b) where+ parseJSON = Aeson.withObject "These a b" (p . HM.toList)+ where+ p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b+ p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b+ p [("This", a)] = This <$> parseJSON a+ p [("That", b)] = That <$> parseJSON b+ p _ = fail "Expected object with 'This' and 'That' keys only"++-- | @since 0.7.2+instance Aeson.ToJSON2 These where+ liftToJSON2 toa _ _tob _ (This a) = Aeson.object [ "This" .= toa a ]+ liftToJSON2 _toa _ tob _ (That b) = Aeson.object [ "That" .= tob b ]+ liftToJSON2 toa _ tob _ (These a b) = Aeson.object [ "This" .= toa a, "That" .= tob b ]++ liftToEncoding2 toa _ _tob _ (This a) = Aeson.pairs $ Aeson.pair "This" (toa a)+ liftToEncoding2 _toa _ tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)+ liftToEncoding2 toa _ tob _ (These a b) = Aeson.pairs $ Aeson.pair "This" (toa a) <> Aeson.pair "That" (tob b)++-- | @since 0.7.2+instance ToJSON a => Aeson.ToJSON1 (These a) where+ liftToJSON _tob _ (This a) = Aeson.object [ "This" .= a ]+ liftToJSON tob _ (That b) = Aeson.object [ "That" .= tob b ]+ liftToJSON tob _ (These a b) = Aeson.object [ "This" .= a, "That" .= tob b ]++ liftToEncoding _tob _ (This a) = Aeson.pairs $ "This" .= a+ liftToEncoding tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)+ liftToEncoding tob _ (These a b) = Aeson.pairs $ "This" .= a <> Aeson.pair "That" (tob b)++-- | @since 0.7.2+instance Aeson.FromJSON2 These where+ liftParseJSON2 pa _ pb _ = Aeson.withObject "These a b" (p . HM.toList)+ where+ p [("This", a), ("That", b)] = These <$> pa a <*> pb b+ p [("That", b), ("This", a)] = These <$> pa a <*> pb b+ p [("This", a)] = This <$> pa a+ p [("That", b)] = That <$> pb b+ p _ = fail "Expected object with 'This' and 'That' keys only"++-- | @since 0.7.2+instance FromJSON a => Aeson.FromJSON1 (These a) where+ liftParseJSON pb _ = Aeson.withObject "These a b" (p . HM.toList)+ where+ p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b+ p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b+ p [("This", a)] = This <$> parseJSON a+ p [("That", b)] = That <$> pb b+ p _ = fail "Expected object with 'This' and 'That' keys only"+#endif++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++#ifdef MIN_VERSION_QuickCheck+-- | @since 0.7.4+instance Arbitrary2 These where+ liftArbitrary2 arbA arbB = oneof+ [ This <$> arbA+ , That <$> arbB+ , These <$> arbA <*> arbB+ ]++ liftShrink2 shrA _shrB (This x) = This <$> shrA x+ liftShrink2 _shrA shrB (That y) = That <$> shrB y+ liftShrink2 shrA shrB (These x y) =+ [This x, That y] ++ [These x' y' | (x', y') <- liftShrink2 shrA shrB (x, y)]++-- | @since 0.7.4+instance (Arbitrary a) => Arbitrary1 (These a) where+ liftArbitrary = liftArbitrary2 arbitrary+ liftShrink = liftShrink2 shrink++-- | @since 0.7.1+instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where+ arbitrary = arbitrary1+ shrink = shrink1++-- | @since 0.7.1+instance (Function a, Function b) => Function (These a b) where+ function = functionMap g f+ where+ g (This a) = Left a+ g (That b) = Right (Left b)+ g (These a b) = Right (Right (a, b))++ f (Left a) = This a+ f (Right (Left b)) = That b+ f (Right (Right (a, b))) = These a b++-- | @since 0.7.1+instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (These a b)+#endif
+ src/Data/These/Combinators.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE CPP #-}+-- | This module provides+--+-- * specialised versions of class members e.g. 'bitraverseThese'+-- * non-lens variants of "Data.These.Lens" things, e.g 'justHere'+module Data.These.Combinators (+ -- * Specialised combinators+ -- ** Bifunctor+ bimapThese,+ mapHere,+ mapThere,+ -- ** Bitraversable+ bitraverseThese,+ -- ** Associativity and commutativity+ swapThese,+ assocThese,+ unassocThese,++ -- * Other operations+ -- ** preview+ --+ -- |+ -- @+ -- 'justThis' = 'Control.Lens.preview' '_This'+ -- 'justThat' = 'Control.Lens.preview' '_That'+ -- 'justThese' = 'Control.Lens.preview' '_These'+ -- 'justHere' = 'Control.Lens.preview' 'here'+ -- 'justThere' = 'Control.Lens.preview' 'there'+ -- @+ justThis,+ justThat,+ justThese,+ justHere,+ justThere,++ -- ** toListOf+ --+ -- |+ -- @+ -- 'catThis' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_This')+ -- 'catThat' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_That')+ -- 'catThese' = 'Control.Lens.toListOf' ('Control.Lens.folded' . '_These')+ -- 'catHere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'here')+ -- 'catThere' = 'Control.Lens.toListOf' ('Control.Lens.folded' . 'there')+ -- @+ catThis,+ catThat,+ catThese,+ catHere,+ catThere,++ -- * is / has+ --+ -- |+ -- @+ -- 'isThis' = 'Control.Lens.Extra.is' '_This'+ -- 'isThat' = 'Control.Lens.Extra.is' '_That'+ -- 'isThese' = 'Control.Lens.Extra.is' '_These'+ -- 'hasHere' = 'Control.Lens.has' 'here'+ -- 'hasThere' = 'Control.Lens.has' 'there'+ -- @+ isThis,+ isThat,+ isThese,+ hasHere,+ hasThere,++ -- * over / map+ --+ -- @+ -- 'mapThis' = 'Control.Lens.over' '_This'+ -- 'mapThat' = 'Control.Lens.over' '_That'+ -- 'mapThese' = 'Control.Lens.over' '_These'+ -- 'mapHere' = 'Control.Lens.over' 'here'+ -- 'mapThere' = 'Control.Lens.over' 'there'+ -- @+ mapThis,+ mapThat,+ mapThese,+ ) where++import Prelude ()+import Prelude.Compat++import Data.Bifunctor (bimap, first, second)+import Data.Bitraversable (bitraverse)+import Data.Maybe (isJust, mapMaybe)+import Data.These++#ifdef MIN_VERSION_assoc+import Data.Bifunctor.Assoc (assoc, unassoc)+import Data.Bifunctor.Swap (swap)+#endif++-------------------------------------------------------------------------------+-- bifunctors+-------------------------------------------------------------------------------++-- | 'Bifunctor' 'bimap'.+bimapThese :: (a -> c) -> (b -> d) -> These a b -> These c d+bimapThese = bimap++-- | @'mapHere' = 'Control.Lens.over' 'here'@+mapHere :: (a -> c) -> These a b -> These c b+mapHere = first++-- | @'mapThere' = 'Control.Lens.over' 'there'@+mapThere :: (b -> d) -> These a b -> These a d+mapThere = second++-- | 'Bitraversable' 'bitraverse'.+bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d)+bitraverseThese = bitraverse++-------------------------------------------------------------------------------+-- assoc+-------------------------------------------------------------------------------++-- | 'These' is commutative.+--+-- @+-- 'swapThese' . 'swapThese' = 'id'+-- @+--+-- @since 0.8+swapThese :: These a b -> These b a+#ifdef MIN_VERSION_assoc+swapThese = swap+#else+swapThese (This a) = That a+swapThese (That b) = This b+swapThese (These a b) = These b a+#endif++-- | 'These' is associative.+--+-- @+-- 'assocThese' . 'unassocThese' = 'id'+-- 'unassocThese' . 'assocThese' = 'id'+-- @+--+-- @since 0.8+assocThese :: These (These a b) c -> These a (These b c)+#ifdef MIN_VERSION_assoc+assocThese = assoc+#else+assocThese (This (This a)) = This a+assocThese (This (That b)) = That (This b)+assocThese (That c) = That (That c)+assocThese (These (That b) c) = That (These b c)+assocThese (This (These a b)) = These a (This b)+assocThese (These (This a) c) = These a (That c)+assocThese (These (These a b) c) = These a (These b c)+#endif++-- | 'These' is associative. See 'assocThese'.+--+-- @since 0.8+unassocThese :: These a (These b c) -> These (These a b) c+#ifdef MIN_VERSION_assoc+unassocThese = unassoc+#else+unassocThese (This a) = This (This a)+unassocThese (That (This b)) = This (That b)+unassocThese (That (That c)) = That c+unassocThese (That (These b c)) = These (That b) c+unassocThese (These a (This b)) = This (These a b)+unassocThese (These a (That c)) = These (This a) c+unassocThese (These a (These b c)) = These (These a b) c+#endif++-------------------------------------------------------------------------------+-- preview+-------------------------------------------------------------------------------++-- |+--+-- >>> justHere (This 'x')+-- Just 'x'+--+-- >>> justHere (That 'y')+-- Nothing+--+-- >>> justHere (These 'x' 'y')+-- Just 'x'+--+justHere :: These a b -> Maybe a+justHere (This a) = Just a+justHere (That _) = Nothing+justHere (These a _) = Just a++-- |+--+-- >>> justThere (This 'x')+-- Nothing+--+-- >>> justThere (That 'y')+-- Just 'y'+--+-- >>> justThere (These 'x' 'y')+-- Just 'y'+--+justThere :: These a b -> Maybe b+justThere (This _) = Nothing+justThere (That b) = Just b+justThere (These _ b) = Just b++justThis :: These a b -> Maybe a+justThis (This a) = Just a+justThis _ = Nothing++justThat :: These a b -> Maybe b+justThat (That x) = Just x+justThat _ = Nothing++justThese :: These a b -> Maybe (a, b)+justThese (These a x) = Just (a, x)+justThese _ = Nothing++-------------------------------------------------------------------------------+-- toListOf+-------------------------------------------------------------------------------++-- | Select all 'This' constructors from a list.+catThis :: [These a b] -> [a]+catThis = mapMaybe justThis++-- | Select all 'That' constructors from a list.+catThat :: [These a b] -> [b]+catThat = mapMaybe justThat++-- | Select all 'These' constructors from a list.+catThese :: [These a b] -> [(a, b)]+catThese = mapMaybe justThese++catHere :: [These a b] -> [a]+catHere = mapMaybe justHere++catThere :: [These a b] -> [b]+catThere = mapMaybe justThere++-------------------------------------------------------------------------------+-- is+-------------------------------------------------------------------------------++isThis, isThat, isThese :: These a b -> Bool+-- | @'isThis' = 'isJust' . 'justThis'@+isThis = isJust . justThis++-- | @'isThat' = 'isJust' . 'justThat'@+isThat = isJust . justThat++-- | @'isThese' = 'isJust' . 'justThese'@+isThese = isJust . justThese++hasHere, hasThere :: These a b -> Bool+-- | @'hasHere' = 'isJust' . 'justHere'@+hasHere = isJust . justHere++-- | @'hasThere' = 'isJust' . 'justThere'@+hasThere = isJust . justThere++-------------------------------------------------------------------------------+-- over / map+-------------------------------------------------------------------------------++mapThis :: (a -> a) -> These a b -> These a b+mapThis f (This x) = This (f x)+mapThis _ y = y++mapThat :: (b -> b) -> These a b -> These a b+mapThat f (That x) = That (f x)+mapThat _ y = y++mapThese :: ((a, b) -> (a, b)) -> These a b -> These a b+mapThese f (These x y) = uncurry These (curry f x y)+mapThese _ z = z
− test/Tests.hs
@@ -1,480 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-module Main (main) where--import Prelude ()-import Prelude.Compat--import Control.Applicative (ZipList (..))-import Control.Lens (folded, toListOf)-import Control.Monad (join)-import Data.Bifunctor (bimap)-import Data.Foldable (toList)-import Data.Functor.Compose (Compose (..))-import Data.Functor.Identity (Identity (..))-import Data.HashMap.Strict (HashMap)-import Data.IntMap (IntMap)-import Data.List (nub)-import Data.List.NonEmpty (NonEmpty)-import Data.Map (Map)-import Data.Maybe (mapMaybe)-import Data.Semigroup (Semigroup (..))-import Data.Sequence (Seq)-import Data.Traversable (fmapDefault, foldMapDefault)-import Test.QuickCheck- (Arbitrary (..), CoArbitrary (..), Property, elements, once, (.&&.),- (===))-import Test.QuickCheck.Function (Fun (..))-import Test.QuickCheck.Instances ()-import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.QuickCheck (testProperty)--import qualified Data.Aeson as Aeson-import qualified Data.Binary as Binary-import qualified Data.Functor.Product as P-import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Tree as T-import qualified Data.Vector as V-import qualified Test.Tasty.QuickCheck as QC--import Data.Align-import Data.Align.Indexed-import Data.Align.Key-import Data.These-import Data.These.Combinators-import Data.These.Lens---- For old GHC to work-data Proxy (a :: * -> *) = Proxy--main :: IO ()-main = defaultMain tests--tests :: TestTree-tests = testGroup "Tests"- [ theseProps- , alignProps- , alignWithKeyProps- , crosswalkProps- , testGroup "Semigroup"- [ semigroupLaws "These" (These "x" "y")- , semigroupLaws "SearchResult" (ScannedAndFound "x" "y")- , monoidLaws "List" "x" -- to disallow- ]- ]--theseProps :: TestTree-theseProps = testGroup "These"- [ functorProps- , traversableProps- , testProperty "Map value laziness property" mapStrictnessProp- , testProperty "IntMap value laziness property" intmapStrictnessProp- , aesonProps- , binaryProps- ]--crosswalkProps :: TestTree-crosswalkProps = testGroup "Crosswalk"- [ crosswalkLaws "[]" (Proxy :: Proxy [])- -- , crosswalkLaws "Identity" (Proxy :: Proxy Identity)- , crosswalkLaws "Maybe" (Proxy :: Proxy Maybe)- , crosswalkLaws "These" (Proxy :: Proxy (These Int))- , crosswalkLaws "Seq" (Proxy :: Proxy Seq)- , crosswalkLaws "Vector" (Proxy :: Proxy V.Vector)- , crosswalkLaws "(,) Int" (Proxy :: Proxy ((,) Int))- , crosswalkLaws "Compose [] []" (Proxy :: Proxy (Compose [] []))- ]--alignProps :: TestTree-alignProps = testGroup "Align"- [ dataAlignLaws "[]" (CAlign :: C [])- , dataAlignLaws "HashMap String" (CAlign :: C (HashMap String))- , dataAlignLaws "IntMap" (CAlign :: C IntMap)- , dataAlignLaws "Map Char" (CAlign :: C (Map Char))- , dataAlignLaws "Maybe" (CAlign :: C Maybe)- , dataAlignLaws "Product [] Maybe" (CAlign :: C (P.Product [] Maybe))- , dataAlignLaws "Compose [] Maybe" (CAlign :: C (Compose [] Maybe))- , dataAlignLaws "Seq" (CAlign :: C Seq)- , dataAlignLaws "Vector" (CAlign :: C V.Vector)- , dataAlignLaws "ZipList" (CAlign :: C ZipList)- , dataAlignLaws "Tree" (CSemialign :: C T.Tree)- , dataAlignLaws "NonEmpty" (CSemialign :: C NonEmpty)-- -- , dataAlignLaws "WrongMap" (CAlign :: C (WrongMap Char))- -- weird objects:- -- , dataAlignLaws "Const String" (CAlign :: C (Const String))- , dataAlignLaws "R" (CAlign :: C R)- -- , dataAlignLaws "Weirdmap" (CAlign :: C (WeirdMap Char))- ]--alignWithKeyProps :: TestTree-alignWithKeyProps = testGroup "AlignWithKey / AlignWithIndex"- [ testProperty "example" $ once $ exampleK- , testProperty "example" $ once $ exampleI- ]- where- exampleK = alignWithKey (,) "foo" "quux" === exampleV- exampleI = ialign (,) "foo" "quux" === exampleV-- exampleV =- [ (0, These 'f' 'q')- , (1, These 'o' 'u')- , (2, These 'o' 'u')- , (3, That 'x')- ]---- Even the `align` is/was defined using strict combinators, this will still work:-mapStrictnessProp :: [Int] -> [Int] -> Bool-mapStrictnessProp lkeys rkeys = length (nub lkeys) <= Map.size (lhs `align` rhs)- where lhs = Map.fromList $ fmap (,loop) lkeys- rhs = Map.fromList $ fmap (,loop) rkeys-- loop :: Int- loop = error "break"--intmapStrictnessProp :: [Int] -> [Int] -> Bool-intmapStrictnessProp lkeys rkeys = length (nub lkeys) <= IntMap.size (lhs `align` rhs)- where lhs = IntMap.fromList $ fmap (,loop) lkeys- rhs = IntMap.fromList $ fmap (,loop) rkeys-- loop :: Int- loop = error "break"--functorIdentityProp :: (Functor f, Eq (f a), Show (f a)) => f a -> Property-functorIdentityProp x = fmap id x === x--functorCompositionProp :: (Functor f, Show (f c), Eq (f c)) => f a -> Fun a b -> Fun b c -> Property-functorCompositionProp x (Fun _ f) (Fun _ g) = fmap g (fmap f x) === fmap (g . f) x--functorProps :: TestTree-functorProps = testGroup "Functor"- [ QC.testProperty "identity" (functorIdentityProp :: These Int Bool -> Property)- , QC.testProperty "composition" (functorCompositionProp :: These Int Int -> Fun Int Int -> Fun Int Int -> Property)- ]--traversableIdentityProp :: (Traversable t, Eq (t a), Show (t a)) => t a -> Property-traversableIdentityProp x = traverse Identity x === Identity x--traversableCompositionProp :: (Traversable t, Applicative g, Applicative f, Show (Compose f g (t b)), Eq (Compose f g (t b)))- => t a1 -> Fun a1 (f a) -> Fun a (g b) -> Property-traversableCompositionProp x (Fun _ f) (Fun _ g) = traverse (Compose . fmap g . f) x === (Compose . fmap (traverse g) . traverse f $ x)--traversableFunctorProp :: (Traversable f, Show (f b), Eq (f b)) => f a -> Fun a b -> Property-traversableFunctorProp x (Fun _ f) = fmap f x === fmapDefault f x--traversableFoldableProp :: (Monoid m, Traversable t, Show m, Eq m) => t a -> Fun a m -> Property-traversableFoldableProp x (Fun _ f) = foldMap f x === foldMapDefault f x--traversableProps :: TestTree-traversableProps = testGroup "Traversable"- [ QC.testProperty "identity" (traversableIdentityProp :: These Int Bool -> Property)- , QC.testProperty "composition" (traversableCompositionProp :: These Bool Int -> Fun Int (Maybe Int) -> Fun Int (Either Bool Int) -> Property)- , QC.testProperty "functor" (traversableFunctorProp :: These Bool Int -> (Fun Int Int) -> Property)- , QC.testProperty "foldable" (traversableFoldableProp :: These Bool Int -> (Fun Int [Bool]) -> Property)- ]------------------------------------------------------------------------------------ Align laws------------------------------------------------------------------------------------ Data.Align--data C f where- CSemialign :: Semialign f => C f- CAlign :: Align f => C f---- (\`align` nil) = fmap This--- (nil \`align`) = fmap That--- join align = fmap (join These)--- align (f \<$> x) (g \<$> y) = bimap f g \<$> align x y--- alignWith f a b = f \<$> align a b------ We also require a sixth property, when f is Foldable.-dataAlignLaws- :: forall (f :: * -> *).- ( Foldable f- , Eq (f (These Int Int))- , Show (f (These Int Int))- , Eq (f (These Int (These Int Int)))- , Show (f (These Int (These Int Int)))- , CoArbitrary (These Int Int)- , Arbitrary (f Int)- , Eq (f Int)- , Show (f Int)- )- => String- -> C f- -> TestTree-dataAlignLaws name p =- testGroup ("Data.Align laws: " <> name) props- where- props = case p of- CSemialign -> semialignProps- CAlign -> semialignProps ++ alignLaws-- semialignProps :: Semialign f => [TestTree]- semialignProps =- [ QC.testProperty "join" joinProp- , QC.testProperty "bimap" bimapProp- , QC.testProperty "alignWith" alignWithProp- , QC.testProperty "assoc" assocProp- , QC.testProperty "alignToList" alignToListProp- ]-- alignLaws :: Align f => [TestTree]- alignLaws =- [ QC.testProperty "right identity" rightIdentityProp- , QC.testProperty "left identity" leftIdentityProp- ]-- rightIdentityProp :: Align f => f Int -> Property- rightIdentityProp xs = (xs `align` (nil :: f Int)) === fmap This xs-- leftIdentityProp :: Align f => f Int -> Property- leftIdentityProp xs = ((nil :: f Int) `align` xs) === fmap That xs-- joinProp :: Semialign f => f Int -> Property- joinProp xs = join align xs === fmap (join These) xs-- bimapProp :: Semialign f => f Int -> f Int -> Fun Int Int -> Fun Int Int -> Property- bimapProp xs ys (Fun _ f) (Fun _ g) =- align (f <$> xs) (g <$> ys) === (bimap f g <$> align xs ys)-- alignWithProp :: Semialign f => f Int -> f Int -> Fun (These Int Int) Int -> Property- alignWithProp xs ys (Fun _ f) =- alignWith f xs ys === (f <$> align xs ys)-- assocProp :: Semialign f => f Int -> f Int -> f Int -> Property- assocProp xs ys zs = lhs === fmap assocThese rhs- where- rhs = (xs `align` ys) `align` zs- lhs = xs `align` (ys `align` zs)-- alignToListProp :: Semialign f => f Int -> f Int -> Property- alignToListProp xs ys =- toList xs === toListOf (folded . here) xys- .&&.- toList xs === mapMaybe justHere (toList xys)- .&&.- toList ys === toListOf (folded . there) xys- where- xys = align xs ys-------------------------------------------------------------------------------- WrongMap doesn't satisfy Align laws----------------------------------------------------------------------------------newtype WrongMap k v = WM (Map k v) deriving (Eq, Ord, Show, Functor, Foldable)--instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (WrongMap k v) where- arbitrary = WM <$> arbitrary- shrink (WM m) = WM <$> shrink m--instance Ord k => Align (WrongMap k) where- nil = WM Map.empty--instance Ord k => Semialign (WrongMap k) where- align (WM x) (WM y)- | Map.null y = WM $ This <$> x- | Map.null x = WM $ That <$> y- | otherwise = WM $ Map.intersectionWith These x y------------------------------------------------------------------------------------ WeirdMap------------------------------------------------------------------------------------ | Sequence-like __invalid__ 'Align' instance for Map.------ Satisfies first five laws;--- Doesn't satisfy /assoc/ or /toList/ laws.----newtype WeirdMap k v = WeirdMap (Map k v)- deriving (Eq, Ord, Show, Functor, Foldable)--instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (WeirdMap k v) where- arbitrary = WeirdMap <$> arbitrary- shrink (WeirdMap m) = WeirdMap <$> shrink m--instance Ord k => Align (WeirdMap k) where- nil = WeirdMap Map.empty--instance Ord k => Semialign (WeirdMap k) where- alignWith f (WeirdMap x) (WeirdMap y) = WeirdMap $ Map.fromList $- alignWith g (Map.toList x) (Map.toList y)- where- g (This (k, a)) = (k, f (This a))- g (That (k, a)) = (k, f (That a))- g (These (k, a) (_, b)) = (k, f (These a b))------------------------------------------------------------------------------------ Const is invalid Align with Monoid, we need Idemporent monoid!----------------------------------------------------------------------------------{--instance Monoid a => Align (Const a) where- nil = Const mempty--instance Monoid a => Semialign (Const a) where- align (Const a) (Const b) = Const (mappend a b)--}------------------------------------------------------------------------------------ R does satisfy Align laws, though is weird--- https://github.com/isomorphism/these/issues/96----------------------------------------------------------------------------------newtype R a = Nest [[a]]- deriving (Show, Eq, Ord, Functor, Foldable)--instance Align R where- nil = Nest []--instance Semialign R where- align (Nest ass) (Nest bss)- | null ass = That <$> Nest bss- | null bss = This <$> Nest ass- | shape ass == shape bss = Nest $ zipWith (zipWith These) ass bss- | otherwise = Nest [align (concat ass) (concat bss)]- where- shape = fmap (() <$)--instance Arbitrary a => Arbitrary (R a) where- arbitrary = Nest <$> arbitrary- shrink (Nest xss) = Nest <$> shrink xss--data Index = I1 | I2 | I3 | I4- deriving (Eq, Ord, Show, Enum, Bounded)--instance Arbitrary Index where- arbitrary = elements [minBound .. maxBound]- shrink I1 = []- shrink I2 = [I1]- shrink I3 = [I1, I2]- shrink I4 = [I1, I2, I3]------------------------------------------------------------------------------------ Crosswalk laws----------------------------------------------------------------------------------crosswalkLaws- :: forall (t :: * -> *).- ( Crosswalk t- , Arbitrary (t Int)- , Eq (t Int), Show (t Int)- )- => String- -> Proxy t- -> TestTree-crosswalkLaws name _ = testGroup ("Data.CrossWalk laws: " <> name)- [ QC.testProperty "crosswalk (const nil) = const nil" firstLaw- , QC.testProperty "crosswalk f = sequenceL . fmap f" secondLaw- ]- where- -- f = Map Index- -- a, b = Int- firstLaw :: t Int -> Property- firstLaw x = lhs === rhs- where- lhs = crosswalk (const nil) x- rhs = const nil x :: Map Index (t Int)-- secondLaw :: Fun Int (Map Index Int) -> t Int -> Property- secondLaw (Fun _ f) x = lhs === rhs- where- lhs = crosswalk f x- rhs = sequenceL . fmap f $ x------------------------------------------------------------------------------------ aeson----------------------------------------------------------------------------------aesonProps :: TestTree-aesonProps = testGroup "aeson"- [ testProperty "roundtrip / direct" prop1- , testProperty "roundtrip / toJSON" prop2- ]- where- prop1 :: These Int String -> Property- prop1 x = Just x === Aeson.decode (Aeson.encode x)-- prop2 :: These Int String -> Property- prop2 x = Just x === Aeson.decode (Aeson.encode $ Aeson.toJSON x)------------------------------------------------------------------------------------ binary----------------------------------------------------------------------------------binaryProps :: TestTree-binaryProps = testProperty "binary / roundtrip" prop- where- prop :: These Int String -> Property- prop x = x === Binary.decode (Binary.encode x)------------------------------------------------------------------------------------ SearchResult----------------------------------------------------------------------------------semigroupLaws- :: forall a. (Semigroup a, Show a, Eq a, Arbitrary a)- => String -> a -> TestTree-semigroupLaws name _ = testGroup ("Semigroup: " ++ name)- [ QC.testProperty "associativity" assocProp- ]- where- assocProp :: a -> a -> a -> Property- assocProp x y z = (x <> y) <> z === x <> (y <> z)--monoidLaws- :: forall a. (Monoid a, Show a, Eq a, Arbitrary a)- => String -> a -> TestTree-monoidLaws name _ = testGroup ("Monoid: " ++ name)- [ QC.testProperty "associativity" assocProp- , QC.testProperty "left-identity" idLeftProp- , QC.testProperty "right-identity" idRightProp- ]- where- assocProp :: a -> a -> a -> Property- assocProp x y z = (x `mappend` y) `mappend` z === x `mappend` (y `mappend` z)-- idLeftProp :: a -> Property- idLeftProp x = mappend mempty x === x-- idRightProp :: a -> Property- idRightProp x = mappend x mempty === x---- | Either a, or b, or both a and b------ See https://github.com/isomorphism/these/issues/80-data SearchResult a b = Scanned a | Found b | ScannedAndFound a b- deriving (Eq, Ord, Show)--instance (Arbitrary a, Arbitrary b) => Arbitrary (SearchResult a b) where- arbitrary = srFromThese <$> arbitrary--srFromThese :: These a b -> SearchResult a b-srFromThese (This a) = Scanned a-srFromThese (That b) = Found b-srFromThese (These a b) = ScannedAndFound a b---- | Accumulate 'a's from left to right, until one 'b' is found-instance Semigroup a => Semigroup (SearchResult a b) where- ScannedAndFound a b <> _ = ScannedAndFound a b- Found b <> _ = Found b- Scanned a <> Scanned a' = Scanned (a <> a')- Scanned a <> Found b = ScannedAndFound a b- Scanned a <> ScannedAndFound a' b = ScannedAndFound (a <> a') b--{---- almost lawful-instance Monoid a => Monoid (SearchResult a b) where- mappend = (<>)- mempty = Scanned mempty--}
these.cabal view
@@ -1,122 +1,112 @@ cabal-version: >=1.10 name: these-version: 0.8.1-synopsis:- An either-or-both data type & a generalized 'zip with padding' typeclass-+version: 1+synopsis: An either-or-both data type. homepage: https://github.com/isomorphism/these license: BSD3 license-file: LICENSE-author: C. McCann-maintainer: oleg.grenrus@iki.fi-category: Data,Control+author: C. McCann, Oleg Grenrus+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+category: Data, These build-type: Simple-extra-source-files:- README.md- CHANGELOG.md-+extra-source-files: CHANGELOG.md description: This package provides a data type @These a b@ which can hold a value of either type or values of each type. This is usually thought of as an "inclusive or" type (contrasting @Either a b@ as "exclusive or") or as an "outer join" type (contrasting @(a, b)@ as "inner join"). .- The major use case of this is provided by the @Align@ class, representing a- generalized notion of "zipping with padding" that combines structures without- truncating to the size of the smaller input.+ @+ data These a b = This a | That b | These a b+ @ .- Also included is @ChronicleT@, a monad transformer based on the Monad instance- for @These a@, along with the usual monad transformer bells and whistles.+ Since version 1, this package was split into parts: .- For a dependency light version, check <https://hackage.haskell.org/package/data-or> package.+ * <https://hackage.haskell.org/package/semialign semialign> For @Align@ and @Zip@ type-classes.+ .+ * <https://hackage.haskell.org/package/semialign-indexed semialign-indexed> For @SemialignWithIndex@ class, providing @ialignWith@ and @izipWith@.+ .+ * <https://hackage.haskell.org/package/these-lens these-lens> For lens combinators.+ .+ * <http://hackage.haskell.org/package/monad-chronicle monad-chronicle> For transformers variant of @These@. tested-with:- ghc ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.4+ GHC ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 source-repository head type: git location: https://github.com/isomorphism/these.git +flag aeson+ description: Build with aeson dependency+ manual: True+ default: True++flag assoc+ description: Build with assoc dependency+ manual: True+ default: True++flag semigroupoids+ description: Build with semigroupoids dependency+ manual: True+ default: True++flag QuickCheck+ description: Build with QuickCheck dependency+ manual: True+ default: True+ library default-language: Haskell2010 ghc-options: -Wall++ if impl(ghc >=8.0)+ ghc-options: -Wno-trustworthy-safe++ hs-source-dirs: src exposed-modules:- Control.Monad.Chronicle- Control.Monad.Chronicle.Class- Control.Monad.Trans.Chronicle- Data.Align- Data.Align.Indexed- Data.Align.Key Data.Functor.These Data.These- Data.These.Lens Data.These.Combinators -- ghc boot libs build-depends:- assoc >=1 && <1.1- , base >=4.5.1.0 && <4.13- , binary >=0.5.1.0 && <0.10- , containers >=0.4.2.1 && <0.7- , deepseq >=1.3.0.0 && <1.5- , mtl >=2.1.3 && <2.3- , transformers >=0.3.0.0 && <0.6+ base >=4.5.1.0 && <4.13+ , binary >=0.5.1.0 && <0.10+ , deepseq >=1.3.0.0 && <1.5 -- other dependencies build-depends:- aeson >=1.4.2.0 && <1.5- , base-compat >=0.10.5 && <0.11- , bifunctors >=5.5.3 && <5.6- , data-default-class >=0.1.2.0 && <0.2- , hashable >=1.2.7.0 && <1.4- , keys >=3.12.1 && <3.13- , lens >=4.17 && <4.18- , tagged >=0.8.6 && <0.9- , QuickCheck >=2.12.6.1 && <2.14- , semigroupoids >=5.3.1 && <5.4- , transformers-compat >=0.6.2 && <0.7- , unordered-containers >=0.2.8.0 && <0.3- , vector >=0.12.0.2 && <0.13- , vector-instances >=3.4 && <3.5+ base-compat >=0.10.5 && <0.11+ , hashable >=1.2.7.0 && <1.4 if impl(ghc <7.5) build-depends: ghc-prim + if !impl(ghc >=8.2)+ build-depends: bifunctors >=5.5.4 && <5.6+ if !impl(ghc >=8.0)- build-depends: semigroups >=0.18.5 && <0.20+ build-depends:+ semigroups >=0.18.5 && <0.20+ , transformers >=0.3.0.0 && <0.6+ , transformers-compat >=0.6.5 && <0.7 - -- Ensure Data.Functor.Classes is always available- if impl(ghc >=7.10)- build-depends: transformers >=0.4.2.0+ -- Ensure Data.Functor.Classes is always available+ if impl(ghc >=7.10)+ build-depends: transformers >=0.4.2.0 -test-suite test- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: Tests.hs- hs-source-dirs: test- ghc-options: -Wall+ if flag(aeson)+ build-depends:+ aeson >=1.4.2.0 && <1.5+ , unordered-containers >=0.2.8.0 && <0.3 - -- library constrained dependencies- build-depends:- aeson- , base- , base-compat- , bifunctors- , binary- , containers- , hashable- , lens- , QuickCheck- , these- , transformers- , unordered-containers- , vector+ if flag(assoc)+ build-depends: assoc >=1 && <1.1 - if !impl(ghc >=8.0)- build-depends: semigroups+ if flag(semigroupoids)+ build-depends: semigroupoids >=5.3.2 && <5.4 - -- additional dependencies- build-depends:- quickcheck-instances >=0.3.15 && <0.4- , tasty >=1.2 && <1.3- , tasty-quickcheck >=0.10 && <0.11+ if flag(quickcheck)+ build-depends: QuickCheck >=2.12.6.1 && <2.14