diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/transformers/legacy')
6 files changed, 1285 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs new file mode 100644 index 000000000000..940e4e470f47 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 700 +{-# LANGUAGE DeriveDataTypeable #-} +#endif +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Trustworthy #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +#endif +#if MIN_VERSION_base(4,7,0) +-- We need to implement bitSize for the Bits instance, but it's deprecated. +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity functor and monad. +-- +-- This trivial type constructor serves two purposes: +-- +-- * It can be used with functions parameterized by functor or monad classes. +-- +-- * It can be used as a base monad to which a series of monad +-- transformers may be applied to construct a composite monad. +-- Most monad transformer modules include the special case of +-- applying the transformer to 'Identity'. For example, @State s@ +-- is an abbreviation for @StateT s 'Identity'@. +----------------------------------------------------------------------------- + +module Data.Functor.Identity ( + Identity(..), + ) where + +import Data.Bits +import Control.Applicative +import Control.Arrow (Arrow((***))) +import Control.Monad.Fix +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith, munzip)) +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (Monoid(mempty, mappend)) +import Data.String (IsString(fromString)) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 700 +import Data.Data +#endif +import Data.Ix (Ix(..)) +import Foreign (Storable(..), castPtr) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +-- | Identity functor and monad. (a non-strict monad) +newtype Identity a = Identity { runIdentity :: a } + deriving ( Eq, Ord +#if __GLASGOW_HASKELL__ >= 700 + , Data, Typeable +#endif +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) + +instance (Bits a) => Bits (Identity a) where + Identity x .&. Identity y = Identity (x .&. y) + Identity x .|. Identity y = Identity (x .|. y) + xor (Identity x) (Identity y) = Identity (xor x y) + complement (Identity x) = Identity (complement x) + shift (Identity x) i = Identity (shift x i) + rotate (Identity x) i = Identity (rotate x i) + setBit (Identity x) i = Identity (setBit x i) + clearBit (Identity x) i = Identity (clearBit x i) + shiftL (Identity x) i = Identity (shiftL x i) + shiftR (Identity x) i = Identity (shiftR x i) + rotateL (Identity x) i = Identity (rotateL x i) + rotateR (Identity x) i = Identity (rotateR x i) + testBit (Identity x) i = testBit x i + bitSize (Identity x) = bitSize x + isSigned (Identity x) = isSigned x + bit i = Identity (bit i) +#if MIN_VERSION_base(4,5,0) + unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i) + unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i) + popCount (Identity x) = popCount x +#endif +#if MIN_VERSION_base(4,7,0) + zeroBits = Identity zeroBits + bitSizeMaybe (Identity x) = bitSizeMaybe x +#endif + +instance (Bounded a) => Bounded (Identity a) where + minBound = Identity minBound + maxBound = Identity maxBound + +instance (Enum a) => Enum (Identity a) where + succ (Identity x) = Identity (succ x) + pred (Identity x) = Identity (pred x) + toEnum i = Identity (toEnum i) + fromEnum (Identity x) = fromEnum x + enumFrom (Identity x) = map Identity (enumFrom x) + enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y) + enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) + enumFromThenTo (Identity x) (Identity y) (Identity z) = + map Identity (enumFromThenTo x y z) + +#if MIN_VERSION_base(4,7,0) +instance (FiniteBits a) => FiniteBits (Identity a) where + finiteBitSize (Identity x) = finiteBitSize x +#endif + +instance (Floating a) => Floating (Identity a) where + pi = Identity pi + exp (Identity x) = Identity (exp x) + log (Identity x) = Identity (log x) + sqrt (Identity x) = Identity (sqrt x) + sin (Identity x) = Identity (sin x) + cos (Identity x) = Identity (cos x) + tan (Identity x) = Identity (tan x) + asin (Identity x) = Identity (asin x) + acos (Identity x) = Identity (acos x) + atan (Identity x) = Identity (atan x) + sinh (Identity x) = Identity (sinh x) + cosh (Identity x) = Identity (cosh x) + tanh (Identity x) = Identity (tanh x) + asinh (Identity x) = Identity (asinh x) + acosh (Identity x) = Identity (acosh x) + atanh (Identity x) = Identity (atanh x) + Identity x ** Identity y = Identity (x ** y) + logBase (Identity x) (Identity y) = Identity (logBase x y) + +instance (Fractional a) => Fractional (Identity a) where + Identity x / Identity y = Identity (x / y) + recip (Identity x) = Identity (recip x) + fromRational r = Identity (fromRational r) + +instance (IsString a) => IsString (Identity a) where + fromString s = Identity (fromString s) + +instance (Ix a) => Ix (Identity a) where + range (Identity x, Identity y) = map Identity (range (x, y)) + index (Identity x, Identity y) (Identity i) = index (x, y) i + inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e + rangeSize (Identity x, Identity y) = rangeSize (x, y) + +instance (Integral a) => Integral (Identity a) where + quot (Identity x) (Identity y) = Identity (quot x y) + rem (Identity x) (Identity y) = Identity (rem x y) + div (Identity x) (Identity y) = Identity (div x y) + mod (Identity x) (Identity y) = Identity (mod x y) + quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y) + divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y) + toInteger (Identity x) = toInteger x + +instance (Monoid a) => Monoid (Identity a) where + mempty = Identity mempty + mappend (Identity x) (Identity y) = Identity (mappend x y) + +instance (Num a) => Num (Identity a) where + Identity x + Identity y = Identity (x + y) + Identity x - Identity y = Identity (x - y) + Identity x * Identity y = Identity (x * y) + negate (Identity x) = Identity (negate x) + abs (Identity x) = Identity (abs x) + signum (Identity x) = Identity (signum x) + fromInteger n = Identity (fromInteger n) + +instance (Real a) => Real (Identity a) where + toRational (Identity x) = toRational x + +instance (RealFloat a) => RealFloat (Identity a) where + floatRadix (Identity x) = floatRadix x + floatDigits (Identity x) = floatDigits x + floatRange (Identity x) = floatRange x + decodeFloat (Identity x) = decodeFloat x + exponent (Identity x) = exponent x + isNaN (Identity x) = isNaN x + isInfinite (Identity x) = isInfinite x + isDenormalized (Identity x) = isDenormalized x + isNegativeZero (Identity x) = isNegativeZero x + isIEEE (Identity x) = isIEEE x + significand (Identity x) = significand (Identity x) + scaleFloat s (Identity x) = Identity (scaleFloat s x) + encodeFloat m n = Identity (encodeFloat m n) + atan2 (Identity x) (Identity y) = Identity (atan2 x y) + +instance (RealFrac a) => RealFrac (Identity a) where + properFraction (Identity x) = (id *** Identity) (properFraction x) + truncate (Identity x) = truncate x + round (Identity x) = round x + ceiling (Identity x) = ceiling x + floor (Identity x) = floor x + +instance (Storable a) => Storable (Identity a) where + sizeOf (Identity x) = sizeOf x + alignment (Identity x) = alignment x + peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i) + pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x + peekByteOff p i = fmap Identity (peekByteOff p i) + pokeByteOff p i (Identity x) = pokeByteOff p i x + peek p = fmap runIdentity (peek (castPtr p)) + poke p (Identity x) = poke (castPtr p) x + +-- These instances would be equivalent to the derived instances of the +-- newtype if the field were removed. + +instance (Read a) => Read (Identity a) where + readsPrec d = readParen (d > 10) $ \ r -> + [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s] + +instance (Show a) => Show (Identity a) where + showsPrec d (Identity x) = showParen (d > 10) $ + showString "Identity " . showsPrec 11 x + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Functor Identity where + fmap f m = Identity (f (runIdentity m)) + +instance Foldable Identity where + foldMap f (Identity x) = f x + +instance Traversable Identity where + traverse f (Identity x) = Identity <$> f x + +instance Applicative Identity where + pure a = Identity a + Identity f <*> Identity x = Identity (f x) + +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) + +#if MIN_VERSION_base(4,4,0) +instance MonadZip Identity where + mzipWith f (Identity x) (Identity y) = Identity (f x y) + munzip (Identity (a, b)) = (Identity a, Identity b) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs new file mode 100644 index 000000000000..7c74d4ef0d71 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.IO.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Class of monads based on @IO@. +----------------------------------------------------------------------------- + +module Control.Monad.IO.Class ( + MonadIO(..) + ) where + +#if __GLASGOW_HASKELL__ >= 708 +import Data.Typeable +#endif + +-- | Monads in which 'IO' computations may be embedded. +-- Any monad built by applying a sequence of monad transformers to the +-- 'IO' monad will be an instance of this class. +-- +-- Instances should satisfy the following laws, which state that 'liftIO' +-- is a transformer of monads: +-- +-- * @'liftIO' . 'return' = 'return'@ +-- +-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ + +class (Monad m) => MonadIO m where + -- | Lift a computation from the 'IO' monad. + liftIO :: IO a -> m a + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable MonadIO +#endif + +instance MonadIO IO where + liftIO = id diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs new file mode 100644 index 000000000000..bda1749643d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Classes +-- Copyright : (c) Ross Paterson 2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to +-- unary and binary type constructors. +-- +-- These classes are needed to express the constraints on arguments of +-- transformers in portable Haskell. Thus for a new transformer @T@, +-- one might write instances like +-- +-- > instance (Eq1 f) => Eq1 (T f) where ... +-- > instance (Ord1 f) => Ord1 (T f) where ... +-- > instance (Read1 f) => Read1 (T f) where ... +-- > instance (Show1 f) => Show1 (T f) where ... +-- +-- If these instances can be defined, defining instances of the base +-- classes is mechanical: +-- +-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 +-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 +-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 +-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 +-- +----------------------------------------------------------------------------- + +module Data.Functor.Classes ( + -- * Liftings of Prelude classes + -- ** For unary constructors + Eq1(..), eq1, + Ord1(..), compare1, + Read1(..), readsPrec1, + Show1(..), showsPrec1, + -- ** For binary constructors + Eq2(..), eq2, + Ord2(..), compare2, + Read2(..), readsPrec2, + Show2(..), showsPrec2, + -- * Helper functions + -- $example + readsData, + readsUnaryWith, + readsBinaryWith, + showsUnaryWith, + showsBinaryWith, + -- ** Obsolete helpers + readsUnary, + readsUnary1, + readsBinary1, + showsUnary, + showsUnary1, + showsBinary1, + ) where + +import Control.Applicative (Const(Const)) +import Data.Functor.Identity (Identity(Identity)) +import Data.Monoid (mappend) +#if MIN_VERSION_base(4,7,0) +import Data.Proxy (Proxy(Proxy)) +#endif +#if __GLASGOW_HASKELL__ >= 708 +import Data.Typeable +#endif +import Text.Show (showListWith) + +-- | Lifting of the 'Eq' class to unary type constructors. +class Eq1 f where + -- | Lift an equality test through the type constructor. + -- + -- The function will usually be applied to an equality function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Eq1 +#endif + +-- | Lift the standard @('==')@ function through the type constructor. +eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool +eq1 = liftEq (==) + +-- | Lifting of the 'Ord' class to unary type constructors. +class (Eq1 f) => Ord1 f where + -- | Lift a 'compare' function through the type constructor. + -- + -- The function will usually be applied to a comparison function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Ord1 +#endif + +-- | Lift the standard 'compare' function through the type constructor. +compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering +compare1 = liftCompare compare + +-- | Lifting of the 'Read' class to unary type constructors. +class Read1 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] + liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Read1 +#endif + +-- | Read a list (using square brackets and commas), given a function +-- for reading elements. +readListWith :: ReadS a -> ReadS [a] +readListWith rp = + readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) + where + readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] + +-- | Lift the standard 'readsPrec' and 'readList' functions through the +-- type constructor. +readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) +readsPrec1 = liftReadsPrec readsPrec readList + +-- | Lifting of the 'Show' class to unary type constructors. +class Show1 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + Int -> f a -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + [f a] -> ShowS + liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Show1 +#endif + +-- | Lift the standard 'showsPrec' and 'showList' functions through the +-- type constructor. +showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS +showsPrec1 = liftShowsPrec showsPrec showList + +-- | Lifting of the 'Eq' class to binary type constructors. +class Eq2 f where + -- | Lift equality tests through the type constructor. + -- + -- The function will usually be applied to equality functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Eq2 +#endif + +-- | Lift the standard @('==')@ function through the type constructor. +eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool +eq2 = liftEq2 (==) (==) + +-- | Lifting of the 'Ord' class to binary type constructors. +class (Eq2 f) => Ord2 f where + -- | Lift 'compare' functions through the type constructor. + -- + -- The function will usually be applied to comparison functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> + f a c -> f b d -> Ordering + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Ord2 +#endif + +-- | Lift the standard 'compare' function through the type constructor. +compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering +compare2 = liftCompare2 compare compare + +-- | Lifting of the 'Read' class to binary type constructors. +class Read2 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] + liftReadList2 rp1 rl1 rp2 rl2 = + readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Read2 +#endif + +-- | Lift the standard 'readsPrec' function through the type constructor. +readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) +readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList + +-- | Lifting of the 'Show' class to binary type constructors. +class Show2 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS + liftShowList2 sp1 sl1 sp2 sl2 = + showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Show2 +#endif + +-- | Lift the standard 'showsPrec' function through the type constructor. +showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS +showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList + +-- Instances for Prelude type constructors + +instance Eq1 Maybe where + liftEq _ Nothing Nothing = True + liftEq _ Nothing (Just _) = False + liftEq _ (Just _) Nothing = False + liftEq eq (Just x) (Just y) = eq x y + +instance Ord1 Maybe where + liftCompare _ Nothing Nothing = EQ + liftCompare _ Nothing (Just _) = LT + liftCompare _ (Just _) Nothing = GT + liftCompare comp (Just x) (Just y) = comp x y + +instance Read1 Maybe where + liftReadsPrec rp _ d = + readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) + `mappend` + readsData (readsUnaryWith rp "Just" Just) d + +instance Show1 Maybe where + liftShowsPrec _ _ _ Nothing = showString "Nothing" + liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x + +instance Eq1 [] where + liftEq _ [] [] = True + liftEq _ [] (_:_) = False + liftEq _ (_:_) [] = False + liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys + +instance Ord1 [] where + liftCompare _ [] [] = EQ + liftCompare _ [] (_:_) = LT + liftCompare _ (_:_) [] = GT + liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys + +instance Read1 [] where + liftReadsPrec _ rl _ = rl + +instance Show1 [] where + liftShowsPrec _ sl _ = sl + +instance Eq2 (,) where + liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 + +instance Ord2 (,) where + liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = + comp1 x1 x2 `mappend` comp2 y1 y2 + +instance Read2 (,) where + liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> + [((x,y), w) | ("(",s) <- lex r, + (x,t) <- rp1 0 s, + (",",u) <- lex t, + (y,v) <- rp2 0 u, + (")",w) <- lex v] + +instance Show2 (,) where + liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = + showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' + +instance (Eq a) => Eq1 ((,) a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 ((,) a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 ((,) a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 ((,) a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Eq2 Either where + liftEq2 e1 _ (Left x) (Left y) = e1 x y + liftEq2 _ _ (Left _) (Right _) = False + liftEq2 _ _ (Right _) (Left _) = False + liftEq2 _ e2 (Right x) (Right y) = e2 x y + +instance Ord2 Either where + liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y + liftCompare2 _ _ (Left _) (Right _) = LT + liftCompare2 _ _ (Right _) (Left _) = GT + liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y + +instance Read2 Either where + liftReadsPrec2 rp1 _ rp2 _ = readsData $ + readsUnaryWith rp1 "Left" Left `mappend` + readsUnaryWith rp2 "Right" Right + +instance Show2 Either where + liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x + liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x + +instance (Eq a) => Eq1 (Either a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 (Either a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 (Either a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 (Either a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +#if MIN_VERSION_base(4,7,0) +instance Eq1 Proxy where + liftEq _ _ _ = True + +instance Ord1 Proxy where + liftCompare _ _ _ = EQ + +instance Show1 Proxy where + liftShowsPrec _ _ _ _ = showString "Proxy" + +instance Read1 Proxy where + liftReadsPrec _ _ d = + readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) +#endif + +-- Instances for other functors defined in the base package + +instance Eq1 Identity where + liftEq eq (Identity x) (Identity y) = eq x y + +instance Ord1 Identity where + liftCompare comp (Identity x) (Identity y) = comp x y + +instance Read1 Identity where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Identity" Identity + +instance Show1 Identity where + liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x + +instance Eq2 Const where + liftEq2 eq _ (Const x) (Const y) = eq x y + +instance Ord2 Const where + liftCompare2 comp _ (Const x) (Const y) = comp x y + +instance Read2 Const where + liftReadsPrec2 rp _ _ _ = readsData $ + readsUnaryWith rp "Const" Const + +instance Show2 Const where + liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x + +instance (Eq a) => Eq1 (Const a) where + liftEq = liftEq2 (==) +instance (Ord a) => Ord1 (Const a) where + liftCompare = liftCompare2 compare +instance (Read a) => Read1 (Const a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Show a) => Show1 (Const a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Building blocks + +-- | @'readsData' p d@ is a parser for datatypes where each alternative +-- begins with a data constructor. It parses the constructor and +-- passes it to @p@. Parsers for various constructors can be constructed +-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with +-- @mappend@ from the @Monoid@ class. +readsData :: (String -> ReadS a) -> Int -> ReadS a +readsData reader d = + readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] + +-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor +-- and then parses its argument using @rp@. +readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t +readsUnaryWith rp name cons kw s = + [(cons x,t) | kw == name, (x,t) <- rp 11 s] + +-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary +-- data constructor and then parses its arguments using @rp1@ and @rp2@ +-- respectively. +readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> + String -> (a -> b -> t) -> String -> ReadS t +readsBinaryWith rp1 rp2 name cons kw s = + [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] + +-- | @'showsUnaryWith' sp n d x@ produces the string representation of a +-- unary data constructor with name @n@ and argument @x@, in precedence +-- context @d@. +showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS +showsUnaryWith sp name d x = showParen (d > 10) $ + showString name . showChar ' ' . sp 11 x + +-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string +-- representation of a binary data constructor with name @n@ and arguments +-- @x@ and @y@, in precedence context @d@. +showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> + String -> Int -> a -> b -> ShowS +showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y + +-- Obsolete building blocks + +-- | @'readsUnary' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec'. +{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} +readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t +readsUnary name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] + +-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec1'. +{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} +readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t +readsUnary1 name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] + +-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor +-- and then parses its arguments using 'readsPrec1'. +{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} +readsBinary1 :: (Read1 f, Read1 g, Read a) => + String -> (f a -> g a -> t) -> String -> ReadS t +readsBinary1 name cons kw s = + [(cons x y,u) | kw == name, + (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] + +-- | @'showsUnary' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} +showsUnary :: (Show a) => String -> Int -> a -> ShowS +showsUnary name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec 11 x + +-- | @'showsUnary1' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} +showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS +showsUnary1 name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x + +-- | @'showsBinary1' n d x y@ produces the string representation of a binary +-- data constructor with name @n@ and arguments @x@ and @y@, in precedence +-- context @d@. +{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} +showsBinary1 :: (Show1 f, Show1 g, Show a) => + String -> Int -> f a -> g a -> ShowS +showsBinary1 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x . + showChar ' ' . showsPrec1 11 y + +{- $example +These functions can be used to assemble 'Read' and 'Show' instances for +new algebraic types. For example, given the definition + +> data T f a = Zero a | One (f a) | Two a (f a) + +a standard 'Read1' instance may be defined as + +> instance (Read1 f) => Read1 (T f) where +> liftReadsPrec rp rl = readsData $ +> readsUnaryWith rp "Zero" Zero `mappend` +> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` +> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two + +and the corresponding 'Show1' instance as + +> instance (Show1 f) => Show1 (T f) where +> liftShowsPrec sp _ d (Zero x) = +> showsUnaryWith sp "Zero" d x +> liftShowsPrec sp sl d (One x) = +> showsUnaryWith (liftShowsPrec sp sl) "One" d x +> liftShowsPrec sp sl d (Two x y) = +> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs new file mode 100644 index 000000000000..ed781309aff8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Compose +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Composition of functors. +----------------------------------------------------------------------------- + +module Data.Functor.Compose ( + Compose(..), + ) where + +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +#if __GLASGOW_HASKELL__ >= 708 +import Data.Data +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +infixr 9 `Compose` + +-- | Right-to-left composition of functors. +-- The composition of applicative functors is always applicative, +-- but the composition of monads is not always a monad. +newtype Compose f g a = Compose { getCompose :: f (g a) } + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic (Compose f g a) + +instance Functor f => Generic1 (Compose f g) where + type Rep1 (Compose f g) = + D1 MDCompose + (C1 MCCompose + (S1 MSCompose (f :.: Rec1 g))) + from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) + to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) + +data MDCompose +data MCCompose +data MSCompose + +instance Datatype MDCompose where + datatypeName _ = "Compose" + moduleName _ = "Data.Functor.Compose" +# if __GLASGOW_HASKELL__ >= 708 + isNewtype _ = True +# endif + +instance Constructor MCCompose where + conName _ = "Compose" + conIsRecord _ = True + +instance Selector MSCompose where + selName _ = "getCompose" +#endif + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Compose +deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) + => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) +#endif + +-- Instances of lifted Prelude classes + +instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where + liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y + +instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where + liftCompare comp (Compose x) (Compose y) = + liftCompare (liftCompare comp) x y + +instance (Read1 f, Read1 g) => Read1 (Compose f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 f, Show1 g) => Show1 (Compose f g) where + liftShowsPrec sp sl d (Compose x) = + showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +-- Instances of Prelude classes + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where + (==) = eq1 + +instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where + compare = compare1 + +instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where + readsPrec = readsPrec1 + +instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where + showsPrec = showsPrec1 + +-- Functor instances + +instance (Functor f, Functor g) => Functor (Compose f g) where + fmap f (Compose x) = Compose (fmap (fmap f) x) + +instance (Foldable f, Foldable g) => Foldable (Compose f g) where + foldMap f (Compose t) = foldMap (foldMap f) t + +instance (Traversable f, Traversable g) => Traversable (Compose f g) where + traverse f (Compose t) = Compose <$> traverse (traverse f) t + +instance (Applicative f, Applicative g) => Applicative (Compose f g) where + pure x = Compose (pure (pure x)) + Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) + +instance (Alternative f, Applicative g) => Alternative (Compose f g) where + empty = Compose empty + Compose x <|> Compose y = Compose (x <|> y) + +#if MIN_VERSION_base(4,12,0) +instance (Functor f, Contravariant g) => Contravariant (Compose f g) where + contramap f (Compose fga) = Compose (fmap (contramap f) fga) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs new file mode 100644 index 000000000000..ba0dc0407e00 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Product +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Products, lifted to functors. +----------------------------------------------------------------------------- + +module Data.Functor.Product ( + Product(..), + ) where + +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Control.Monad.Fix (MonadFix(..)) +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +#if __GLASGOW_HASKELL__ >= 708 +import Data.Data +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +-- | Lifted product of functors. +data Product f g a = Pair (f a) (g a) + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic (Product f g a) + +instance Generic1 (Product f g) where + type Rep1 (Product f g) = + D1 MDProduct + (C1 MCPair + (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) + from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) + to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) + +data MDProduct +data MCPair + +instance Datatype MDProduct where + datatypeName _ = "Product" + moduleName _ = "Data.Functor.Product" + +instance Constructor MCPair where + conName _ = "Pair" +#endif + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Product +deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) + => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) +#endif + +instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where + liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 + +instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where + liftCompare comp (Pair x1 y1) (Pair x2 y2) = + liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 + +instance (Read1 f, Read1 g) => Read1 (Product f g) where + liftReadsPrec rp rl = readsData $ + readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair + +instance (Show1 f, Show1 g) => Show1 (Product f g) where + liftShowsPrec sp sl d (Pair x y) = + showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) + where (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Product f g) where + fmap f (Pair x y) = Pair (fmap f x) (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Product f g) where + traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y + +instance (Applicative f, Applicative g) => Applicative (Product f g) where + pure x = Pair (pure x) (pure x) + Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) + +instance (Alternative f, Alternative g) => Alternative (Product f g) where + empty = Pair empty empty + Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2) + +instance (Monad f, Monad g) => Monad (Product f g) where +#if !(MIN_VERSION_base(4,8,0)) + return x = Pair (return x) (return x) +#endif + Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where + mzero = Pair mzero mzero + Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) + +instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where + mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where + mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) +#endif + +#if MIN_VERSION_base(4,12,0) +instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where + contramap f (Pair a b) = Pair (contramap f a) (contramap f b) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs new file mode 100644 index 000000000000..e6d1428b30e3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Sum +-- Copyright : (c) Ross Paterson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Sums, lifted to functors. +----------------------------------------------------------------------------- + +module Data.Functor.Sum ( + Sum(..), + ) where + +import Control.Applicative +#if __GLASGOW_HASKELL__ >= 708 +import Data.Data +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +-- | Lifted sum of functors. +data Sum f g a = InL (f a) | InR (g a) + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic (Sum f g a) + +instance Generic1 (Sum f g) where + type Rep1 (Sum f g) = + D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) + :+: C1 MCInR (S1 NoSelector (Rec1 g))) + from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) + from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) + to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) + to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) + +data MDSum +data MCInL +data MCInR + +instance Datatype MDSum where + datatypeName _ = "Sum" + moduleName _ = "Data.Functor.Sum" + +instance Constructor MCInL where + conName _ = "InL" + +instance Constructor MCInR where + conName _ = "InR" +#endif + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Sum +deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) + => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) +#endif + +instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where + liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 + liftEq _ (InL _) (InR _) = False + liftEq _ (InR _) (InL _) = False + liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 + +instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where + liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 + liftCompare _ (InL _) (InR _) = LT + liftCompare _ (InR _) (InL _) = GT + liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 + +instance (Read1 f, Read1 g) => Read1 (Sum f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` + readsUnaryWith (liftReadsPrec rp rl) "InR" InR + +instance (Show1 f, Show1 g) => Show1 (Sum f g) where + liftShowsPrec sp sl d (InL x) = + showsUnaryWith (liftShowsPrec sp sl) "InL" d x + liftShowsPrec sp sl d (InR y) = + showsUnaryWith (liftShowsPrec sp sl) "InR" d y + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where + (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Sum f g) where + fmap f (InL x) = InL (fmap f x) + fmap f (InR y) = InR (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Sum f g) where + foldMap f (InL x) = foldMap f x + foldMap f (InR y) = foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Sum f g) where + traverse f (InL x) = InL <$> traverse f x + traverse f (InR y) = InR <$> traverse f y + +#if MIN_VERSION_base(4,12,0) +instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where + contramap f (InL xs) = InL (contramap f xs) + contramap f (InR ys) = InR (contramap f ys) +#endif |