{-# 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 { forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer :: b (Const a) }
  deriving  (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 :: forall a b. (a -> b) -> Container b a -> Container b b
fmap a -> b
f
    = forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer

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

instance TraversableB b => Traversable (Container b) where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Container b a -> f (Container b b)
traverse a -> f b
f
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer

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

    Container b (a -> b)
l <*> :: forall a b. Container b (a -> b) -> Container b a -> Container b b
<*> Container b a
r
      = forall (b :: (* -> *) -> *) a. b (Const a) -> Container b a
Container forall a b. (a -> b) -> a -> 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 a' x. Const (a -> a') x -> Const a x -> Const a' x
appConst (forall (b :: (* -> *) -> *) a. Container b a -> b (Const a)
getContainer Container b (a -> b)
l) (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 :: forall a a' x. Const (a -> a') x -> Const a x -> Const a' x
appConst (Const a -> a'
f) (Const a
a)
          = 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 { forall (b :: (* -> *) -> *) e. ErrorContainer b e -> b (Either e)
getErrorContainer :: b (Either e) }
  deriving (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 :: forall a b. (a -> b) -> ErrorContainer b a -> ErrorContainer b b
fmap a -> b
f
    = forall (b :: (* -> *) -> *) e. b (Either e) -> ErrorContainer b e
ErrorContainer forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
bmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: (* -> *) -> *) e. ErrorContainer b e -> b (Either e)
getErrorContainer

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

instance TraversableB b => Traversable (ErrorContainer b) where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ErrorContainer b a -> f (ErrorContainer b b)
traverse a -> f b
f
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (b :: (* -> *) -> *) e. b (Either e) -> ErrorContainer b e
ErrorContainer forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: (* -> *) -> *) e. ErrorContainer b e -> b (Either e)
getErrorContainer

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