these 0.6.2.1 → 0.7
raw patch · 7 files changed
+129/−48 lines, 7 filesdep ~bifunctorsdep ~semigroupoids
Dependency ranges changed: bifunctors, semigroupoids
Files
- CHANGELOG.md +6/−0
- Control/Monad/Chronicle/Class.hs +3/−3
- Control/Monad/Trans/Chronicle.hs +24/−24
- Data/Align.hs +35/−8
- Data/These.hs +8/−8
- test/Tests.hs +44/−0
- these.cabal +9/−5
CHANGELOG.md view
@@ -1,3 +1,9 @@+# 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)
Control/Monad/Chronicle/Class.hs view
@@ -38,7 +38,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad (liftM) import Data.Default.Class-import Data.Monoid+import Data.Semigroup import Prelude -- Fix redundant import warnings @@ -93,7 +93,7 @@ chronicle :: These c a -> m a -instance (Monoid c) => MonadChronicle c (These c) where+instance (Semigroup c) => MonadChronicle c (These c) where dictate c = These c () confess c = This c memento (This c) = That (Left c)@@ -106,7 +106,7 @@ retcon = mapThis chronicle = id -instance (Monoid c, Monad m) => MonadChronicle c (ChronicleT c m) where+instance (Semigroup c, Monad m) => MonadChronicle c (ChronicleT c m) where dictate = Ch.dictate confess = Ch.confess memento = Ch.memento
Control/Monad/Trans/Chronicle.hs view
@@ -30,7 +30,7 @@ import Data.Functor.Apply (Apply(..)) import Data.Functor.Bind (Bind(..)) import Data.Functor.Identity-import Data.Monoid+import Data.Semigroup import Control.Monad.Error.Class import Control.Monad.Reader.Class@@ -61,17 +61,17 @@ instance (Functor m) => Functor (ChronicleT c m) where fmap f (ChronicleT c) = ChronicleT (fmap f <$> c) -instance (Monoid c, Apply m) => Apply (ChronicleT c m) where+instance (Semigroup c, Apply m) => Apply (ChronicleT c m) where ChronicleT f <.> ChronicleT x = ChronicleT ((<.>) <$> f <.> x) -instance (Monoid c, Applicative m) => Applicative (ChronicleT c m) where+instance (Semigroup c, Applicative m) => Applicative (ChronicleT c m) where pure = ChronicleT . pure . pure ChronicleT f <*> ChronicleT x = ChronicleT (liftA2 (<*>) f x) -instance (Monoid c, Apply m, Monad m) => Bind (ChronicleT c m) where+instance (Semigroup c, Apply m, Monad m) => Bind (ChronicleT c m) where (>>-) = (>>=) -instance (Monoid c, Monad m) => Monad (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@@ -80,22 +80,22 @@ That x -> runChronicleT (k x) These a x -> do cy <- runChronicleT (k x) return $ case cy of- This b -> This (mappend a b)+ This b -> This (a <> b) That y -> These a y- These b y -> These (mappend a b) y+ These b y -> These (a <> b) y -instance (Monoid c) => MonadTrans (ChronicleT c) where+instance (Semigroup c) => MonadTrans (ChronicleT c) where lift m = ChronicleT (That `liftM` m) -instance (Monoid c, MonadIO m) => MonadIO (ChronicleT c m) where+instance (Semigroup c, MonadIO m) => MonadIO (ChronicleT c m) where liftIO = lift . liftIO -instance (Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where+instance (Semigroup c, Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where empty = mzero (<|>) = mplus -instance (Monoid c, Monad m) => MonadPlus (ChronicleT c m) where+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@@ -103,24 +103,24 @@ Right r -> return r -instance (Monoid c, MonadError e m) => MonadError e (ChronicleT c m) where+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 (Monoid c, MonadReader r m) => MonadReader r (ChronicleT c m) where+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 (Monoid c, MonadRWS r w s m) => MonadRWS r w s (ChronicleT c m) where+instance (Semigroup c, MonadRWS r w s m) => MonadRWS r w s (ChronicleT c m) where -instance (Monoid c, MonadState s m) => MonadState 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 (Monoid c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where+instance (Semigroup c, MonadWriter w m) => MonadWriter w (ChronicleT c m) where tell = lift . tell listen (ChronicleT m) = ChronicleT $ do (m', w) <- listen m@@ -136,7 +136,7 @@ -- this is basically copied from the instance for Either in transformers -- need to test this to make sure it's actually sensible...?-instance (Monoid c, MonadFix m) => MonadFix (ChronicleT c m) where+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" @@ -144,7 +144,7 @@ -- | @'dictate' c@ is an action that records the output @c@. -- -- Equivalent to 'tell' for the 'Writer' monad.-dictate :: (Monoid c, Monad m) => c -> ChronicleT c m ()+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@@ -153,13 +153,13 @@ -- 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 :: (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 :: (Monoid c, Monad m) => c -> ChronicleT c m a+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@@ -169,7 +169,7 @@ -- 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 :: (Monoid c, Monad m) => ChronicleT c m a -> ChronicleT c m (Either c a)+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@@ -180,7 +180,7 @@ -- | @'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 :: (Monoid c, Monad m) => a -> ChronicleT c m a -> ChronicleT c m a+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@@ -194,7 +194,7 @@ -- and only the record kept. -- -- This can be seen as converting non-fatal errors into fatal ones.-condemn :: (Monoid c, Monad m) => ChronicleT c m a -> ChronicleT c m a+condemn :: (Semigroup c, Monad m) => ChronicleT c m a -> ChronicleT c m a condemn (ChronicleT m) = ChronicleT $ do m' <- m return $ case m' of@@ -207,6 +207,6 @@ -- function @f@ to its output, leaving the return value unchanged. -- -- Equivalent to 'censor' for the 'Writer' monad.-retcon :: (Monoid c, Monad m) => (c -> c) -> ChronicleT c m a -> ChronicleT c m a+retcon :: (Semigroup c, Monad m) => (c -> c) -> ChronicleT c m a -> ChronicleT c m a retcon f m = ChronicleT $ mapThis f `liftM` runChronicleT m
Data/Align.hs view
@@ -43,6 +43,7 @@ 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 (..))@@ -141,17 +142,31 @@ nil = ZipList [] align (ZipList xs) (ZipList ys) = ZipList (align xs ys) --- could probably be more efficient... instance Align Seq where nil = Seq.empty- align xs ys =- case Seq.viewl xs of- Seq.EmptyL -> That <$> ys- x Seq.:< xs' ->- case Seq.viewl ys of- Seq.EmptyL -> This <$> xs- y Seq.:< ys' -> These x y Seq.<| align xs' ys' + 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)@@ -328,10 +343,22 @@ 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
Data/These.hs view
@@ -245,28 +245,28 @@ bitraverse1 _ g (That x) = That <$> g x bitraverse1 f g (These x y) = These <$> f x <.> g y -instance (Monoid a) => Apply (These a) where+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 (mappend a b)+ These a _ <.> This b = This (a <> b) These a f <.> That x = These a (f x)- These a f <.> These b x = These (mappend a b) (f x)+ These a f <.> These b x = These (a <> b) (f x) -instance (Monoid a) => Applicative (These a) where+instance (Semigroup a) => Applicative (These a) where pure = That (<*>) = (<.>) -instance (Monoid a) => Bind (These a) where+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 (mappend a b)+ This b -> This (a <> b) That y -> These a y- These b y -> These (mappend a b) y+ These b y -> These (a <> b) y -instance (Monoid a) => Monad (These a) where+instance (Semigroup a) => Monad (These a) where return = pure (>>=) = (>>-)
test/Tests.hs view
@@ -53,6 +53,12 @@ , 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 ]@@ -142,6 +148,44 @@ 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
these.cabal view
@@ -1,5 +1,5 @@ Name: these-Version: 0.6.2.1+Version: 0.7 Synopsis: An either-or-both data type & a generalized 'zip with padding' typeclass Homepage: https://github.com/isomorphism/these License: BSD3@@ -37,17 +37,21 @@ containers >= 0.4 && < 0.6, mtl >= 2 && < 2.3, transformers >= 0.2 && < 0.6,- semigroups >= 0.8 && < 0.19,- bifunctors >= 0.1 && < 5.3,+ bifunctors >= 0.1 && < 5.4, semigroupoids >= 1.0 && < 5.1, profunctors >= 3 && < 5.3, vector >= 0.4 && < 0.12, transformers-compat >= 0.2 && < 0.6, hashable >= 1.2.3 && < 1.3, unordered-containers >= 0.2 && < 0.3,- data-default-class >= 0.0 && < 0.1+ data-default-class >= 0.0 && < 0.2 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@@ -59,7 +63,7 @@ base >= 4.5 && < 4.10, transformers >= 0.2 && < 0.6, vector >= 0.4 && < 0.12,- bifunctors >= 0.1 && < 5.3,+ bifunctors >= 0.1 && < 5.4, containers >= 0.4 && < 0.6, hashable >= 1.2.3 && < 1.3, unordered-containers >= 0.2 && < 0.3,