diff --git a/Control/Monad/Chronicle.hs b/Control/Monad/Chronicle.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Chronicle.hs @@ -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 + diff --git a/Control/Monad/Chronicle/Class.hs b/Control/Monad/Chronicle/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Chronicle/Class.hs @@ -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 + + + diff --git a/Control/Monad/Trans/Chronicle.hs b/Control/Monad/Trans/Chronicle.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Chronicle.hs @@ -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 + diff --git a/Data/Align.hs b/Data/Align.hs new file mode 100644 --- /dev/null +++ b/Data/Align.hs @@ -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) diff --git a/Data/These.hs b/Data/These.hs new file mode 100644 --- /dev/null +++ b/Data/These.hs @@ -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 + +-- 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 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 + (>>=) = (>>-) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/these.cabal b/these.cabal new file mode 100644 --- /dev/null +++ b/these.cabal @@ -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 +