these-0.7.3/0000755000000000000000000000000013023456024011016 5ustar0000000000000000these-0.7.3/these.cabal0000644000000000000000000000714213023456024013116 0ustar0000000000000000Name: these Version: 0.7.3 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: cam@uptoisomorphism.net Category: Data,Control Build-type: Simple Extra-source-files: README.md, CHANGELOG.md Cabal-version: >=1.8 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. source-repository head type: git location: https://github.com/isomorphism/these.git Library Exposed-modules: Data.These, Data.Align, Data.Align.Key, Control.Monad.Chronicle, Control.Monad.Chronicle.Class, Control.Monad.Trans.Chronicle Build-depends: base >= 4.4 && < 4.10, aeson >= 0.7.0.4 && < 1.1, bifunctors >= 0.1 && < 5.5, binary >= 0.5.0.2 && < 0.9, containers >= 0.4 && < 0.6, data-default-class >= 0.0 && < 0.2, deepseq >= 1.3.0.0 && < 1.5, hashable >= 1.2.3 && < 1.3, keys >= 3.10 && < 3.12, mtl >= 2 && < 2.3, profunctors >= 3 && < 5.3, QuickCheck >= 2.8 && < 2.9.3, semigroupoids >= 1.0 && < 5.2, transformers >= 0.2 && < 0.6, transformers-compat >= 0.2 && < 0.6, unordered-containers >= 0.2 && < 0.3, vector >= 0.4 && < 0.12, vector-instances >= 3.3.1 && < 3.4 if impl(ghc <7.5) build-depends: ghc-prim if !impl(ghc >= 8.0) build-depends: semigroups >= 0.8 && < 0.19 ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 main-is: Tests.hs hs-source-dirs: test ghc-options: -Wall build-depends: these, base >= 4.5, quickcheck-instances >= 0.3.6 && < 0.3.13, tasty >= 0.10 && < 0.12, tasty-quickcheck >= 0.8 && < 0.9, aeson, bifunctors, binary, containers, hashable, QuickCheck, transformers, unordered-containers, vector these-0.7.3/CHANGELOG.md0000644000000000000000000000136513023456024012634 0ustar0000000000000000# 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.3/LICENSE0000644000000000000000000000275313023456024012032 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.3/Setup.hs0000644000000000000000000000005613023456024012453 0ustar0000000000000000import Distribution.Simple main = defaultMain these-0.7.3/README.md0000644000000000000000000001056713023456024012306 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.3/Control/0000755000000000000000000000000013023456024012436 5ustar0000000000000000these-0.7.3/Control/Monad/0000755000000000000000000000000013023456024013474 5ustar0000000000000000these-0.7.3/Control/Monad/Chronicle.hs0000644000000000000000000000200413023456024015732 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.3/Control/Monad/Chronicle/0000755000000000000000000000000013023456024015402 5ustar0000000000000000these-0.7.3/Control/Monad/Chronicle/Class.hs0000644000000000000000000002274213023456024017012 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.3/Control/Monad/Trans/0000755000000000000000000000000013023456024014563 5ustar0000000000000000these-0.7.3/Control/Monad/Trans/Chronicle.hs0000644000000000000000000002034513023456024017031 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.3/Data/0000755000000000000000000000000013023456024011667 5ustar0000000000000000these-0.7.3/Data/These.hs0000644000000000000000000003314013023456024013274 0ustar0000000000000000----------------------------------------------------------------------------- -- | Module : Data.These -- -- The 'These' type and associated operations. Now enhanced with @Control.Lens@ magic! {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Data.These ( These(..) -- * Functions to get rid of 'These' , these , fromThese , mergeThese , mergeTheseWith -- * Traversals , here, there -- * Prisms , _This, _That, _These -- * Case selections , justThis , justThat , justThese , catThis , catThat , catThese , partitionThese -- * Case predicates , isThis , isThat , isThese -- * Map operations , mapThese , mapThis , mapThat -- $align ) where import Control.Applicative import Control.Monad import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Foldable import Data.Functor.Bind import Data.Hashable (Hashable(..)) import Data.Maybe (isJust, mapMaybe) import Data.Profunctor import Data.Semigroup import Data.Semigroup.Bifoldable import Data.Semigroup.Bitraversable import Data.Traversable import Data.Data import GHC.Generics import Prelude hiding (foldr) import Control.DeepSeq (NFData (..)) import Data.Aeson (FromJSON (..), ToJSON (..), (.=)) import Data.Binary (Binary (..)) import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), oneof) import Test.QuickCheck.Function (Function (..), functionMap) import qualified Data.HashMap.Strict as HM import qualified Data.Aeson as Aeson #if MIN_VERSION_aeson(1,0,0) import qualified Data.Aeson.Encoding as Aeson (pair) #endif -- -------------------------------------------------------------------------- -- | 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. 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 @Traversal@ of the first half of a 'These', suitable for use with @Control.Lens@. 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 @Traversal@ of the second half of a 'These', suitable for use with @Control.Lens@. 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 -- is there a recipe for creating suitable definitions anywhere? -- not yet -- prism bt seta = dimap seta (either pure (fmap bt)) . right' -- (let's all pretend I know how this works ok) prism :: (Choice p, Applicative f) => (b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t) prism bt seta = dimap seta (either pure (fmap bt)) . right' -- | A 'Prism' selecting the 'This' constructor. _This :: (Choice p, Applicative f) => p a (f a) -> p (These a b) (f (These a b)) _This = prism This (these Right (Left . That) (\x y -> Left $ These x y)) -- | A 'Prism' selecting the 'That' constructor. _That :: (Choice p, Applicative f) => p b (f b) -> p (These a b) (f (These a b)) _That = prism That (these (Left . This) Right (\x y -> Left $ These x y)) -- | A 'Prism' selecting the 'These' constructor. 'These' names are ridiculous! _These :: (Choice p, Applicative f) => p (a, b) (f (a, b)) -> p (These a b) (f (These a b)) _These = prism (uncurry These) (these (Left . This) (Left . That) (\x y -> Right (x, y))) -- | @'justThis' = preview '_This'@ justThis :: These a b -> Maybe a justThis (This a) = Just a justThis _ = Nothing -- | @'justThat' = preview '_That'@ justThat :: These a b -> Maybe b justThat (That x) = Just x justThat _ = Nothing -- | @'justThese' = 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) -- | @'mapThis' = over 'here'@ mapThis :: (a -> c) -> These a b -> These c b mapThis f = mapThese f id -- | @'mapThat' = 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 -- $align -- -- For zipping and unzipping of structures with 'These' values, see -- "Data.Align". 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 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 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) 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 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" 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 ] #if MIN_VERSION_aeson(0,10,0) toEncoding (This a) = Aeson.pairs $ "This" .= a toEncoding (That b) = Aeson.pairs $ "That" .= b toEncoding (These a b) = Aeson.pairs $ "This" .= a <> "That" .= b #endif 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" #if MIN_VERSION_aeson(1,0,0) 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) 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) 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" 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 instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where arbitrary = oneof [ This <$> arbitrary , That <$> arbitrary , These <$> arbitrary <*> arbitrary ] shrink (This x) = This <$> shrink x shrink (That y) = That <$> shrink y shrink (These x y) = [This x, That y] ++ [These x' y' | (x', y') <- shrink (x, y)] 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 instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (These a b) these-0.7.3/Data/Align.hs0000644000000000000000000003275513023456024013271 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 Control.Applicative import Data.Bifoldable (Bifoldable(..)) import Data.Bifunctor (Bifunctor(..)) import Data.Foldable import Data.Functor.Identity import Data.Functor.Product import Data.Hashable (Hashable(..)) import Data.HashMap.Strict (HashMap) import Data.Maybe (catMaybes) import Data.Monoid hiding (Product, (<>)) import Data.Semigroup (Semigroup (..)) import Data.Sequence (Seq) import Data.These import qualified Data.Vector as V import Data.Vector.Generic (Vector, unstream, stream, empty) import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..)) import qualified Data.HashMap.Strict as HashMap import qualified Data.Sequence as Seq import qualified Data.Vector.Fusion.Stream.Monadic as Stream import qualified Data.Vector.Generic as VG (fromList, foldr) #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.Strict (Map) import qualified Data.Map.Strict as Map import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap #else import Data.Map (Map) import qualified Data.Map as Map import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap #endif import Prelude hiding (foldr) -- Fix redundant import warnings 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 -- @ 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 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" instance Align IntMap where nil = IntMap.empty 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" 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 '<>'. 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 -- -------------------------------------------------------------------------- -- | 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.3/Data/Align/0000755000000000000000000000000013023456024012721 5ustar0000000000000000these-0.7.3/Data/Align/Key.hs0000644000000000000000000000216413023456024014010 0ustar0000000000000000----------------------------------------------------------------------------- -- | Module : Data.Aligned.Key -- -- 'These'-based zipping and unzipping of indexed functors. 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'. 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 [] --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.3/test/0000755000000000000000000000000013023456024011775 5ustar0000000000000000these-0.7.3/test/Tests.hs0000644000000000000000000002246113023456024013440 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TupleSections #-} module Main (main) where import Control.Applicative import Control.Monad (join) import Data.Align import Data.Align.Key import Data.Foldable import Data.Bifunctor import Data.Functor.Compose import Data.Functor.Identity import qualified Data.Functor.Product as P import Data.HashMap.Strict (HashMap) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List as L import Data.Map (Map) import qualified Data.Map as Map import Data.Sequence (Seq) import Data.Monoid import Data.These import Data.Int (Int8) import Data.Traversable import qualified Data.Vector as V import Prelude -- Fix redundant import warnings import Test.QuickCheck.Function import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.QuickCheck as QC import qualified Data.Aeson as Aeson import qualified Data.Binary as Binary import qualified Data.Set as Set -- For old GHC to work data Proxy (a :: * -> *) = Proxy main :: IO () main = defaultMain tests tests :: TestTree tests = testGroup "Tests" [theseProps, alignWithKeyProps] theseProps :: TestTree theseProps = testGroup "These" [ functorProps , traversableProps , 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) , 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) , testProperty "Map value laziness property" mapStrictnessProp , testProperty "IntMap value laziness property" intmapStrictnessProp , aesonProps , binaryProps ] alignWithKeyProps :: TestTree alignWithKeyProps = testGroup "AlignWithKey" [ testProperty "example" $ once $ example ] where example = alignWithKey (,) "foo" "quux" === [ (0, These 'f' 'q') , (1, These 'o' 'u') , (2, These 'o' 'u') , (3, That 'x') ] -- Even the `align` is defined using strict combinators, this will still work: mapStrictnessProp :: [Int] -> [Int] -> Bool mapStrictnessProp lkeys rkeys = Prelude.length (nub lkeys) <= Map.size (lhs `align` rhs) where lhs = Map.fromList $ fmap (,loop) lkeys rhs = Map.fromList $ fmap (,loop) rkeys loop :: Int loop = loop intmapStrictnessProp :: [Int] -> [Int] -> Bool intmapStrictnessProp lkeys rkeys = Prelude.length (nub lkeys) <= IntMap.size (lhs `align` rhs) where lhs = IntMap.fromList $ fmap (,loop) lkeys rhs = IntMap.fromList $ fmap (,loop) rkeys loop :: Int loop = loop 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) ] -- 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 dataAlignLaws :: forall (f :: * -> *). ( Align f , Eq (f (These Int Int)) , Show (f (These 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 ] 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) 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] 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 ------------------------------------------------------------------------------- -- Orphan instances ------------------------------------------------------------------------------- instance (Arbitrary a, Arbitrary (f a), Arbitrary (g a)) => Arbitrary (P.Product f g a) where arbitrary = P.Pair <$> arbitrary <*> arbitrary shrink (P.Pair x y) = [P.Pair x' y' | (x', y') <- shrink (x, y)] #if !MIN_VERSION_quickcheck_instances(0,3,12) instance Arbitrary a => Arbitrary (V.Vector a) where arbitrary = V.fromList <$> arbitrary shrink = fmap V.fromList . shrink . V.toList #endif #if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary a => Arbitrary (ZipList a) where arbitrary = ZipList <$> arbitrary shrink = fmap ZipList . shrink . getZipList #endif ------------------------------------------------------------------------------- -- 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)