{-# 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