{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE MultiParamTypeClasses #-}
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 #-}
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 #-}
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