From f723b8b878a3c4a4687b9e337a875500bebb39b1 Mon Sep 17 00:00:00 2001 From: Vincent Ambo Date: Thu, 4 Jul 2019 11:18:12 +0100 Subject: feat(third_party/bazel): Check in rules_haskell from Tweag --- .../transformers/Control/Applicative/Lift.hs | 165 +++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs (limited to 'third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs') 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 new file mode 100644 index 0000000000..8d35e288c0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs @@ -0,0 +1,165 @@ +{-# 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 -- cgit 1.4.1