    {-# LANGUAGE CPP #-}
    #if __GLASGOW_HASKELL__ >= 702
    {-# LANGUAGE Safe #-}
    #endif
    #if __GLASGOW_HASKELL__ >= 710
    {-# LANGUAGE AutoDeriveTypeable #-}
    #endif
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Applicative.Lift
    -- Copyright   :  (c) Ross Paterson 2010
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  R.Paterson@city.ac.uk
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- Adding a new kind of pure computation to an applicative functor.
    -----------------------------------------------------------------------------

    module Control.Applicative.Lift (
        -- * Lifting an applicative
        Lift(..),
        unLift,
        mapLift,
        elimLift,
        -- * Collecting errors
        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))

    -- | Applicative functor formed by adding pure computations to a given
    -- applicative functor.
    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) = (a -> b -> Bool) -> f a -> f b -> Bool
    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) = (a -> b -> Ordering) -> f a -> f b -> Ordering
    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 = (String -> ReadS (Lift f a)) -> Int -> ReadS (Lift f a)
    forall a. (String -> ReadS a) -> Int -> ReadS a
    readsData ((String -> ReadS (Lift f a)) -> Int -> ReadS (Lift f a))
    -> (String -> ReadS (Lift f a)) -> Int -> ReadS (Lift f a)
    forall a b. (a -> b) -> a -> b
    $
            (Int -> ReadS a)
    -> String -> (a -> Lift f a) -> String -> ReadS (Lift f a)
    forall a t.
    (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
    readsUnaryWith Int -> ReadS a
    rp String
    "Pure" a -> Lift f a
    forall (f :: * -> *) a. a -> Lift f a
    Pure (String -> ReadS (Lift f a))
    -> (String -> ReadS (Lift f a)) -> String -> ReadS (Lift f a)
    forall a. Monoid a => a -> a -> a
    `mappend`
            (Int -> ReadS (f a))
    -> String -> (f a -> Lift f a) -> String -> ReadS (Lift f a)
    forall a t.
    (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
    readsUnaryWith ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
    forall (f :: * -> *) a.
    Read1 f =>
    (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
    liftReadsPrec Int -> ReadS a
    rp ReadS [a]
    rl) String
    "Other" f a -> Lift f a
    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) = (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
    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) =
            (Int -> f a -> ShowS) -> String -> Int -> f a -> ShowS
    forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
    showsUnaryWith ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
    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
    (==) = 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 = Lift f a -> Lift f a -> Ordering
    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 = Int -> ReadS (Lift f a)
    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 = Int -> Lift f a -> ShowS
    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) = b -> Lift f b
    forall (f :: * -> *) a. a -> Lift f a
    Pure (a -> b
    f a
    x)
        fmap a -> b
    f (Other f a
    y) = f b -> Lift f b
    forall (f :: * -> *) a. f a -> Lift f a
    Other ((a -> b) -> f a -> f b
    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) = (a -> m) -> f a -> m
    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) = b -> Lift f b
    forall (f :: * -> *) a. a -> Lift f a
    Pure (b -> Lift f b) -> f b -> f (Lift f b)
    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) = f b -> Lift f b
    forall (f :: * -> *) a. f a -> Lift f a
    Other (f b -> Lift f b) -> f (f b) -> f (Lift f b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (a -> f b) -> f a -> f (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 #-}

    -- | A combination is 'Pure' only if both parts are.
    instance (Applicative f) => Applicative (Lift f) where
        pure :: forall a. a -> Lift f a
    pure = a -> Lift f a
    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 = b -> Lift f b
    forall (f :: * -> *) a. a -> Lift f a
    Pure (a -> b
    f a
    x)
        Pure a -> b
    f <*> Other f a
    y = f b -> Lift f b
    forall (f :: * -> *) a. f a -> Lift f a
    Other (a -> b
    f (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> f a
    y)
        Other f (a -> b)
    f <*> Pure a
    x = f b -> Lift f b
    forall (f :: * -> *) a. f a -> Lift f a
    Other (((a -> b) -> a -> b
    forall a b. (a -> b) -> a -> b
    $ a
    x) ((a -> b) -> b) -> f (a -> b) -> f b
    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 = f b -> Lift f b
    forall (f :: * -> *) a. f a -> Lift f a
    Other (f (a -> b)
    f f (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> f a
    y)
        {-# INLINE (<*>) #-}

    -- | A combination is 'Pure' only either part is.
    instance (Alternative f) => Alternative (Lift f) where
        empty :: forall a. Lift f a
    empty = f a -> Lift f a
    forall (f :: * -> *) a. f a -> Lift f a
    Other f a
    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
    _ = a -> Lift f a
    forall (f :: * -> *) a. a -> Lift f a
    Pure a
    x
        Other f a
    _ <|> Pure a
    y = a -> Lift f a
    forall (f :: * -> *) a. a -> Lift f a
    Pure a
    y
        Other f a
    x <|> Other f a
    y = f a -> Lift f a
    forall (f :: * -> *) a. f a -> Lift f a
    Other (f a
    x f a -> f a -> f a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> f a
    y)
        {-# INLINE (<|>) #-}

    -- | Projection to the other functor.
    unLift :: (Applicative f) => Lift f a -> f a
    unLift :: forall (f :: * -> *) a. Applicative f => Lift f a -> f a
    unLift (Pure a
    x) = a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    x
    unLift (Other f a
    e) = f a
    e
    {-# INLINE unLift #-}

    -- | Apply a transformation to the other computation.
    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) = a -> Lift g a
    forall (f :: * -> *) a. a -> Lift f a
    Pure a
    x
    mapLift f a -> g a
    f (Other f a
    e) = g a -> Lift g a
    forall (f :: * -> *) a. f a -> Lift f a
    Other (f a -> g a
    f f a
    e)
    {-# INLINE mapLift #-}

    -- | Eliminator for 'Lift'.
    --
    -- * @'elimLift' f g . 'pure' = f@
    --
    -- * @'elimLift' f g . 'Other' = g@
    --
    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 #-}

    -- | An applicative functor that collects a monoid (e.g. lists) of errors.
    -- A sequence of computations fails if any of its components do, but
    -- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except",
    -- these computations continue after an error, collecting all the errors.
    --
    -- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@
    --
    -- * @'pure' f '<*>' 'failure' e = 'failure' e@
    --
    -- * @'failure' e '<*>' 'pure' x = 'failure' e@
    --
    -- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@
    --
    type Errors e = Lift (Constant e)

    -- | Extractor for computations with accumulating errors.
    --
    -- * @'runErrors' ('pure' x) = 'Right' x@
    --
    -- * @'runErrors' ('failure' e) = 'Left' e@
    --
    runErrors :: Errors e a -> Either e a
    runErrors :: forall e a. Errors e a -> Either e a
    runErrors (Other (Constant e
    e)) = e -> Either e a
    forall a b. a -> Either a b
    Left e
    e
    runErrors (Pure a
    x) = a -> Either e a
    forall a b. b -> Either a b
    Right a
    x
    {-# INLINE runErrors #-}

    -- | Report an error.
    failure :: e -> Errors e a
    failure :: forall e a. e -> Errors e a
    failure e
    e = Constant e a -> Lift (Constant e) a
    forall (f :: * -> *) a. f a -> Lift f a
    Other (e -> Constant e a
    forall {k} a (b :: k). a -> Constant a b
    Constant e
    e)
    {-# INLINE failure #-}

    -- | Convert from 'Either' to 'Errors' (inverse of 'runErrors').
    eitherToErrors :: Either e a -> Errors e a
    eitherToErrors :: forall e a. Either e a -> Errors e a
    eitherToErrors = (e -> Errors e a) -> (a -> Errors e a) -> Either e a -> Errors e a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either e -> Errors e a
    forall e a. e -> Errors e a
    failure a -> Errors e a
    forall (f :: * -> *) a. a -> Lift f a
    Pure