{-# LANGUAGE FlexibleInstances #-}

module Hasklet3 where

import Data.Semigroup (All(..))


-- | A list of pairs of elements of type a AND b.
--
--   type ListP a b = [(a,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.
--
--   type ListE a b = [Either a 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)))
--

instance Bifunctor ListP where
  bimap _ _ NilP          = NilP
  bimap f g (ConsP x y t) = ConsP (f x) (g y) (bimap f g t)

instance Bifunctor ListE where
  bimap _ _ NilE        = NilE
  bimap f g (ConsL x t) = ConsL (f x) (bimap f g t)
  bimap f g (ConsR y t) = ConsR (g y) (bimap f g t)


-- | 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 f = bimap f id
-- 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 -> d) -> t a b -> t a d
mapR = bimap id


-- Functor instances and flipped Functor instances for ListP and ListE
--
-- instance Functor (ListP a) where
--   fmap = mapR
-- 
-- instance Functor (ListE a) where
--   fmap = mapR
-- 
-- newtype ListP' b a = FlipP { unFlipP :: ListP a b }
--   deriving (Eq,Show)
-- 
-- newtype ListE' b a = FlipE { unFlipE :: ListE a b }
--   deriving (Eq,Show)
-- 
-- instance Functor (ListP' b) where
--   fmap f = FlipP . mapL f . unFlipP
-- 
-- instance Functor (ListE' b) where
--   fmap f = FlipE . mapL f . unFlipE


newtype Flip t a b = Flip { unFlip :: t b a }
  deriving (Eq,Show)

instance Bifunctor t => Functor (t a) where
  fmap = mapR

instance {-# OVERLAPPING #-} Bifunctor t => Functor (Flip t b) where
  fmap f = Flip . mapL f . unFlip


-- | 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)
--

instance Bifoldable ListP where
  bifoldr _ _ c NilP          = c
  bifoldr f g c (ConsP x y t) = f x (g y (bifoldr f g c t))

instance Bifoldable ListE where
  bifoldr _ _ c NilE        = c
  bifoldr f g c (ConsL x t) = f x (bifoldr f g c t)
  bifoldr f g c (ConsR y t) = g y (bifoldr f g c t)


-- | 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 f = bifoldr f (flip const)  -- flip const = (\a c -> c)
-- foldrL = flip bifoldr (flip const)


-- | 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 (flip const)


-- | Map each element in a bifoldable to a common monoid type and combine
--   the results.
--
--   >>> 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 :: (Bifoldable t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m
bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty


-- | 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])