mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-21 02:31:50 +03:00
305604d243
* [ base ] Implement a bunch of standard interfaces for `Data.These` * [ base ] Add couple of eliminators with default values for `These`
188 lines
4.7 KiB
Idris
188 lines
4.7 KiB
Idris
module Data.These
|
|
|
|
import Control.Function
|
|
|
|
import Data.Zippable
|
|
|
|
%default total
|
|
|
|
public export
|
|
data These a b = This a | That b | Both a b
|
|
|
|
public export
|
|
fromEither : Either a b -> These a b
|
|
fromEither = either This That
|
|
|
|
public export
|
|
fromThis : These a b -> Maybe a
|
|
fromThis (This a) = Just a
|
|
fromThis (That _) = Nothing
|
|
fromThis (Both a _) = Just a
|
|
|
|
public export
|
|
fromThat : These a b -> Maybe b
|
|
fromThat (This _) = Nothing
|
|
fromThat (That b) = Just b
|
|
fromThat (Both _ b) = Just b
|
|
|
|
public export
|
|
fromBoth : (defaultL : Lazy a) -> (defaultR : Lazy b) -> These a b -> (a, b)
|
|
fromBoth _ y (This x) = (x, y)
|
|
fromBoth x _ (That y) = (x, y)
|
|
fromBoth _ _ (Both x y) = (x, y)
|
|
|
|
public export
|
|
these : (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
|
|
these l r lr (This a) = l a
|
|
these l r lr (That b) = r b
|
|
these l r lr (Both a b) = lr a b
|
|
|
|
public export
|
|
these' : (defualtL : Lazy a) -> (defaultR : Lazy b) -> (a -> b -> c) -> These a b -> c
|
|
these' _ y f (This x) = f x y
|
|
these' x _ f (That y) = f x y
|
|
these' _ _ f (Both x y) = f x y
|
|
|
|
public export
|
|
swap : These a b -> These b a
|
|
swap (This a) = That a
|
|
swap (That b) = This b
|
|
swap (Both a b) = Both b a
|
|
|
|
export
|
|
Injective This where
|
|
injective Refl = Refl
|
|
|
|
export
|
|
Injective That where
|
|
injective Refl = Refl
|
|
|
|
export
|
|
{x : _} -> Injective (Both x) where
|
|
injective Refl = Refl
|
|
|
|
export
|
|
{y : _} -> Injective (`Both` y) where
|
|
injective Refl = Refl
|
|
|
|
export
|
|
Biinjective Both where
|
|
biinjective Refl = (Refl, Refl)
|
|
|
|
public export
|
|
(Show a, Show b) => Show (These a b) where
|
|
showPrec d (This x) = showCon d "This" $ showArg x
|
|
showPrec d (That x) = showCon d "That" $ showArg x
|
|
showPrec d (Both x y) = showCon d "Both" $ showArg x ++ showArg y
|
|
|
|
public export
|
|
Eq a => Eq b => Eq (These a b) where
|
|
This x == This x' = x == x'
|
|
That x == That x' = x == x'
|
|
Both x y == Both x' y' = x == x' && y == y'
|
|
_ == _ = False
|
|
|
|
public export
|
|
Semigroup a => Semigroup b => Semigroup (These a b) where
|
|
This x <+> This x' = This $ x <+> x'
|
|
This x <+> That y = Both x y
|
|
This x <+> Both x' y = Both (x <+> x') y
|
|
|
|
That y <+> This x = Both x y
|
|
That y <+> That y' = That $ y <+> y'
|
|
That y <+> Both x y' = Both x $ y <+> y'
|
|
|
|
Both x y <+> This x' = Both (x <+> x') y
|
|
Both x y <+> That y' = Both x (y <+> y')
|
|
Both x y <+> Both x' y' = Both (x <+> x') (y <+> y')
|
|
|
|
%inline
|
|
public export
|
|
Bifunctor These where
|
|
bimap f g (This a) = This (f a)
|
|
bimap f g (That b) = That (g b)
|
|
bimap f g (Both a b) = Both (f a) (g b)
|
|
|
|
%inline
|
|
public export
|
|
Bifoldable These where
|
|
bifoldr f _ acc (This a) = f a acc
|
|
bifoldr _ g acc (That b) = g b acc
|
|
bifoldr f g acc (Both a b) = f a (g b acc)
|
|
|
|
bifoldl f _ acc (This a) = f acc a
|
|
bifoldl _ g acc (That b) = g acc b
|
|
bifoldl f g acc (Both a b) = g (f acc a) b
|
|
|
|
binull _ = False
|
|
|
|
%inline
|
|
public export
|
|
Bitraversable These where
|
|
bitraverse f _ (This a) = This <$> f a
|
|
bitraverse _ g (That b) = That <$> g b
|
|
bitraverse f g (Both a b) = [| Both (f a) (g b) |]
|
|
|
|
%inline
|
|
public export
|
|
Functor (These a) where
|
|
map = mapSnd
|
|
|
|
public export
|
|
bifold : Semigroup m => These m m -> m
|
|
bifold (This a) = a
|
|
bifold (That b) = b
|
|
bifold (Both a b) = a <+> b
|
|
|
|
||| A right-biased applicative implementation that combines lefts with a semigroup operation
|
|
|||
|
|
||| This implementation does its best to not to lose any data from the original arguments.
|
|
public export
|
|
Semigroup a => Applicative (These a) where
|
|
pure = That
|
|
|
|
This e <*> That _ = This e
|
|
This e <*> This e' = This $ e <+> e'
|
|
This e <*> Both e' _ = This $ e <+> e'
|
|
|
|
That f <*> That x = That $ f x
|
|
That f <*> This e = This e
|
|
That f <*> Both e x = Both e $ f x
|
|
|
|
Both e _ <*> This e' = This $ e <+> e'
|
|
Both e f <*> That x = Both e $ f x
|
|
Both e f <*> Both e' x = Both (e <+> e') $ f x
|
|
|
|
public export
|
|
Foldable (These a) where
|
|
foldr _ init $ This _ = init
|
|
foldr op init $ That x = x `op` init
|
|
foldr op init $ Both _ x = x `op` init
|
|
|
|
foldl _ init $ This _ = init
|
|
foldl op init $ That x = init `op` x
|
|
foldl op init $ Both _ x = init `op` x
|
|
|
|
null $ This _ = True
|
|
null $ That _ = False
|
|
null $ Both _ _ = False
|
|
|
|
public export
|
|
Traversable (These a) where
|
|
traverse _ $ This e = pure $ This e
|
|
traverse f $ That x = That <$> f x
|
|
traverse f $ Both x y = Both x <$> f y
|
|
|
|
public export
|
|
Semigroup a => Zippable (These a) where
|
|
zipWith f x y = [| f x y |]
|
|
zipWith3 f x y z = [| f x y z |]
|
|
|
|
unzipWith f (This x) = (This x, This x)
|
|
unzipWith f (That x) = let (u, v) = f x in (That u, That v)
|
|
unzipWith f (Both x y) = let (u, v) = f y in (Both x u, Both x v)
|
|
|
|
unzipWith3 f (This x) = (This x, This x, This x)
|
|
unzipWith3 f (That x) = let (u, v, w) = f x in (That u, That v, That w)
|
|
unzipWith3 f (Both x y) = let (u, v, w) = f y in (Both x u, Both x v, Both x w)
|