feat(third_party/bazel): Check in rules_haskell from Tweag
This commit is contained in:
Vincent Ambo
parent
2eb1dc26e4
commit
f723b8b878
479 changed files with 51484 additions and 0 deletions
259
third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs
vendored
Normal file
259
third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs
vendored
Normal file
|
|
@ -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
|
||||
51
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs
vendored
Normal file
51
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs
vendored
Normal file
|
|
@ -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
|
||||
529
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs
vendored
Normal file
529
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs
vendored
Normal file
|
|
@ -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
|
||||
|
||||
-}
|
||||
154
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs
vendored
Normal file
154
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs
vendored
Normal file
|
|
@ -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
|
||||
156
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs
vendored
Normal file
156
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs
vendored
Normal file
|
|
@ -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
|
||||
136
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs
vendored
Normal file
136
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs
vendored
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue