these (empty) → 0.2
raw patch · 8 files changed
+1026/−0 lines, 8 filesdep +basedep +bifunctorsdep +containerssetup-changed
Dependencies added: base, bifunctors, containers, mtl, profunctors, semigroupoids, semigroups, transformers, vector
Files
- Control/Monad/Chronicle.hs +21/−0
- Control/Monad/Chronicle/Class.hs +185/−0
- Control/Monad/Trans/Chronicle.hs +195/−0
- Data/Align.hs +304/−0
- Data/These.hs +261/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- these.cabal +28/−0
+ Control/Monad/Chronicle.hs view
@@ -0,0 +1,21 @@+module Control.Monad.Chronicle ( + -- * The Chronicle monad+ Chronicle, chronicle, runChronicle+ -- * The ChronicleT monad transformer+ , ChronicleT(..)+ -- * Chronicle operations+ , dictate, confess+ , memento, absolve, condemn, retcon+ , module Data.Semigroup+ , module Data.Monoid+ , module Control.Monad+ , module Control.Monad.Trans+ ) where++import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(..))++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Chronicle+
+ Control/Monad/Chronicle/Class.hs view
@@ -0,0 +1,185 @@+{-# 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(..)) where++import Data.These+import Control.Applicative+import Control.Monad.Trans.Chronicle (ChronicleT)+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.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.Exception (IOException, catch, ioError)+import Control.Monad+import Control.Monad.Instances ()+import Data.Monoid+import Prelude -- (Either(..), (.), IO)++++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 ()++ -- | @'confess' c@ is an action that ends with a final output @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 (Monoid c) => MonadChronicle c (These c) where+ dictate c = These c ()+ confess = This+ 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 (Monoid 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 (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 (Monoid s, MonadChronicle c m) => MonadChronicle c (LazyState.StateT s m) where+ dictate = lift . dictate+ confess = lift . confess+ memento (LazyState.StateT m) = LazyState.StateT $ \s ->+ 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 (Monoid s, MonadChronicle c m) => MonadChronicle c (StrictState.StateT s m) where+ dictate = lift . dictate+ confess = lift . confess+ memento (StrictState.StateT m) = StrictState.StateT $ \s ->+ 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+++
+ Control/Monad/Trans/Chronicle.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- | 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.Trans.Chronicle ( + -- * The Chronicle monad+ Chronicle, chronicle, runChronicle+ -- * The ChronicleT monad transformer+ , ChronicleT(..)+ -- * Chronicle operations+ , dictate, confess+ , memento, absolve, condemn+ , retcon+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.Functor.Apply (Apply(..))+import Data.Functor.Bind (Bind(..))+import Data.Functor.Identity+import Data.Monoid (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++-- --------------------------------------------------------------------------+-- | 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 (Monoid 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+ 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 (Monoid 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 (mappend a b)+ That y -> These a y+ These b y -> These (mappend a b) y++instance (Monoid c) => MonadTrans (ChronicleT c) where+ lift m = ChronicleT (That `liftM` m)++instance (Monoid c, MonadIO m) => MonadIO (ChronicleT c m) where+ liftIO = lift . liftIO+++instance (Monoid c, Applicative m, Monad m) => Alternative (ChronicleT c m) where+ empty = mzero+ (<|>) = mplus++instance (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 (Monoid 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+ 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 (Monoid 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+ 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++++-- | @'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 c = ChronicleT $ return (These c ())++-- | @'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 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 :: (Monoid 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 :: (Monoid 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 :: (Monoid 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 :: (Monoid 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
@@ -0,0 +1,304 @@+-----------------------------------------------------------------------------+-- | 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, padZip, padZipWith+ , lpadZip, lpadZipWith+ , rpadZip, rpadZipWith+ + -- * Unalign+ , Unalign(..)+ + -- * Crosswalk+ , Crosswalk(..)+ + -- * Bicrosswalk+ , Bicrosswalk(..)+ , alignVectorWith+ ) where++-- TODO: More instances..++import Control.Applicative (ZipList(..), pure, (<$>))+import Data.Bifoldable (Bifoldable(..))+import Data.Bifunctor (Bifunctor(..))+import Data.Foldable (Foldable)+import Data.Functor.Identity+import Data.Functor.Product+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Maybe (catMaybes)+import Data.Monoid (Monoid(..))+import Data.Sequence (Seq)+import Data.These+import Data.Vector.Generic (Vector, unstream, stream)+import Data.Vector.Fusion.Stream.Monadic (Stream(..), Step(..))+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Vector.Fusion.Stream.Monadic as Stream+import qualified Data.Vector.Fusion.Stream.Size as Stream++import Prelude++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+ nil :: f a++ align :: f a -> f b -> f (These a b)+ align = alignWith id++ alignWith :: (These a b -> c) -> f a -> f b -> f c+ alignWith f a b = f <$> align a b++{-# RULES++"align nil nil" align nil nil = nil+"align x x" forall x. align x x = fmap (\x -> These x x) 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++ #-}+++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)++-- 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'++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+ alignWith f (Stream stepa sa na) (Stream stepb sb nb)+ = Stream step (sa, sb, Nothing, False) (Stream.larger na nb)+ 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)++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)++-- | Align two structures and combine with 'mappend'.+malign :: (Align f, Monoid a) => f a -> f a -> f a+malign = alignWith (mergeThese mappend)++-- | 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++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 (These a) where+ crosswalk _ (This _) = nil+ crosswalk f (That x) = That <$> f x+ crosswalk f (These a x) = These a <$> f x++-- --------------------------------------------------------------------------+-- | 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++instance Bicrosswalk Either where+ bicrosswalk f _ (Left x) = Left <$> f x+ bicrosswalk _ g (Right x) = Right <$> g x++instance Bicrosswalk These where+ bicrosswalk f _ (This x) = This <$> f x+ bicrosswalk _ g (That x) = That <$> g x+ bicrosswalk f g (These x y) = align (f x) (g y)
+ Data/These.hs view
@@ -0,0 +1,261 @@+-----------------------------------------------------------------------------+-- | Module : Data.These+--+-- The 'These' type and associated operations. Now enhanced with @Control.Lens@ magic!+module Data.These (+ These(..)+ + -- * Functions to get rid of 'These'+ , these+ , fromThese+ , mergeThese+ + -- * 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 (Applicative(..))+import Control.Monad+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Foldable+import Data.Functor.Bind+import Data.Maybe (isJust, mapMaybe)+import Data.Profunctor+import Data.Semigroup (Semigroup(..), Monoid(..))+import Data.Semigroup.Bifoldable+import Data.Semigroup.Bitraversable+import Data.Traversable+import Prelude hiding (foldr)++-- --------------------------------------------------------------------------+-- | 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)++-- | 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+++-- | 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++-- <cmccann> is there a recipe for creating suitable definitions anywhere?+-- <edwardk> not yet+-- <edwardk> prism bt seta = dimap seta (either pure (fmap bt)) . right'+-- (let's all pretend I know how this works ok)+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 (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 f z = foldr f z . justThat++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+ bimapM f _ (This x) = liftM This (f x)+ bimapM _ g (That x) = liftM That (g x)+ bimapM f g (These x y) = liftM2 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 (Monoid 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 f <.> That x = These a (f x)+ These a f <.> These b x = These (mappend a b) (f x)++instance (Monoid a) => Applicative (These a) where+ pure = That+ (<*>) = (<.>)++instance (Monoid 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)+ That y -> These a y+ These b y -> These (mappend a b) y++instance (Monoid a) => Monad (These a) where+ return = pure+ (>>=) = (>>-)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ these.cabal view
@@ -0,0 +1,28 @@+Name: these+Version: 0.2+Synopsis: An either-or-both data type, with corresponding hybrid error/writer monad transformer.+Homepage: https://github.com/isomorphism/these+License: BSD3+License-file: LICENSE+Author: C. McCann+Maintainer: cam@uptoisomorphism.net+Category: Data,Control+Build-type: Simple+Cabal-version: >=1.2++Library+ Exposed-modules: Data.These, + Data.Align, + Control.Monad.Chronicle, + Control.Monad.Chronicle.Class, + Control.Monad.Trans.Chronicle+ Build-depends: base >= 3 && < 5,+ containers >= 0.4 && < 1.0,+ mtl >= 2 && < 3,+ transformers >= 0.2 && < 1.0,+ semigroups >= 0.8 && < 1.0,+ bifunctors >= 0.1 && < 4.0,+ semigroupoids >= 1.0 && < 4.0,+ profunctors >= 3 && < 4,+ vector >= 0.4 && < 1.0+