1 files changed, 165 insertions, 0 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
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