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