1{-# LANGUAGE CPP #-}
2
3#ifndef HASKELL98
4# if __GLASGOW_HASKELL__ >= 704
5{-# LANGUAGE Safe #-}
6# elif __GLASGOW_HASKELL__ >= 702
7{-# LANGUAGE Trustworthy #-}
8# endif
9#endif
10-- |
11-- Module      :  Control.Applicative.Lift
12-- Copyright   :  (c) Ross Paterson 2010
13-- License     :  BSD-style (see the file LICENSE)
14--
15-- Maintainer  :  ross@soi.city.ac.uk
16-- Stability   :  experimental
17-- Portability :  portable
18--
19-- Adding a new kind of pure computation to an applicative functor.
20--
21-- NB: This module is only included in @lens@ for backwards compatibility with
22-- @transformers@ versions before 3.0.
23
24module Control.Applicative.Lift (
25    -- * Lifting an applicative
26    Lift(..),
27    unLift,
28    mapLift,
29    elimLift,
30    -- * Collecting errors
31    Errors,
32    runErrors,
33    failure,
34    eitherToErrors
35  ) where
36
37import Data.Functor.Classes
38
39import Control.Applicative
40import Data.Foldable (Foldable(foldMap))
41import Data.Functor.Constant
42import Data.Monoid (Monoid(..))
43import Data.Traversable (Traversable(traverse))
44
45-- | Applicative functor formed by adding pure computations to a given
46-- applicative functor.
47data Lift f a = Pure a | Other (f a)
48
49instance (Eq1 f) => Eq1 (Lift f) where
50    liftEq eq (Pure x1) (Pure x2) = eq x1 x2
51    liftEq _ (Pure _) (Other _) = False
52    liftEq _ (Other _) (Pure _) = False
53    liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2
54    {-# INLINE liftEq #-}
55
56instance (Ord1 f) => Ord1 (Lift f) where
57    liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
58    liftCompare _ (Pure _) (Other _) = LT
59    liftCompare _ (Other _) (Pure _) = GT
60    liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2
61    {-# INLINE liftCompare #-}
62
63instance (Read1 f) => Read1 (Lift f) where
64    liftReadsPrec rp rl = readsData $
65        readsUnaryWith rp "Pure" Pure `mappend`
66        readsUnaryWith (liftReadsPrec rp rl) "Other" Other
67
68instance (Show1 f) => Show1 (Lift f) where
69    liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
70    liftShowsPrec sp sl d (Other y) =
71        showsUnaryWith (liftShowsPrec sp sl) "Other" d y
72
73instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
74instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
75instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
76instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1
77
78instance (Functor f) => Functor (Lift f) where
79    fmap f (Pure x) = Pure (f x)
80    fmap f (Other y) = Other (fmap f y)
81    {-# INLINE fmap #-}
82
83instance (Foldable f) => Foldable (Lift f) where
84    foldMap f (Pure x) = f x
85    foldMap f (Other y) = foldMap f y
86    {-# INLINE foldMap #-}
87
88instance (Traversable f) => Traversable (Lift f) where
89    traverse f (Pure x) = Pure <$> f x
90    traverse f (Other y) = Other <$> traverse f y
91    {-# INLINE traverse #-}
92
93-- | A combination is 'Pure' only if both parts are.
94instance (Applicative f) => Applicative (Lift f) where
95    pure = Pure
96    {-# INLINE pure #-}
97    Pure f <*> Pure x = Pure (f x)
98    Pure f <*> Other y = Other (f <$> y)
99    Other f <*> Pure x = Other (($ x) <$> f)
100    Other f <*> Other y = Other (f <*> y)
101    {-# INLINE (<*>) #-}
102
103-- | A combination is 'Pure' only either part is.
104instance (Alternative f) => Alternative (Lift f) where
105    empty = Other empty
106    {-# INLINE empty #-}
107    Pure x <|> _ = Pure x
108    Other _ <|> Pure y = Pure y
109    Other x <|> Other y = Other (x <|> y)
110    {-# INLINE (<|>) #-}
111
112-- | Projection to the other functor.
113unLift :: (Applicative f) => Lift f a -> f a
114unLift (Pure x) = pure x
115unLift (Other e) = e
116{-# INLINE unLift #-}
117
118-- | Apply a transformation to the other computation.
119mapLift :: (f a -> g a) -> Lift f a -> Lift g a
120mapLift _ (Pure x) = Pure x
121mapLift f (Other e) = Other (f e)
122{-# INLINE mapLift #-}
123
124-- | Eliminator for 'Lift'.
125--
126-- * @'elimLift' f g . 'pure' = f@
127--
128-- * @'elimLift' f g . 'Other' = g@
129--
130elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r
131elimLift f _ (Pure x) = f x
132elimLift _ g (Other e) = g e
133{-# INLINE elimLift #-}
134
135-- | An applicative functor that collects a monoid (e.g. lists) of errors.
136-- A sequence of computations fails if any of its components do, but
137-- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except",
138-- these computations continue after an error, collecting all the errors.
139--
140-- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@
141--
142-- * @'pure' f '<*>' 'failure' e = 'failure' e@
143--
144-- * @'failure' e '<*>' 'pure' x = 'failure' e@
145--
146-- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@
147--
148type Errors e = Lift (Constant e)
149
150-- | Extractor for computations with accumulating errors.
151--
152-- * @'runErrors' ('pure' x) = 'Right' x@
153--
154-- * @'runErrors' ('failure' e) = 'Left' e@
155--
156runErrors :: Errors e a -> Either e a
157runErrors (Other (Constant e)) = Left e
158runErrors (Pure x) = Right x
159{-# INLINE runErrors #-}
160
161-- | Report an error.
162failure :: e -> Errors e a
163failure e = Other (Constant e)
164{-# INLINE failure #-}
165
166-- | Convert from 'Either' to 'Errors' (inverse of 'runErrors').
167eitherToErrors :: Either e a -> Errors e a
168eitherToErrors = either failure Pure
169