these-0.7.6/0000755000000000000000000000000007346545000011025 5ustar0000000000000000these-0.7.6/CHANGELOG.md0000755000000000000000000000256507346545000012651 0ustar0000000000000000# 0.7.6 - Tigthen lower bounds - Add dependency on `lens` - Add `assoc`, `reassoc`, `swap` and `Swapped` instance - Add since annotations for things added in 0.7.x - Add `AlignWithKey ZipList` instance - Add `Data.Align.Indexed` module. - Add `Data.Functor.These` with `These1` data type. - Add associativity law - Add `toList` property to enforce "align"-feel. - `Map` and `IntMap` `Align` instances implemented using merge combinators (when available) # 0.7.5 - Add `Compose` and `(,)` `Crosswalk` instances - Add `bitraverseThese` - GHC-8.6 support # 0.7.4 - `QuickCheck-2.10` support: `Arbitrary1/2` instances - GHC-8.2 support # 0.7.3 - Add `salign :: (Align f, Semigroup a) => f a -> f a -> f a` # 0.7.2 - Support `aeson-1`: add `FromJSON1`, `FromJSON2` `ToJSON1`, and `ToJSON2` `These` instances. # 0.7.1 - Add `AlignWithKey` in `Data.Align.Key` (added dependency `keys`) - Add `These` instances for - `binary`: `Binary` - `aeson`: `FromJSON`, `ToJSON` - `QuickCheck`: `Arbitrary`, `CoArbitrary`, `Function` - `deepseq`: `NFData` # 0.7 - Breaking change: Generalized `Monad`, `Applicative` instances of `These` and `Chronicle` to require only a `Semigroup` constraint - More efficient `Align Seq` implementation - Add `Crosswalk Seq` and `Vector` instances # 0.6.2.1 - Support quickcheck-instances-0.3.12 (tests) # 0.6.2.0 - Add support to bifunctors-5.1 these-0.7.6/Control/Monad/0000755000000000000000000000000007346545000013503 5ustar0000000000000000these-0.7.6/Control/Monad/Chronicle.hs0000644000000000000000000000200407346545000015741 0ustar0000000000000000----------------------------------------------------------------------------- -- | 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 these-0.7.6/Control/Monad/Chronicle/0000755000000000000000000000000007346545000015411 5ustar0000000000000000these-0.7.6/Control/Monad/Chronicle/Class.hs0000644000000000000000000002274207346545000017021 0ustar0000000000000000{-# 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 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 = mapThat 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 = mapThis 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 these-0.7.6/Control/Monad/Trans/0000755000000000000000000000000007346545000014572 5ustar0000000000000000these-0.7.6/Control/Monad/Trans/Chronicle.hs0000644000000000000000000002034507346545000017040 0ustar0000000000000000{-# 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 -- -------------------------------------------------------------------------- -- | 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 $ mapThis f `liftM` runChronicleT m these-0.7.6/Data/0000755000000000000000000000000007346545000011676 5ustar0000000000000000these-0.7.6/Data/Align.hs0000644000000000000000000003654007346545000013274 0ustar0000000000000000{-# 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 ( 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.Maybe (catMaybes) import Data.Semigroup (Semigroup (..)) import Data.Sequence (Seq) 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.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.Map.Merge.Lazy as Map import qualified Data.IntMap.Merge.Lazy as IntMap #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: @nil@ and either @align@ or @alignWith@. -- -- == Laws: -- -- @ -- (\`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 -- align (align x y) z = fmap assoc (align x (align 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) => Align f where -- | An empty strucutre. @'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 -- | 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 nil , (align | alignWith) #-} #endif {-# 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 #-} instance Align Maybe where nil = Nothing 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 = [] align xs [] = This <$> xs align [] ys = That <$> ys align (x:xs) (y:ys) = These x y : align xs ys instance Align ZipList where nil = ZipList [] align (ZipList xs) (ZipList ys) = ZipList (align xs ys) instance Align Seq where nil = Seq.empty 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) instance (Ord k) => Align (Map k) where nil = Map.empty #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 #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 instance (Align f, Align g) => Align (Product f g) where nil = Pair nil nil align (Pair a b) (Pair c d) = Pair (align a c) (align b d) -- Based on the Data.Vector.Fusion.Stream.Monadic zipWith implementation instance Monad m => Align (Stream m) where nil = Stream.empty #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 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 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 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" -- | 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) these-0.7.6/Data/Align/0000755000000000000000000000000007346545000012730 5ustar0000000000000000these-0.7.6/Data/Align/Indexed.hs0000644000000000000000000000304707346545000014650 0ustar0000000000000000{-# 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) 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) import qualified Data.Align.Key as Key -- | Keyed version of 'Align'. -- -- @since 0.7.6 class (FunctorWithIndex i f, Align 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 instance AlignWithIndex () Maybe where ialign = Key.alignWithKey instance AlignWithIndex Int [] where ialign = Key.alignWithKey instance AlignWithIndex Int ZipList where ialign = Key.alignWithKey instance AlignWithIndex Int Seq where ialign = Key.alignWithKey instance AlignWithIndex Int IntMap where ialign = Key.alignWithKey instance Ord k => AlignWithIndex k (Map k) where ialign = Key.alignWithKey instance (Eq k, Hashable k) => AlignWithIndex k (HashMap k) where ialign = Key.alignWithKey instance AlignWithIndex Int Vector where ialign = Key.alignWithKey these-0.7.6/Data/Align/Key.hs0000644000000000000000000000225607346545000014021 0ustar0000000000000000----------------------------------------------------------------------------- -- | 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, Align 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 these-0.7.6/Data/Functor/0000755000000000000000000000000007346545000013316 5ustar0000000000000000these-0.7.6/Data/Functor/These.hs0000644000000000000000000002226407346545000014730 0ustar0000000000000000{-# 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 these-0.7.6/Data/These.hs0000644000000000000000000004051107346545000013303 0ustar0000000000000000----------------------------------------------------------------------------- -- | 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 -- * Traversals , here, there -- * Half selections , justHere , justThere -- * Prisms , _This, _That, _These -- * Case selections , justThis , justThat , justThese , catThis , catThat , catThese , partitionThese -- * Case predicates , isThis , isThat , isThese -- * Map operations , mapThese , mapThis , mapThat , bitraverseThese -- * Associativity and commutativity , swap , assoc , reassoc ) where import Prelude () import Prelude.Compat import Control.DeepSeq (NFData (..)) import Control.Lens (Prism', Swapped (..), iso, prism) import Data.Aeson (FromJSON (..), ToJSON (..), (.=)) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..)) 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.Maybe (isJust, mapMaybe) 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) -- | 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 (This a ) = (a, x) fromThese a _ (That x ) = (a, x) fromThese _ _ (These a x) = (a, x) -- | 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 $ mapThese f g t -- | 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 -- | @'justHere' = 'Control.Lens.preview' 'here'@ -- -- >>> 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' = 'Control.Lens.preview' 'there'@ -- -- >>> 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 -- | 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))) -- | @'justThis' = 'Control.Lens.preview' '_This'@ justThis :: These a b -> Maybe a justThis (This a) = Just a justThis _ = Nothing -- | @'justThat' = 'Control.Lens.preview' '_That'@ justThat :: These a b -> Maybe b justThat (That x) = Just x justThat _ = Nothing -- | @'justThese' = 'Control.Lens.preview' '_These'@ justThese :: These a b -> Maybe (a, b) justThese (These a x) = Just (a, x) justThese _ = Nothing 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 -- | 'Bifunctor' map. mapThese :: (a -> c) -> (b -> d) -> These a b -> These c d mapThese f _ (This a ) = This (f a) mapThese _ g (That x) = That (g x) mapThese f g (These a x) = These (f a) (g x) -- | 'Bitraversable'. -- -- @since 0.7.5 bitraverseThese :: Applicative f => (a -> f c) -> (b -> f d) -> These a b -> f (These c d) bitraverseThese f _ (This x) = This <$> f x bitraverseThese _ g (That x) = That <$> g x bitraverseThese f g (These x y) = These <$> f x <*> g y -- | @'mapThis' = 'Control.Lens.over' 'here'@ mapThis :: (a -> c) -> These a b -> These c b mapThis f = mapThese f id -- | @'mapThat' = 'Control.Lens.over' 'there'@ mapThat :: (b -> d) -> These a b -> These a d mapThat f = mapThese id f -- | 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 -- | Select each constructor and partition them into separate lists. partitionThese :: [These a b] -> ( [(a, b)], ([a], [b]) ) partitionThese [] = ([], ([], [])) partitionThese (These x y:xs) = first ((x, y):) $ partitionThese xs partitionThese (This x :xs) = second (first (x:)) $ partitionThese xs partitionThese (That y:xs) = second (second (y:)) $ partitionThese xs -- | 'These' is commutative. -- -- @ -- 'swap' . 'swap' = 'id' -- @ -- -- @since 0.7.6 swap :: These a b -> These b a swap (This a) = That a swap (That b) = This b swap (These a b) = These b a -- | 'These' is associative. -- -- @ -- 'assoc' . 'reassoc' = 'id' -- 'reassoc' . 'assoc' = 'id' -- @ -- -- @since 0.7.6 assoc :: These a (These b c) -> These (These a b) c assoc (This a) = This (This a) assoc (That (This b)) = This (That b) assoc (That (That c)) = That c assoc (That (These b c)) = These (That b) c assoc (These a (This b)) = This (These a b) assoc (These a (That c)) = These (This a) c assoc (These a (These b c)) = These (These a b) c -- | 'These is associative. See 'assoc'. -- -- @since 0.7.6 reassoc :: These (These a b) c -> These a (These b c) reassoc (This (This a)) = This a reassoc (This (That b)) = That (This b) reassoc (That c) = That (That c) reassoc (These (That b) c) = That (These b c) reassoc (This (These a b)) = These a (This b) reassoc (These (This a) c) = These a (That c) reassoc (These (These a b) c) = These a (These 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 = mapThese first = mapThis second = mapThat 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 = bitraverseThese 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) these-0.7.6/LICENSE0000644000000000000000000000275307346545000012041 0ustar0000000000000000Copyright (c)2012, C. McCann All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of C. McCann nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. these-0.7.6/README.md0000755000000000000000000001056707346545000012320 0ustar0000000000000000These — an either-or-both data type ==================================== [![Build Status](https://secure.travis-ci.org/isomorphism/these.svg)](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 ----------- ``` elliott, you should think of some more instances for Bicrosswalk one of these days cmccann: Does it have any instances? 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. these-0.7.6/Setup.hs0000644000000000000000000000005607346545000012462 0ustar0000000000000000import Distribution.Simple main = defaultMain these-0.7.6/test/0000755000000000000000000000000007346545000012004 5ustar0000000000000000these-0.7.6/test/Tests.hs0000644000000000000000000003775407346545000013462 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# 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.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.Vector as V import qualified Test.Tasty.QuickCheck as QC import Data.Align import Data.Align.Indexed import Data.Align.Key import Data.These -- 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 "[]" (Proxy :: Proxy []) , dataAlignLaws "HashMap String" (Proxy :: Proxy (HashMap String)) , dataAlignLaws "IntMap" (Proxy :: Proxy IntMap) , dataAlignLaws "Map Char" (Proxy :: Proxy (Map Char)) , dataAlignLaws "Maybe" (Proxy :: Proxy Maybe) , dataAlignLaws "Product [] Maybe" (Proxy :: Proxy (P.Product [] Maybe)) , dataAlignLaws "Seq" (Proxy :: Proxy Seq) , dataAlignLaws "Vector" (Proxy :: Proxy V.Vector) , dataAlignLaws "ZipList" (Proxy :: Proxy ZipList) -- , dataAlignLaws "WrongMap" (Proxy :: Proxy (WrongMap Char)) -- weird objects: -- , dataAlignLaws "Const String" (Proxy :: Proxy (Const String)) , dataAlignLaws "R" (Proxy :: Proxy R) -- , dataAlignLaws "Weirdmap" (Proxy :: Proxy (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 -- (\`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 :: * -> *). ( Align f, Foldable f , Eq (f (These Int Int)) , Show (f (These Int Int)) , Eq (f (These (These Int Int) Int)) , Show (f (These (These Int Int) Int)) , CoArbitrary (These Int Int) , Arbitrary (f Int) , Eq (f Int) , Show (f Int)) => String -> Proxy f -> TestTree dataAlignLaws name _ = testGroup ("Data.Align laws: " <> name) [ QC.testProperty "right identity" rightIdentityProp , QC.testProperty "left identity" leftIdentityProp , QC.testProperty "join" joinProp , QC.testProperty "bimap" bimapProp , QC.testProperty "alignWith" alignWithProp , QC.testProperty "assoc" assocProp , QC.testProperty "alignToList" alignToListProp ] where rightIdentityProp :: f Int -> Property rightIdentityProp xs = (xs `align` (nil :: f Int)) === fmap This xs leftIdentityProp :: f Int -> Property leftIdentityProp xs = ((nil :: f Int) `align` xs) === fmap That xs joinProp :: f Int -> Property joinProp xs = join align xs === fmap (join These) xs bimapProp :: 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 :: f Int -> f Int -> Fun (These Int Int) Int -> Property alignWithProp xs ys (Fun _ f) = alignWith f xs ys === (f <$> align xs ys) assocProp :: f Int -> f Int -> f Int -> Property assocProp xs ys zs = rhs === lhs where rhs = (xs `align` ys) `align` zs lhs = fmap assoc $ xs `align` (ys `align` zs) alignToListProp :: 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 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 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 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 [] 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-0.7.6/these.cabal0000644000000000000000000000667507346545000013137 0ustar0000000000000000cabal-version: >=1.10 name: these version: 0.7.6 synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass homepage: https://github.com/isomorphism/these license: BSD3 license-file: LICENSE author: C. McCann maintainer: oleg.grenrus@iki.fi category: Data,Control build-type: Simple extra-source-files: README.md 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. . Also included is @ChronicleT@, a monad transformer based on the Monad instance for @These a@, along with the usual monad transformer bells and whistles. . For a dependency light version, check package. 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.3 source-repository head type: git location: https://github.com/isomorphism/these.git library default-language: Haskell2010 ghc-options: -Wall 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 -- ghc boot libs build-depends: 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 -- 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.3 , keys >=3.12.1 && <3.13 , lens >=4.17 && <4.18 , QuickCheck >=2.12.6.1 && <2.13 , 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 if impl(ghc <7.5) build-depends: ghc-prim if !impl(ghc >=8.0) build-depends: semigroups >=0.18.5 && <0.19 -- 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 -- library constrained dependencies build-depends: aeson , base , base-compat , bifunctors , binary , containers , hashable , lens , QuickCheck , these , transformers , unordered-containers , vector if !impl(ghc >=8.0) build-depends: semigroups -- additional dependencies build-depends: quickcheck-instances >=0.3.15 && <0.4 , tasty >=1.2 && <1.3 , tasty-quickcheck >=0.10 && <0.11