153 lines
4.4 KiB
Haskell
153 lines
4.4 KiB
Haskell
module Hasklet3 where
|
|
|
|
import Data.Semigroup (All(..))
|
|
|
|
|
|
-- | A list of pairs of elements of type a AND b.
|
|
data ListP a b
|
|
= NilP
|
|
| ConsP a b (ListP a b)
|
|
deriving (Eq,Show)
|
|
|
|
-- | A list of elements of either type a OR b.
|
|
data ListE a b
|
|
= NilE
|
|
| ConsL a (ListE a b)
|
|
| ConsR b (ListE a b)
|
|
deriving (Eq,Show)
|
|
|
|
-- | Containers with two different element types that can be mapped over.
|
|
--
|
|
-- Instances of Bifunctor should satisfy the following laws:
|
|
-- * bimap id id <=> id
|
|
-- * bimap (f1 . f2) (g1 . g2) <=> bimap f1 g1 . bimap f2 g2
|
|
--
|
|
class Bifunctor t where
|
|
bimap :: (a -> c) -> (b -> d) -> t a b -> t c d
|
|
|
|
-- | Test cases for Bifunctor instances.
|
|
--
|
|
-- >>> bimap (+1) (>3) (ConsP 1 2 (ConsP 3 4 NilP))
|
|
-- ConsP 2 False (ConsP 4 True NilP)
|
|
--
|
|
-- >>> bimap (+1) even (ConsL 1 (ConsR 2 (ConsR 3 (ConsL 4 NilE))))
|
|
-- ConsL 2 (ConsR True (ConsR False (ConsL 5 NilE)))
|
|
--
|
|
|
|
-- [Bifunctor instances go here.]
|
|
|
|
instance Bifunctor ListP where
|
|
bimap f g NilP = NilP
|
|
bimap f g (ConsP a b r) = ConsP (f a) (g b) $ bimap f g r
|
|
|
|
instance Bifunctor ListE where
|
|
bimap f g NilE = NilE
|
|
bimap f g (ConsL a r) = ConsL (f a) $ bimap f g r
|
|
bimap f g (ConsR b r) = ConsR (g b) $ bimap f g r
|
|
|
|
-- | Map over the left elements of a bifunctor.
|
|
--
|
|
-- >>> mapL (+5) (ConsP 1 2 (ConsP 3 4 NilP))
|
|
-- ConsP 6 2 (ConsP 8 4 NilP)
|
|
--
|
|
-- >>> mapL even (ConsL 1 (ConsR 2 (ConsR 3 (ConsL 4 NilE))))
|
|
-- ConsL False (ConsR 2 (ConsR 3 (ConsL True NilE)))
|
|
--
|
|
mapL :: Bifunctor t => (a -> c) -> t a b -> t c b
|
|
mapL = flip bimap id
|
|
|
|
-- | Map over the right elements of a bifunctor.
|
|
--
|
|
-- >>> mapR (+5) (ConsP 1 2 (ConsP 3 4 NilP))
|
|
-- ConsP 1 7 (ConsP 3 9 NilP)
|
|
--
|
|
-- >>> mapR even (ConsL 1 (ConsR 2 (ConsR 3 (ConsL 4 NilE))))
|
|
-- ConsL 1 (ConsR True (ConsR False (ConsL 4 NilE)))
|
|
--
|
|
mapR :: Bifunctor t => (b -> c) -> t a b -> t a c
|
|
mapR = bimap id
|
|
|
|
|
|
-- | Containers with two different element types that can be folded to
|
|
-- a single summary value.
|
|
class Bifoldable t where
|
|
bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c
|
|
|
|
|
|
-- | Test cases for Bifoldable instances.
|
|
--
|
|
-- >>> let addL x (y,z) = (x+y, z)
|
|
-- >>> let mulR x (y,z) = (y, x*z)
|
|
--
|
|
-- >>> bifoldr addL mulR (0,1) (ConsP 1 2 (ConsP 3 4 NilP))
|
|
-- (4,8)
|
|
--
|
|
-- >>> bifoldr addL mulR (0,1) (ConsL 1 (ConsR 2 (ConsR 3 (ConsL 4 NilE))))
|
|
-- (5,6)
|
|
--
|
|
|
|
-- [Bifoldable instances go here.]
|
|
|
|
instance Bifoldable ListP where
|
|
bifoldr _ _ c NilP = c
|
|
bifoldr f g c (ConsP a b r) = f a $ g b $ bifoldr f g c r
|
|
|
|
instance Bifoldable ListE where
|
|
bifoldr _ _ c NilE = c
|
|
bifoldr f g c (ConsL a r) = f a $ bifoldr f g c r
|
|
bifoldr f g c (ConsR b r) = g b $ bifoldr f g c r
|
|
|
|
-- | Fold over the left elements of a bifoldable.
|
|
--
|
|
-- >>> foldrL (+) 0 (ConsP 2 3 (ConsP 4 5 NilP))
|
|
-- 6
|
|
--
|
|
-- >>> foldrL (*) 1 (ConsL 2 (ConsR 3 (ConsR 4 (ConsL 5 NilE))))
|
|
-- 10
|
|
--
|
|
foldrL :: Bifoldable t => (a -> c -> c) -> c -> t a b -> c
|
|
foldrL = flip bifoldr (const id)
|
|
|
|
-- | Fold over the right elements of a bifoldable.
|
|
--
|
|
-- >>> foldrR (+) 0 (ConsP 2 3 (ConsP 4 5 NilP))
|
|
-- 8
|
|
--
|
|
-- >>> foldrR (*) 1 (ConsL 2 (ConsR 3 (ConsR 4 (ConsL 5 NilE))))
|
|
-- 12
|
|
--
|
|
foldrR :: Bifoldable t => (b -> c -> c) -> c -> t a b -> c
|
|
foldrR = bifoldr (const id)
|
|
|
|
-- | Map each element in a bifoldable to a common monoid type and combine
|
|
-- the results. This function is used by the 'checkAll' and 'toEitherList'
|
|
-- functions below.
|
|
--
|
|
-- >>> checkAll odd even (ConsP 1 2 (ConsP 3 4 NilP))
|
|
-- True
|
|
--
|
|
-- >>> checkAll odd even (ConsL 1 (ConsL 2 (ConsL 3 (ConsR 4 NilE))))
|
|
-- False
|
|
--
|
|
-- >>> toEitherList (ConsP 1 True (ConsP 2 False NilP))
|
|
-- [Left 1,Right True,Left 2,Right False]
|
|
--
|
|
-- >>> toEitherList (ConsL 1 (ConsL 2 (ConsL 3 (ConsR "hi" NilE))))
|
|
-- [Left 1,Left 2,Left 3,Right "hi"]
|
|
--
|
|
bifoldMap :: (Monoid m, Bifoldable t) => (a -> m) -> (b -> m) -> t a b -> m
|
|
bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty
|
|
|
|
-- Jack tried doing it point free, so I did too!
|
|
-- bifoldMap = (.(mappend.)).flip flip mempty.bifoldr.(mappend.)
|
|
|
|
-- | Check whether all of the elements in a bifoldable satisfy the given
|
|
-- predicates. The 'All' monoid used in the implementation is the boolean
|
|
-- monoid under conjunction.
|
|
checkAll :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool
|
|
checkAll f g = getAll . bifoldMap (All . f) (All . g)
|
|
|
|
-- | Create a list of all elements in a bifoldable.
|
|
toEitherList :: Bifoldable t => t a b -> [Either a b]
|
|
toEitherList = bifoldMap (\x -> [Left x]) (\y -> [Right y])
|