{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE AutoDeriveTypeable #-}
#endif
module Control.Applicative.Lift (
Lift(..),
unLift,
mapLift,
elimLift,
Errors,
runErrors,
failure,
eitherToErrors
) where
import Data.Functor.Classes
import Control.Applicative
import Data.Foldable (Foldable(foldMap))
import Data.Functor.Constant
import Data.Monoid (Monoid(..))
import Data.Traversable (Traversable(traverse))
data Lift f a = Pure a | Other (f a)
instance (Eq1 f) => Eq1 (Lift f) where
liftEq :: forall a b. (a -> b -> Bool) -> Lift f a -> Lift f b -> Bool
liftEq a -> b -> Bool
eq (Pure a
x1) (Pure b
x2) = a -> b -> Bool
eq a
x1 b
x2
liftEq a -> b -> Bool
_ (Pure a
_) (Other f b
_) = Bool
False
liftEq a -> b -> Bool
_ (Other f a
_) (Pure b
_) = Bool
False
liftEq a -> b -> Bool
eq (Other f a
y1) (Other f b
y2) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq f a
y1 f b
y2
{-# INLINE liftEq #-}
instance (Ord1 f) => Ord1 (Lift f) where
liftCompare :: forall a b.
(a -> b -> Ordering) -> Lift f a -> Lift f b -> Ordering
liftCompare a -> b -> Ordering
comp (Pure a
x1) (Pure b
x2) = a -> b -> Ordering
comp a
x1 b
x2
liftCompare a -> b -> Ordering
_ (Pure a
_) (Other f b
_) = Ordering
LT
liftCompare a -> b -> Ordering
_ (Other f a
_) (Pure b
_) = Ordering
GT
liftCompare a -> b -> Ordering
comp (Other f a
y1) (Other f b
y2) = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
comp f a
y1 f b
y2
{-# INLINE liftCompare #-}
instance (Read1 f) => Read1 (Lift f) where
liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Lift f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rp String
"Pure" forall (f :: * -> *) a. a -> Lift f a
Pure forall a. Monoid a => a -> a -> a
`mappend`
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) String
"Other" forall (f :: * -> *) a. f a -> Lift f a
Other
instance (Show1 f) => Show1 (Lift f) where
liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Lift f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
_ Int
d (Pure a
x) = forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
sp String
"Pure" Int
d a
x
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (Other f a
y) =
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) String
"Other" Int
d f a
y
instance (Eq1 f, Eq a) => Eq (Lift f a) where == :: Lift f a -> Lift f a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1
instance (Ord1 f, Ord a) => Ord (Lift f a) where compare :: Lift f a -> Lift f a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1
instance (Read1 f, Read a) => Read (Lift f a) where readsPrec :: Int -> ReadS (Lift f a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1
instance (Show1 f, Show a) => Show (Lift f a) where showsPrec :: Int -> Lift f a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1
instance (Functor f) => Functor (Lift f) where
fmap :: forall a b. (a -> b) -> Lift f a -> Lift f b
fmap a -> b
f (Pure a
x) = forall (f :: * -> *) a. a -> Lift f a
Pure (a -> b
f a
x)
fmap a -> b
f (Other f a
y) = forall (f :: * -> *) a. f a -> Lift f a
Other (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
y)
{-# INLINE fmap #-}
instance (Foldable f) => Foldable (Lift f) where
foldMap :: forall m a. Monoid m => (a -> m) -> Lift f a -> m
foldMap a -> m
f (Pure a
x) = a -> m
f a
x
foldMap a -> m
f (Other f a
y) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f f a
y
{-# INLINE foldMap #-}
instance (Traversable f) => Traversable (Lift f) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Lift f a -> f (Lift f b)
traverse a -> f b
f (Pure a
x) = forall (f :: * -> *) a. a -> Lift f a
Pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
traverse a -> f b
f (Other f a
y) = forall (f :: * -> *) a. f a -> Lift f a
Other forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f f a
y
{-# INLINE traverse #-}
instance (Applicative f) => Applicative (Lift f) where
pure :: forall a. a -> Lift f a
pure = forall (f :: * -> *) a. a -> Lift f a
Pure
{-# INLINE pure #-}
Pure a -> b
f <*> :: forall a b. Lift f (a -> b) -> Lift f a -> Lift f b
<*> Pure a
x = forall (f :: * -> *) a. a -> Lift f a
Pure (a -> b
f a
x)
Pure a -> b
f <*> Other f a
y = forall (f :: * -> *) a. f a -> Lift f a
Other (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
y)
Other f (a -> b)
f <*> Pure a
x = forall (f :: * -> *) a. f a -> Lift f a
Other ((forall a b. (a -> b) -> a -> b
$ a
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a -> b)
f)
Other f (a -> b)
f <*> Other f a
y = forall (f :: * -> *) a. f a -> Lift f a
Other (f (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
y)
{-# INLINE (<*>) #-}
instance (Alternative f) => Alternative (Lift f) where
empty :: forall a. Lift f a
empty = forall (f :: * -> *) a. f a -> Lift f a
Other forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
Pure a
x <|> :: forall a. Lift f a -> Lift f a -> Lift f a
<|> Lift f a
_ = forall (f :: * -> *) a. a -> Lift f a
Pure a
x
Other f a
_ <|> Pure a
y = forall (f :: * -> *) a. a -> Lift f a
Pure a
y
Other f a
x <|> Other f a
y = forall (f :: * -> *) a. f a -> Lift f a
Other (f a
x forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
y)
{-# INLINE (<|>) #-}
unLift :: (Applicative f) => Lift f a -> f a
unLift :: forall (f :: * -> *) a. Applicative f => Lift f a -> f a
unLift (Pure a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
unLift (Other f a
e) = f a
e
{-# INLINE unLift #-}
mapLift :: (f a -> g a) -> Lift f a -> Lift g a
mapLift :: forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> Lift f a -> Lift g a
mapLift f a -> g a
_ (Pure a
x) = forall (f :: * -> *) a. a -> Lift f a
Pure a
x
mapLift f a -> g a
f (Other f a
e) = forall (f :: * -> *) a. f a -> Lift f a
Other (f a -> g a
f f a
e)
{-# INLINE mapLift #-}
elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r
elimLift :: forall a r (f :: * -> *). (a -> r) -> (f a -> r) -> Lift f a -> r
elimLift a -> r
f f a -> r
_ (Pure a
x) = a -> r
f a
x
elimLift a -> r
_ f a -> r
g (Other f a
e) = f a -> r
g f a
e
{-# INLINE elimLift #-}
type Errors e = Lift (Constant e)
runErrors :: Errors e a -> Either e a
runErrors :: forall e a. Errors e a -> Either e a
runErrors (Other (Constant e
e)) = forall a b. a -> Either a b
Left e
e
runErrors (Pure a
x) = forall a b. b -> Either a b
Right a
x
{-# INLINE runErrors #-}
failure :: e -> Errors e a
failure :: forall e a. e -> Errors e a
failure e
e = forall (f :: * -> *) a. f a -> Lift f a
Other (forall {k} a (b :: k). a -> Constant a b
Constant e
e)
{-# INLINE failure #-}
eitherToErrors :: Either e a -> Errors e a
eitherToErrors :: forall e a. Either e a -> Errors e a
eitherToErrors = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. e -> Errors e a
failure forall (f :: * -> *) a. a -> Lift f a
Pure