{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Data.Functor.ProductIsomorphic.Instances
-- Copyright   : 2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines functor instances morphed functions
-- are restricted to products.
module Data.Functor.ProductIsomorphic.Instances (
  WrappedFunctor (..),
  WrappedAlter (..),
  ) where

import Data.Monoid (Monoid, mempty, (<>))
import Control.Applicative
  ((<$>), Applicative, pure, (<*>),
   Alternative, empty, (<|>),
   Const (..))

import Data.Functor.ProductIsomorphic.Class
  (ProductIsoFunctor(..), ProductIsoApplicative (..),
   ProductIsoAlternative (..), ProductIsoEmpty (..))


instance ProductIsoFunctor (Const a) where
  a -> b
_ |$| :: forall a b.
ProductConstructor (a -> b) =>
(a -> b) -> Const a a -> Const a b
|$| Const a
a = forall {k} a (b :: k). a -> Const a b
Const a
a
  {-# INLINABLE (|$|) #-}

instance Monoid a => ProductIsoApplicative (Const a) where
  pureP :: forall a. ProductConstructor a => a -> Const a a
pureP a
_ = forall {k} a (b :: k). a -> Const a b
Const forall a. Monoid a => a
mempty
  {-# INLINABLE pureP #-}
  Const a
a |*| :: forall a b. Const a (a -> b) -> Const a a -> Const a b
|*| Const a
b = forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ a
a forall a. Semigroup a => a -> a -> a
<> a
b
  {-# INLINABLE (|*|) #-}

instance Monoid a => ProductIsoEmpty (Const a) () where
  pureE :: Const a ()
pureE = forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP ()
  {-# INLINABLE pureE #-}
  peRight :: forall a. Const a (a, ()) -> Const a a
peRight (Const a
a) = forall {k} a (b :: k). a -> Const a b
Const a
a
  {-# INLINABLE peRight #-}
  peLeft :: forall a. Const a ((), a) -> Const a a
peLeft (Const a
a) = forall {k} a (b :: k). a -> Const a b
Const a
a
  {-# INLINABLE peLeft #-}


-- | Wrapped functor type to make instances of product-iso functors.
newtype WrappedFunctor f a = WrapFunctor { forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor :: f a }

instance Functor f => ProductIsoFunctor (WrappedFunctor f) where
  a -> b
f |$| :: forall a b.
ProductConstructor (a -> b) =>
(a -> b) -> WrappedFunctor f a -> WrappedFunctor f b
|$| WrappedFunctor f a
fa = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall a b. (a -> b) -> a -> b
$ a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor WrappedFunctor f a
fa
  {-# INLINABLE (|$|) #-}

instance Applicative f => ProductIsoApplicative (WrappedFunctor f) where
  pureP :: forall a. ProductConstructor a => a -> WrappedFunctor f a
pureP = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINABLE pureP #-}
  WrapFunctor f (a -> b)
ff |*| :: forall a b.
WrappedFunctor f (a -> b)
-> WrappedFunctor f a -> WrappedFunctor f b
|*| WrapFunctor f a
fa = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall a b. (a -> b) -> a -> b
$ f (a -> b)
ff forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
fa
  {-# INLINABLE (|*|) #-}

instance Alternative f => ProductIsoAlternative (WrappedFunctor f) where
  emptyP :: forall a. WrappedFunctor f a
emptyP = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINABLE emptyP #-}
  WrapFunctor f a
fa1 ||| :: forall a.
WrappedFunctor f a -> WrappedFunctor f a -> WrappedFunctor f a
||| WrapFunctor f a
fa2 = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall a b. (a -> b) -> a -> b
$ f a
fa1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
fa2
  {-# INLINABLE (|||) #-}

instance Applicative f => ProductIsoEmpty (WrappedFunctor f) () where
  pureE :: WrappedFunctor f ()
pureE   = forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP ()
  {-# INLINABLE pureE #-}
  peRight :: forall a. WrappedFunctor f (a, ()) -> WrappedFunctor f a
peRight = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor
  {-# INLINABLE peRight #-}
  peLeft :: forall a. WrappedFunctor f ((), a) -> WrappedFunctor f a
peLeft  = forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor
  {-# INLINABLE peLeft #-}


-- | Wrapped Const Alternative objects to make instances like Const functor.
newtype WrappedAlter f a b = WrapAlter { forall (f :: * -> *) a b. WrappedAlter f a b -> Const (f a) b
unWrapAlter :: Const (f a) b }

instance ProductIsoFunctor (WrappedAlter f a) where
  a -> b
_ |$| :: forall a b.
ProductConstructor (a -> b) =>
(a -> b) -> WrappedAlter f a a -> WrappedAlter f a b
|$| WrapAlter (Const f a
fa) = forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const f a
fa
  {-# INLINABLE (|$|) #-}

instance Alternative f => ProductIsoApplicative (WrappedAlter f a) where
  pureP :: forall a. ProductConstructor a => a -> WrappedAlter f a a
pureP a
_ = forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINABLE pureP #-}
  WrapAlter (Const f a
a) |*| :: forall a b.
WrappedAlter f a (a -> b)
-> WrappedAlter f a a -> WrappedAlter f a b
|*| WrapAlter (Const f a
b) = forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ f a
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
b
  {-# INLINABLE (|*|) #-}

instance Alternative f => ProductIsoEmpty (WrappedAlter f a) () where
  pureE :: WrappedAlter f a ()
pureE   = forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP ()
  {-# INLINABLE pureE #-}
  peRight :: forall a. WrappedAlter f a (a, ()) -> WrappedAlter f a a
peRight = forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. WrappedAlter f a b -> Const (f a) b
unWrapAlter
  {-# INLINABLE peRight #-}
  peLeft :: forall a. WrappedAlter f a ((), a) -> WrappedAlter f a a
peLeft  = forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. WrappedAlter f a b -> Const (f a) b
unWrapAlter