about summary refs log tree commit diff
path: root/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs')
-rw-r--r--third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs165
1 files changed, 0 insertions, 165 deletions
diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs
deleted file mode 100644
index 8d35e288c0..0000000000
--- a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs
+++ /dev/null
@@ -1,165 +0,0 @@
-{-# 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 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
-    {-# INLINE liftEq #-}
-
-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
-    {-# INLINE liftCompare #-}
-
-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)
-    {-# INLINE fmap #-}
-
-instance (Foldable f) => Foldable (Lift f) where
-    foldMap f (Pure x) = f x
-    foldMap f (Other y) = foldMap f y
-    {-# INLINE foldMap #-}
-
-instance (Traversable f) => Traversable (Lift f) where
-    traverse f (Pure x) = Pure <$> f x
-    traverse f (Other y) = Other <$> traverse f y
-    {-# INLINE traverse #-}
-
--- | A combination is 'Pure' only if both parts are.
-instance (Applicative f) => Applicative (Lift f) where
-    pure = Pure
-    {-# INLINE 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)
-    {-# INLINE (<*>) #-}
-
--- | A combination is 'Pure' only either part is.
-instance (Alternative f) => Alternative (Lift f) where
-    empty = Other empty
-    {-# INLINE empty #-}
-    Pure x <|> _ = Pure x
-    Other _ <|> Pure y = Pure y
-    Other x <|> Other y = Other (x <|> y)
-    {-# INLINE (<|>) #-}
-
--- | Projection to the other functor.
-unLift :: (Applicative f) => Lift f a -> f a
-unLift (Pure x) = pure x
-unLift (Other e) = e
-{-# INLINE unLift #-}
-
--- | Apply a transformation to the other computation.
-mapLift :: (f a -> g a) -> Lift f a -> Lift g a
-mapLift _ (Pure x) = Pure x
-mapLift f (Other e) = Other (f 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 f _ (Pure x) = f x
-elimLift _ g (Other e) = g 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 (Other (Constant e)) = Left e
-runErrors (Pure x) = Right x
-{-# INLINE runErrors #-}
-
--- | Report an error.
-failure :: e -> Errors e a
-failure e = Other (Constant e)
-{-# INLINE failure #-}
-
--- | Convert from 'Either' to 'Errors' (inverse of 'runErrors').
-eitherToErrors :: Either e a -> Errors e a
-eitherToErrors = either failure Pure