diff --git a/Control/Monad/Chronicle.hs b/Control/Monad/Chronicle.hs --- a/Control/Monad/Chronicle.hs +++ b/Control/Monad/Chronicle.hs @@ -1,3 +1,10 @@ +----------------------------------------------------------------------------- +-- | 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(..) @@ -12,5 +19,5 @@ import Control.Monad import Control.Monad.Trans -import Control.Monad.Trans.Chronicle (Chronicle, runChronicle, ChronicleT(..)) +import Control.Monad.Trans.Chronicle (Chronicle) import Control.Monad.Chronicle.Class diff --git a/Control/Monad/Chronicle/Class.hs b/Control/Monad/Chronicle/Class.hs --- a/Control/Monad/Chronicle/Class.hs +++ b/Control/Monad/Chronicle/Class.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- for the ErrorT instances {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,13 +19,14 @@ ) where import Data.These -import Control.Applicative (Applicative(..), (<$>)) +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 @@ -35,7 +37,9 @@ import Control.Monad.Trans.Class (lift) import Control.Monad (liftM) +import Data.Default.Class import Data.Monoid +import Prelude -- Fix redundant import warnings class (Monad m) => MonadChronicle c m | m -> c where @@ -43,8 +47,17 @@ -- -- 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 output @c@. + -- | @'confess' c@ is an action that ends with a final record @c@. -- -- Equivalent to 'throwError' for the 'Error' monad. confess :: c -> m a @@ -80,8 +93,6 @@ chronicle :: These c a -> m a - - instance (Monoid c) => MonadChronicle c (These c) where dictate c = These c () confess c = This c @@ -129,6 +140,15 @@ 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 diff --git a/Control/Monad/Trans/Chronicle.hs b/Control/Monad/Trans/Chronicle.hs --- a/Control/Monad/Trans/Chronicle.hs +++ b/Control/Monad/Trans/Chronicle.hs @@ -2,11 +2,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- --- | Module : Control.Monad.Trans.Chronicle +-- | Module : Control.Monad.Chronicle -- --- The 'ChronicleT' monad, a hybrid error/writer monad that allows --- both accumulating outputs and aborting computation with a final --- output. +-- 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 @@ -14,7 +17,7 @@ -- * The ChronicleT monad transformer , ChronicleT(..) -- * Chronicle operations - , dictate, confess + , dictate, disclose, confess , memento, absolve, condemn , retcon ) where @@ -22,16 +25,15 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans +import Data.Default.Class import Data.Functor.Apply (Apply(..)) import Data.Functor.Bind (Bind(..)) import Data.Functor.Identity -import Data.Monoid (Monoid(..)) +import Data.Monoid import Control.Monad.Error.Class import Control.Monad.Reader.Class import Control.Monad.RWS.Class -import Control.Monad.State.Class -import Control.Monad.Writer.Class import Prelude import Data.These @@ -138,6 +140,15 @@ -- Equivalent to 'tell' for the 'Writer' monad. dictate :: (Monoid 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, Monoid 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@. -- diff --git a/Data/Align.hs b/Data/Align.hs --- a/Data/Align.hs +++ b/Data/Align.hs @@ -12,38 +12,38 @@ , lpadZip, lpadZipWith , rpadZip, rpadZipWith , alignVectorWith - + -- * Unalign , Unalign(..) - + -- * Crosswalk , Crosswalk(..) - + -- * Bicrosswalk , Bicrosswalk(..) ) where -- TODO: More instances.. -import Control.Applicative (ZipList(..), pure, (<$>)) +import Control.Applicative import Data.Bifoldable (Bifoldable(..)) import Data.Bifunctor (Bifunctor(..)) -import Data.Foldable (Foldable) +import Data.Foldable import Data.Functor.Identity import Data.Functor.Product -import Data.IntMap (IntMap) -import Data.Map (Map) +import Data.Hashable (Hashable(..)) +import Data.HashMap.Strict (HashMap) import Data.Maybe (catMaybes) -import Data.Monoid (Monoid(..)) +import Data.Monoid hiding (Product) 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.IntMap as IntMap -import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HashMap import qualified Data.Sequence as Seq import qualified Data.Vector.Fusion.Stream.Monadic as Stream + #if MIN_VERSION_vector(0,11,0) import Data.Vector.Fusion.Bundle.Monadic (Bundle (..)) import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle @@ -52,8 +52,22 @@ import qualified Data.Vector.Fusion.Stream.Size as Stream #endif -import Prelude +#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: " ++) @@ -81,21 +95,31 @@ -- 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 (\x -> These x x) x +"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 (\x -> f (These x x)) x +"alignWith f x x" forall f x. alignWith f x x = fmap (\y -> f (These y y)) x #-} @@ -148,11 +172,11 @@ instance Monad m => Align (Stream m) where nil = Stream.empty #if MIN_VERSION_vector(0,11,0) - alignWith f (Stream stepa sa) (Stream stepb sb) - = Stream step (sa, sb, Nothing, False) + alignWith f (Stream stepa ta) (Stream stepb tb) + = Stream step (ta, tb, Nothing, False) #else - alignWith f (Stream stepa sa na) (Stream stepb sb nb) - = Stream step (sa, sb, Nothing, False) (Stream.larger na nb) + 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 @@ -188,6 +212,12 @@ => (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'. malign :: (Align f, Monoid a) => f a -> f a -> f a malign = alignWith (mergeThese mappend) @@ -247,7 +277,7 @@ instance Unalign Maybe instance Unalign [] where - unalign = foldr (these a b ab) ([],[]) + 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) @@ -282,6 +312,10 @@ 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) @@ -317,6 +351,11 @@ 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 diff --git a/Data/These.hs b/Data/These.hs --- a/Data/These.hs +++ b/Data/These.hs @@ -43,16 +43,17 @@ -- $align ) where -import Control.Applicative (Applicative(..)) +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 (Semigroup(..), Monoid(..)) +import Data.Semigroup import Data.Semigroup.Bifoldable import Data.Semigroup.Bitraversable import Data.Traversable @@ -271,3 +272,5 @@ instance (Monoid a) => Monad (These a) where return = pure (>>=) = (>>-) + +instance (Hashable a, Hashable b) => Hashable (These a b) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,68 @@ +These -- 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. + + + diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TupleSections #-} module Main (main) where import Control.Applicative @@ -11,11 +12,21 @@ 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.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 @@ -33,10 +44,33 @@ [ 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) + , testProperty "Map value laziness property" mapStrictnessProp + , testProperty "IntMap value laziness property" intmapStrictnessProp ] +-- 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 @@ -110,11 +144,20 @@ -- 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)] + 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 @@ -132,3 +175,7 @@ instance Arbitrary a => Arbitrary (V.Vector a) where arbitrary = V.fromList <$> arbitrary shrink = fmap V.fromList . shrink . V.toList + +instance Arbitrary a => Arbitrary (ZipList a) where + arbitrary = ZipList <$> arbitrary + shrink = fmap ZipList . shrink . getZipList diff --git a/these.cabal b/these.cabal --- a/these.cabal +++ b/these.cabal @@ -1,6 +1,6 @@ Name: these -Version: 0.6.0.0 -Synopsis: An either-or-both data type, with corresponding hybrid error/writer monad transformer. +Version: 0.6.1.0 +Synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass Homepage: https://github.com/isomorphism/these License: BSD3 License-file: LICENSE @@ -8,7 +8,20 @@ Maintainer: cam@uptoisomorphism.net Category: Data,Control Build-type: Simple +Extra-source-files: README.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. Library Exposed-modules: Data.These, @@ -16,15 +29,19 @@ Control.Monad.Chronicle, Control.Monad.Chronicle.Class, Control.Monad.Trans.Chronicle - Build-depends: base >= 3 && < 5, - containers >= 0.4 && < 0.6, - mtl >= 2 && < 2.3, - transformers >= 0.2 && < 0.5, - semigroups >= 0.8 && < 0.17, - bifunctors >= 0.1 && < 5.1, - semigroupoids >= 1.0 && < 5.1, - profunctors >= 3 && < 5.2, - vector >= 0.4 && < 0.12 + Build-depends: base >= 3 && < 5, + containers >= 0.4 && < 0.6, + mtl >= 2 && < 2.3, + transformers >= 0.2 && < 0.5, + semigroups >= 0.8 && < 0.18, + bifunctors >= 0.1 && < 5.1, + semigroupoids >= 1.0 && < 5.1, + profunctors >= 3 && < 5.2, + vector >= 0.4 && < 0.12, + transformers-compat >= 0.2 && < 0.5, + hashable >= 1.2.3 && < 1.3, + unordered-containers >= 0.2 && < 0.3, + data-default-class >= 0.0 && < 0.1 if impl(ghc <7.5) build-depends: ghc-prim ghc-options: -Wall @@ -34,11 +51,15 @@ main-is: Tests.hs hs-source-dirs: test ghc-options: -Wall - build-depends: base >= 4.5 && < 4.9, - tasty >= 0.10 && < 0.11, - tasty-quickcheck >= 0.8 && < 0.9, - transformers >= 0.2 && < 0.5, - vector >= 0.4 && < 0.12, - bifunctors >= 0.1 && < 5.1, - these, - QuickCheck + build-depends: these, + base >= 4.5 && < 4.9, + transformers >= 0.2 && < 0.5, + vector >= 0.4 && < 0.12, + bifunctors >= 0.1 && < 5.1, + containers >= 0.4 && < 0.6, + hashable >= 1.2.3 && < 1.3, + unordered-containers >= 0.2 && < 0.3, + tasty >= 0.10 && < 0.12, + tasty-quickcheck >= 0.8 && < 0.9, + QuickCheck >= 2.8 && < 2.9, + quickcheck-instances >= 0.3.6 && < 0.4