{-# LANGUAGE UndecidableInstances #-}
module Barbies.Internal.Containers
  (
    Container(..)
  , ErrorContainer(..)
  )

where

import Data.Functor.Barbie
import Data.Bifunctor (first)
import Data.Bitraversable (bitraverse)
import Data.Functor.Const
import GHC.Generics (Generic)


-- {{ Container ---------------------------------------------------------------

-- | Wrapper for barbies that act as containers of @a@
--   by wearing @('Const' a)@.
newtype Container b a
  = Container { Container b a -> b (Const a)
getContainer :: b (Const a) }
  deriving  ((forall x. Container b a -> Rep (Container b a) x)
-> (forall x. Rep (Container b a) x -> Container b a)
-> Generic (Container b a)
forall x. Rep (Container b a) x -> Container b a
forall x. Container b a -> Rep (Container b a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (b :: (* -> *) -> *) a x.
Rep (Container b a) x -> Container b a
forall (b :: (* -> *) -> *) a x.
Container b a -> Rep (Container b a) x
$cto :: forall (b :: (* -> *) -> *) a x.
Rep (Container b a) x -> Container b a
$cfrom :: forall (b :: (* -> *) -> *) a x.
Container b a -> Rep (Container b a) x
Generic)

deriving instance Eq  (b (Const a)) => Eq  (Container b a)
deriving instance Ord (b (Const a)) => Ord (Container b a)

deriving instance Read (b (Const a)) => Read (Container b a)
deriving instance Show (b (Const a)) => Show (Container b a)

instance FunctorB b => Functor (Container b) where
  fmap :: (a -> b) -> Container b a -> Container b b
fmap a -> b
f
    = b (Const b) -> Container b b
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (b (Const b) -> Container b b)
-> (Container b a -> b (Const b)) -> Container b a -> Container b b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Const a a -> Const b a) -> b (Const a) -> b (Const b)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap ((a -> b) -> Const a a -> Const b a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)) (b (Const a) -> b (Const b))
-> (Container b a -> b (Const a)) -> Container b a -> b (Const b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container b a -> b (Const a)
forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer

instance TraversableB b => Foldable (Container b) where
  foldMap :: (a -> m) -> Container b a -> m
foldMap a -> m
f
    = (forall a. Const a a -> m) -> b (Const a) -> m
forall k (b :: (k -> *) -> *) m (f :: k -> *).
(TraversableB b, Monoid m) =>
(forall (a :: k). f a -> m) -> b f -> m
bfoldMap (a -> m
f (a -> m) -> (Const a a -> a) -> Const a a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const a a -> a
forall a k (b :: k). Const a b -> a
getConst) (b (Const a) -> m)
-> (Container b a -> b (Const a)) -> Container b a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container b a -> b (Const a)
forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer

instance TraversableB b => Traversable (Container b) where
    traverse :: (a -> f b) -> Container b a -> f (Container b b)
traverse a -> f b
f
      = (b (Const b) -> Container b b)
-> f (b (Const b)) -> f (Container b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b (Const b) -> Container b b
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (f (b (Const b)) -> f (Container b b))
-> (Container b a -> f (b (Const b)))
-> Container b a
-> f (Container b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Const a a -> f (Const b a))
-> b (Const a) -> f (b (Const b))
forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse ((a -> f b) -> (a -> f a) -> Const a a -> f (Const b a)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f b
f a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (b (Const a) -> f (b (Const b)))
-> (Container b a -> b (Const a))
-> Container b a
-> f (b (Const b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container b a -> b (Const a)
forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer

instance ApplicativeB b => Applicative (Container b) where
    pure :: a -> Container b a
pure a
a
      = b (Const a) -> Container b a
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (b (Const a) -> Container b a) -> b (Const a) -> Container b a
forall a b. (a -> b) -> a -> b
$ (forall a. Const a a) -> b (Const a)
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> b f
bpure (a -> Const a a
forall k a (b :: k). a -> Const a b
Const a
a)

    Container b (a -> b)
l <*> :: Container b (a -> b) -> Container b a -> Container b b
<*> Container b a
r
      = b (Const b) -> Container b b
forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container (b (Const b) -> Container b b) -> b (Const b) -> Container b b
forall a b. (a -> b) -> a -> b
$ (forall a. Const (a -> b) a -> Const a a -> Const b a)
-> b (Const (a -> b)) -> b (Const a) -> b (Const b)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (h :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a -> g a -> h a) -> b f -> b g -> b h
bzipWith forall a. Const (a -> b) a -> Const a a -> Const b a
forall a a' x. Const (a -> a') x -> Const a x -> Const a' x
appConst (Container b (a -> b) -> b (Const (a -> b))
forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer Container b (a -> b)
l) (Container b a -> b (Const a)
forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer Container b a
r)
      where
        appConst :: Const (a -> a') x -> Const a x -> Const a' x
        appConst :: Const (a -> a') x -> Const a x -> Const a' x
appConst (Const a -> a'
f) (Const a
a)
          = a' -> Const a' x
forall k a (b :: k). a -> Const a b
Const (a -> a'
f a
a)

-- }} Container ---------------------------------------------------------------


-- {{ ErrorContainer ----------------------------------------------------------

-- | Wrapper for barbies that act as containers of @e@
--   by wearing @'Either' e@.
newtype ErrorContainer b e
  = ErrorContainer { ErrorContainer b e -> b (Either e)
getErrorContainer :: b (Either e) }
  deriving ((forall x. ErrorContainer b e -> Rep (ErrorContainer b e) x)
-> (forall x. Rep (ErrorContainer b e) x -> ErrorContainer b e)
-> Generic (ErrorContainer b e)
forall x. Rep (ErrorContainer b e) x -> ErrorContainer b e
forall x. ErrorContainer b e -> Rep (ErrorContainer b e) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (b :: (* -> *) -> *) e x.
Rep (ErrorContainer b e) x -> ErrorContainer b e
forall (b :: (* -> *) -> *) e x.
ErrorContainer b e -> Rep (ErrorContainer b e) x
$cto :: forall (b :: (* -> *) -> *) e x.
Rep (ErrorContainer b e) x -> ErrorContainer b e
$cfrom :: forall (b :: (* -> *) -> *) e x.
ErrorContainer b e -> Rep (ErrorContainer b e) x
Generic)


deriving instance Eq  (b (Either  e)) => Eq  (ErrorContainer b e)
deriving instance Ord (b (Either  e)) => Ord (ErrorContainer b e)

deriving instance Read (b (Either  e)) => Read (ErrorContainer b e)
deriving instance Show (b (Either  e)) => Show (ErrorContainer b e)


instance FunctorB b => Functor (ErrorContainer b) where
  fmap :: (a -> b) -> ErrorContainer b a -> ErrorContainer b b
fmap a -> b
f
    = b (Either b) -> ErrorContainer b b
forall (b :: (* -> *) -> *) e. b (Either e) -> ErrorContainer b e
ErrorContainer (b (Either b) -> ErrorContainer b b)
-> (ErrorContainer b a -> b (Either b))
-> ErrorContainer b a
-> ErrorContainer b b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Either a a -> Either b a)
-> b (Either a) -> b (Either b)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap ((a -> b) -> Either a a -> Either b a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)) (b (Either a) -> b (Either b))
-> (ErrorContainer b a -> b (Either a))
-> ErrorContainer b a
-> b (Either b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorContainer b a -> b (Either a)
forall (b :: (* -> *) -> *) e. ErrorContainer b e -> b (Either e)
getErrorContainer

instance TraversableB b => Foldable (ErrorContainer b) where
  foldMap :: (a -> m) -> ErrorContainer b a -> m
foldMap a -> m
f
    = (forall a. Either a a -> m) -> b (Either a) -> m
forall k (b :: (k -> *) -> *) m (f :: k -> *).
(TraversableB b, Monoid m) =>
(forall (a :: k). f a -> m) -> b f -> m
bfoldMap ((a -> m) -> (a -> m) -> Either a a -> m
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m
f (m -> a -> m
forall a b. a -> b -> a
const m
forall a. Monoid a => a
mempty)) (b (Either a) -> m)
-> (ErrorContainer b a -> b (Either a)) -> ErrorContainer b a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorContainer b a -> b (Either a)
forall (b :: (* -> *) -> *) e. ErrorContainer b e -> b (Either e)
getErrorContainer

instance TraversableB b => Traversable (ErrorContainer b) where
    traverse :: (a -> f b) -> ErrorContainer b a -> f (ErrorContainer b b)
traverse a -> f b
f
      = (b (Either b) -> ErrorContainer b b)
-> f (b (Either b)) -> f (ErrorContainer b b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b (Either b) -> ErrorContainer b b
forall (b :: (* -> *) -> *) e. b (Either e) -> ErrorContainer b e
ErrorContainer (f (b (Either b)) -> f (ErrorContainer b b))
-> (ErrorContainer b a -> f (b (Either b)))
-> ErrorContainer b a
-> f (ErrorContainer b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Either a a -> f (Either b a))
-> b (Either a) -> f (b (Either b))
forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse ((a -> f b) -> (a -> f a) -> Either a a -> f (Either b a)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f b
f a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (b (Either a) -> f (b (Either b)))
-> (ErrorContainer b a -> b (Either a))
-> ErrorContainer b a
-> f (b (Either b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorContainer b a -> b (Either a)
forall (b :: (* -> *) -> *) e. ErrorContainer b e -> b (Either e)
getErrorContainer

-- }} ErrorContainer ----------------------------------------------------------