{-# 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) -> Const a a -> Const a b
|$| Const a :: a
a = a -> Const a b
forall k a (b :: k). a -> Const a b
Const a
a
{-# INLINABLE (|$|) #-}
instance Monoid a => ProductIsoApplicative (Const a) where
pureP :: a -> Const a a
pureP _ = a -> Const a a
forall k a (b :: k). a -> Const a b
Const a
forall a. Monoid a => a
mempty
{-# INLINABLE pureP #-}
Const a :: a
a |*| :: Const a (a -> b) -> Const a a -> Const a b
|*| Const b :: a
b = a -> Const a b
forall k a (b :: k). a -> Const a b
Const (a -> Const a b) -> a -> Const a b
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b
{-# INLINABLE (|*|) #-}
instance Monoid a => ProductIsoEmpty (Const a) () where
pureE :: Const a ()
pureE = () -> Const a ()
forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP ()
{-# INLINABLE pureE #-}
peRight :: Const a (a, ()) -> Const a a
peRight (Const a :: a
a) = a -> Const a a
forall k a (b :: k). a -> Const a b
Const a
a
{-# INLINABLE peRight #-}
peLeft :: Const a ((), a) -> Const a a
peLeft (Const a :: a
a) = a -> Const a a
forall k a (b :: k). a -> Const a b
Const a
a
{-# INLINABLE peLeft #-}
newtype WrappedFunctor f a = WrapFunctor { WrappedFunctor f a -> f a
unwrapFunctor :: f a }
instance Functor f => ProductIsoFunctor (WrappedFunctor f) where
f :: a -> b
f |$| :: (a -> b) -> WrappedFunctor f a -> WrappedFunctor f b
|$| fa :: WrappedFunctor f a
fa = f b -> WrappedFunctor f b
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor (f b -> WrappedFunctor f b) -> f b -> WrappedFunctor f b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WrappedFunctor f a -> f a
forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor WrappedFunctor f a
fa
{-# INLINABLE (|$|) #-}
instance Applicative f => ProductIsoApplicative (WrappedFunctor f) where
pureP :: a -> WrappedFunctor f a
pureP = f a -> WrappedFunctor f a
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor (f a -> WrappedFunctor f a)
-> (a -> f a) -> a -> WrappedFunctor f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINABLE pureP #-}
WrapFunctor ff :: f (a -> b)
ff |*| :: WrappedFunctor f (a -> b)
-> WrappedFunctor f a -> WrappedFunctor f b
|*| WrapFunctor fa :: f a
fa = f b -> WrappedFunctor f b
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor (f b -> WrappedFunctor f b) -> f b -> WrappedFunctor f b
forall a b. (a -> b) -> a -> b
$ f (a -> b)
ff f (a -> b) -> f a -> f b
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 :: WrappedFunctor f a
emptyP = f a -> WrappedFunctor f a
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor f a
forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINABLE emptyP #-}
WrapFunctor fa1 :: f a
fa1 ||| :: WrappedFunctor f a -> WrappedFunctor f a -> WrappedFunctor f a
||| WrapFunctor fa2 :: f a
fa2 = f a -> WrappedFunctor f a
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor (f a -> WrappedFunctor f a) -> f a -> WrappedFunctor f a
forall a b. (a -> b) -> a -> b
$ f a
fa1 f a -> f a -> f a
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 = () -> WrappedFunctor f ()
forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP ()
{-# INLINABLE pureE #-}
peRight :: WrappedFunctor f (a, ()) -> WrappedFunctor f a
peRight = f a -> WrappedFunctor f a
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor (f a -> WrappedFunctor f a)
-> (WrappedFunctor f (a, ()) -> f a)
-> WrappedFunctor f (a, ())
-> WrappedFunctor f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, ()) -> a) -> f (a, ()) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, ()) -> a
forall a b. (a, b) -> a
fst (f (a, ()) -> f a)
-> (WrappedFunctor f (a, ()) -> f (a, ()))
-> WrappedFunctor f (a, ())
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedFunctor f (a, ()) -> f (a, ())
forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor
{-# INLINABLE peRight #-}
peLeft :: WrappedFunctor f ((), a) -> WrappedFunctor f a
peLeft = f a -> WrappedFunctor f a
forall (f :: * -> *) a. f a -> WrappedFunctor f a
WrapFunctor (f a -> WrappedFunctor f a)
-> (WrappedFunctor f ((), a) -> f a)
-> WrappedFunctor f ((), a)
-> WrappedFunctor f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((), a) -> a) -> f ((), a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), a) -> a
forall a b. (a, b) -> b
snd (f ((), a) -> f a)
-> (WrappedFunctor f ((), a) -> f ((), a))
-> WrappedFunctor f ((), a)
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedFunctor f ((), a) -> f ((), a)
forall (f :: * -> *) a. WrappedFunctor f a -> f a
unwrapFunctor
{-# INLINABLE peLeft #-}
newtype WrappedAlter f a b = WrapAlter { WrappedAlter f a b -> Const (f a) b
unWrapAlter :: Const (f a) b }
instance ProductIsoFunctor (WrappedAlter f a) where
_ |$| :: (a -> b) -> WrappedAlter f a a -> WrappedAlter f a b
|$| WrapAlter (Const fa :: f a
fa) = Const (f a) b -> WrappedAlter f a b
forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter (Const (f a) b -> WrappedAlter f a b)
-> Const (f a) b -> WrappedAlter f a b
forall a b. (a -> b) -> a -> b
$ f a -> Const (f 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 :: a -> WrappedAlter f a a
pureP _ = Const (f a) a -> WrappedAlter f a a
forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter (Const (f a) a -> WrappedAlter f a a)
-> Const (f a) a -> WrappedAlter f a a
forall a b. (a -> b) -> a -> b
$ f a -> Const (f a) a
forall k a (b :: k). a -> Const a b
Const f a
forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINABLE pureP #-}
WrapAlter (Const a :: f a
a) |*| :: WrappedAlter f a (a -> b)
-> WrappedAlter f a a -> WrappedAlter f a b
|*| WrapAlter (Const b :: f a
b) = Const (f a) b -> WrappedAlter f a b
forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter (Const (f a) b -> WrappedAlter f a b)
-> Const (f a) b -> WrappedAlter f a b
forall a b. (a -> b) -> a -> b
$ f a -> Const (f a) b
forall k a (b :: k). a -> Const a b
Const (f a -> Const (f a) b) -> f a -> Const (f a) b
forall a b. (a -> b) -> a -> b
$ f a
a f a -> f a -> f 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 = () -> WrappedAlter f a ()
forall (f :: * -> *) a.
(ProductIsoApplicative f, ProductConstructor a) =>
a -> f a
pureP ()
{-# INLINABLE pureE #-}
peRight :: WrappedAlter f a (a, ()) -> WrappedAlter f a a
peRight = Const (f a) a -> WrappedAlter f a a
forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter (Const (f a) a -> WrappedAlter f a a)
-> (WrappedAlter f a (a, ()) -> Const (f a) a)
-> WrappedAlter f a (a, ())
-> WrappedAlter f a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, ()) -> a) -> Const (f a) (a, ()) -> Const (f a) a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, ()) -> a
forall a b. (a, b) -> a
fst (Const (f a) (a, ()) -> Const (f a) a)
-> (WrappedAlter f a (a, ()) -> Const (f a) (a, ()))
-> WrappedAlter f a (a, ())
-> Const (f a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedAlter f a (a, ()) -> Const (f a) (a, ())
forall (f :: * -> *) a b. WrappedAlter f a b -> Const (f a) b
unWrapAlter
{-# INLINABLE peRight #-}
peLeft :: WrappedAlter f a ((), a) -> WrappedAlter f a a
peLeft = Const (f a) a -> WrappedAlter f a a
forall (f :: * -> *) a b. Const (f a) b -> WrappedAlter f a b
WrapAlter (Const (f a) a -> WrappedAlter f a a)
-> (WrappedAlter f a ((), a) -> Const (f a) a)
-> WrappedAlter f a ((), a)
-> WrappedAlter f a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((), a) -> a) -> Const (f a) ((), a) -> Const (f a) a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), a) -> a
forall a b. (a, b) -> b
snd (Const (f a) ((), a) -> Const (f a) a)
-> (WrappedAlter f a ((), a) -> Const (f a) ((), a))
-> WrappedAlter f a ((), a)
-> Const (f a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedAlter f a ((), a) -> Const (f a) ((), a)
forall (f :: * -> *) a b. WrappedAlter f a b -> Const (f a) b
unWrapAlter