#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 710
#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 eq (Pure x1) (Pure x2) = eq x1 x2
liftEq _ (Pure _) (Other _) = False
liftEq _ (Other _) (Pure _) = False
liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2
instance (Ord1 f) => Ord1 (Lift f) where
liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
liftCompare _ (Pure _) (Other _) = LT
liftCompare _ (Other _) (Pure _) = GT
liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2
instance (Read1 f) => Read1 (Lift f) where
liftReadsPrec rp rl = readsData $
readsUnaryWith rp "Pure" Pure `mappend`
readsUnaryWith (liftReadsPrec rp rl) "Other" Other
instance (Show1 f) => Show1 (Lift f) where
liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
liftShowsPrec sp sl d (Other y) =
showsUnaryWith (liftShowsPrec sp sl) "Other" d y
instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1
instance (Functor f) => Functor (Lift f) where
fmap f (Pure x) = Pure (f x)
fmap f (Other y) = Other (fmap f y)
instance (Foldable f) => Foldable (Lift f) where
foldMap f (Pure x) = f x
foldMap f (Other y) = foldMap f y
instance (Traversable f) => Traversable (Lift f) where
traverse f (Pure x) = Pure <$> f x
traverse f (Other y) = Other <$> traverse f y
instance (Applicative f) => Applicative (Lift f) where
pure = Pure
Pure f <*> Pure x = Pure (f x)
Pure f <*> Other y = Other (f <$> y)
Other f <*> Pure x = Other (($ x) <$> f)
Other f <*> Other y = Other (f <*> y)
instance (Alternative f) => Alternative (Lift f) where
empty = Other empty
Pure x <|> _ = Pure x
Other _ <|> Pure y = Pure y
Other x <|> Other y = Other (x <|> y)
unLift :: (Applicative f) => Lift f a -> f a
unLift (Pure x) = pure x
unLift (Other e) = e
mapLift :: (f a -> g a) -> Lift f a -> Lift g a
mapLift _ (Pure x) = Pure x
mapLift f (Other e) = Other (f e)
elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r
elimLift f _ (Pure x) = f x
elimLift _ g (Other e) = g e
type Errors e = Lift (Constant e)
runErrors :: Errors e a -> Either e a
runErrors (Other (Constant e)) = Left e
runErrors (Pure x) = Right x
failure :: e -> Errors e a
failure e = Other (Constant e)
eitherToErrors :: Either e a -> Errors e a
eitherToErrors = either failure Pure