diff options
Diffstat (limited to 'libraries/base/Data')
44 files changed, 2444 insertions, 1083 deletions
diff --git a/libraries/base/Data/Bifoldable.hs b/libraries/base/Data/Bifoldable.hs index 1f632e2ff9..4315fdb259 100644 --- a/libraries/base/Data/Bifoldable.hs +++ b/libraries/base/Data/Bifoldable.hs @@ -76,7 +76,7 @@ import GHC.Generics (K1(..)) -- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z -- @ -- --- If the type is also a 'Bifunctor' instance, it should satisfy: +-- If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy: -- -- > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g -- diff --git a/libraries/base/Data/Bifunctor.hs b/libraries/base/Data/Bifunctor.hs index 5441605ecf..04de5ad7f2 100644 --- a/libraries/base/Data/Bifunctor.hs +++ b/libraries/base/Data/Bifunctor.hs @@ -20,7 +20,15 @@ module Data.Bifunctor import Control.Applicative ( Const(..) ) import GHC.Generics ( K1(..) ) --- | Formally, the class 'Bifunctor' represents a bifunctor +-- | A bifunctor is a type constructor that takes +-- two type arguments and is a functor in /both/ arguments. That +-- is, unlike with 'Functor', a type constructor such as 'Either' +-- does not need to be partially applied for a 'Bifunctor' +-- instance, and the methods in this class permit mapping +-- functions over the 'Left' value or the 'Right' value, +-- or both at the same time. +-- +-- Formally, the class 'Bifunctor' represents a bifunctor -- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where both the first and second @@ -59,22 +67,49 @@ class Bifunctor p where -- | Map over both arguments at the same time. -- -- @'bimap' f g ≡ 'first' f '.' 'second' g@ + -- + -- ==== __Examples__ + -- >>> bimap toUpper (+1) ('j', 3) + -- ('J',4) + -- + -- >>> bimap toUpper (+1) (Left 'j') + -- Left 'J' + -- + -- >>> bimap toUpper (+1) (Right 3) + -- Right 4 bimap :: (a -> b) -> (c -> d) -> p a c -> p b d bimap f g = first f . second g + -- | Map covariantly over the first argument. -- -- @'first' f ≡ 'bimap' f 'id'@ + -- + -- ==== __Examples__ + -- >>> first toUpper ('j', 3) + -- ('J',3) + -- + -- >>> first toUpper (Left 'j') + -- Left 'J' first :: (a -> b) -> p a c -> p b c first f = bimap f id + -- | Map covariantly over the second argument. -- -- @'second' ≡ 'bimap' 'id'@ + -- + -- ==== __Examples__ + -- >>> second (+1) ('j', 3) + -- ('j',4) + -- + -- >>> second (+1) (Right 3) + -- Right 4 second :: (b -> c) -> p a b -> p a c second = bimap id + -- | @since 4.8.0.0 instance Bifunctor (,) where bimap f g ~(a, b) = (f a, g b) diff --git a/libraries/base/Data/Bitraversable.hs b/libraries/base/Data/Bitraversable.hs index 169510844d..4064929890 100644 --- a/libraries/base/Data/Bitraversable.hs +++ b/libraries/base/Data/Bitraversable.hs @@ -52,8 +52,11 @@ import GHC.Generics (K1(..)) -- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ -- -- [/composition/] --- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2 --- ≡ 'traverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@ +-- @'Data.Functor.Compose.Compose' . +-- 'fmap' ('bitraverse' g1 g2) . +-- 'bitraverse' f1 f2 +-- ≡ 'traverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1) +-- ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@ -- -- where an /applicative transformation/ is a function -- @@ -66,26 +69,9 @@ import GHC.Generics (K1(..)) -- t (f '<*>' x) = t f '<*>' t x -- @ -- --- and the identity functor 'Identity' and composition functors 'Compose' are --- defined as --- --- > newtype Identity a = Identity { runIdentity :: a } --- > --- > instance Functor Identity where --- > fmap f (Identity x) = Identity (f x) --- > --- > instance Applicative Identity where --- > pure = Identity --- > Identity f <*> Identity x = Identity (f x) --- > --- > newtype Compose f g a = Compose (f (g a)) --- > --- > instance (Functor f, Functor g) => Functor (Compose f g) where --- > fmap f (Compose x) = Compose (fmap (fmap f) x) --- > --- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where --- > pure = Compose . pure . pure --- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +-- and the identity functor 'Identity' and composition functors +-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and +-- "Data.Functor.Compose". -- -- Some simple examples are 'Either' and '(,)': -- diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index d12d6dc4bd..18110b55a8 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -57,17 +57,13 @@ module Data.Bits ( #include "MachDeps.h" -#if defined(MIN_VERSION_integer_gmp) -# define HAVE_INTEGER_GMP1 MIN_VERSION_integer_gmp(1,0,0) -#endif - import Data.Maybe import GHC.Enum import GHC.Num import GHC.Base import GHC.Real -#if HAVE_INTEGER_GMP1 +#if defined(MIN_VERSION_integer_gmp) import GHC.Integer.GMP.Internals (bitInteger, popCountInteger) #endif @@ -194,8 +190,12 @@ class Eq a => Bits a where {-| Return the number of bits in the type of the argument. The actual value of the argument is ignored. The function 'bitSize' is undefined for types that do not have a fixed bitsize, like 'Integer'. + + Default implementation based upon 'bitSizeMaybe' provided since + 4.12.0.0. -} bitSize :: a -> Int + bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b) {-| Return 'True' if the argument is a signed type. The actual value of the argument is ignored -} @@ -245,7 +245,7 @@ class Eq a => Bits a where x `shiftR` i = x `shift` (-i) {-| Shift the first argument right by the specified number of bits, which - must be non-negative an smaller than the number of bits in the type. + must be non-negative and smaller than the number of bits in the type. Right shifts perform sign extension on signed number types; i.e. they fill the top bits with 1 if the @x@ is negative @@ -526,7 +526,7 @@ instance Bits Integer where testBit x (I# i) = testBitInteger x i zeroBits = 0 -#if HAVE_INTEGER_GMP1 +#if defined(MIN_VERSION_integer_gmp) bit (I# i#) = bitInteger i# popCount x = I# (popCountInteger x) #else @@ -540,6 +540,74 @@ instance Bits Integer where bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0 +instance Bits Natural where + (.&.) = andNatural + (.|.) = orNatural + xor = xorNatural + complement _ = errorWithoutStackTrace + "Bits.complement: Natural complement undefined" + shift x i + | i >= 0 = shiftLNatural x i + | otherwise = shiftRNatural x (negate i) + testBit x i = testBitNatural x i + zeroBits = wordToNaturalBase 0## + clearBit x i = x `xor` (bit i .&. x) + + bit (I# i#) = bitNatural i# + popCount x = popCountNatural x + + rotate x i = shift x i -- since an Natural never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" + isSigned _ = False +#else +-- | @since 4.8.0.0 +instance Bits Natural where + Natural n .&. Natural m = Natural (n .&. m) + {-# INLINE (.&.) #-} + Natural n .|. Natural m = Natural (n .|. m) + {-# INLINE (.|.) #-} + xor (Natural n) (Natural m) = Natural (xor n m) + {-# INLINE xor #-} + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" + {-# INLINE complement #-} + shift (Natural n) = Natural . shift n + {-# INLINE shift #-} + rotate (Natural n) = Natural . rotate n + {-# INLINE rotate #-} + bit = Natural . bit + {-# INLINE bit #-} + setBit (Natural n) = Natural . setBit n + {-# INLINE setBit #-} + clearBit (Natural n) = Natural . clearBit n + {-# INLINE clearBit #-} + complementBit (Natural n) = Natural . complementBit n + {-# INLINE complementBit #-} + testBit (Natural n) = testBit n + {-# INLINE testBit #-} + bitSizeMaybe _ = Nothing + {-# INLINE bitSizeMaybe #-} + bitSize = errorWithoutStackTrace "Natural: bitSize" + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + shiftL (Natural n) = Natural . shiftL n + {-# INLINE shiftL #-} + shiftR (Natural n) = Natural . shiftR n + {-# INLINE shiftR #-} + rotateL (Natural n) = Natural . rotateL n + {-# INLINE rotateL #-} + rotateR (Natural n) = Natural . rotateR n + {-# INLINE rotateR #-} + popCount (Natural n) = popCount n + {-# INLINE popCount #-} + zeroBits = Natural 0 + +#endif + ----------------------------------------------------------------------------- -- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using diff --git a/libraries/base/Data/Char.hs b/libraries/base/Data/Char.hs index 69e4db7018..ac0664715c 100644 --- a/libraries/base/Data/Char.hs +++ b/libraries/base/Data/Char.hs @@ -132,6 +132,8 @@ digitToInt c -- True -- >>> isLetter 'A' -- True +-- >>> isLetter 'λ' +-- True -- >>> isLetter '0' -- False -- >>> isLetter '%' diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs index dd3e0eca0b..a544a5bf6c 100644 --- a/libraries/base/Data/Complex.hs +++ b/libraries/base/Data/Complex.hs @@ -55,11 +55,23 @@ infix 6 :+ -- has the phase of @z@, but unit magnitude. -- -- The 'Foldable' and 'Traversable' instances traverse the real part first. +-- +-- Note that `Complex`'s instances inherit the deficiencies from the type +-- parameter's. For example, @Complex Float@'s 'Ord' instance has similar +-- problems to `Float`'s. data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. - deriving (Eq, Show, Read, Data, Generic, Generic1 - , Functor, Foldable, Traversable) + deriving ( Eq -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Data -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Functor -- ^ @since 4.9.0.0 + , Foldable -- ^ @since 4.9.0.0 + , Traversable -- ^ @since 4.9.0.0 + ) -- ----------------------------------------------------------------------------- -- Functions over Complex @@ -197,7 +209,8 @@ instance (RealFloat a) => Floating (Complex a) where where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) asinh z = log (z + sqrt (1+z*z)) - acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + -- Take care to allow (-1)::Complex, fixing #8532 + acosh z = log (z + (sqrt $ z+1) * (sqrt $ z-1)) atanh z = 0.5 * log ((1.0+z) / (1.0-z)) log1p x@(a :+ b) diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 1b55f59b10..fa199f1117 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -4,12 +4,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- @@ -126,7 +126,6 @@ import Data.Version( Version(..) ) import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num -import GHC.Natural import GHC.Read import GHC.Show import Text.Read( reads ) @@ -140,6 +139,8 @@ import GHC.Real -- So we can give Data instance for Ratio --import GHC.IOBase -- So we can give Data instance for IO, Handle import GHC.Ptr -- So we can give Data instance for Ptr import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr +import Foreign.Ptr (IntPtr(..), WordPtr(..)) + -- So we can give Data instance for IntPtr and WordPtr --import GHC.Stable -- So we can give Data instance for StablePtr --import GHC.ST -- So we can give Data instance for ST --import GHC.Conc -- So we can give Data instance for MVar & Co. @@ -277,22 +278,34 @@ class Typeable a => Data a where ------------------------------------------------------------------------------ -- | Mediate types and unary type constructors. - -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined - -- as 'gcast1'. + -- + -- In 'Data' instances of the form + -- + -- @ + -- instance (Data a, ...) => Data (T a) + -- @ + -- + -- 'dataCast1' should be defined as 'gcast1'. -- -- The default definition is @'const' 'Nothing'@, which is appropriate - -- for non-unary type constructors. + -- for instances of other forms. dataCast1 :: Typeable t => (forall d. Data d => c (t d)) -> Maybe (c a) dataCast1 _ = Nothing -- | Mediate types and binary type constructors. - -- In 'Data' instances of the form @T a b@, 'dataCast2' should be - -- defined as 'gcast2'. + -- + -- In 'Data' instances of the form + -- + -- @ + -- instance (Data a, Data b, ...) => Data (T a b) + -- @ + -- + -- 'dataCast2' should be defined as 'gcast2'. -- -- The default definition is @'const' 'Nothing'@, which is appropriate - -- for non-binary type constructors. + -- for instances of other forms. dataCast2 :: Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a) @@ -497,7 +510,7 @@ data DataType = DataType , datarep :: DataRep } - deriving Show + deriving Show -- ^ @since 4.0.0.0 -- | Representation of constructors. Note that equality on constructors -- with different types may not work -- i.e. the constructors for 'False' and @@ -529,7 +542,9 @@ data DataRep = AlgRep [Constr] | CharRep | NoRep - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) -- The list of constructors could be an array, a balanced tree, or others. @@ -539,7 +554,9 @@ data ConstrRep = AlgConstr ConIndex | FloatConstr Rational | CharConstr Char - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) -- | Unique index for datatype constructors, @@ -551,7 +568,9 @@ type ConIndex = Int data Fixity = Prefix | Infix -- Later: add associativity and precedence - deriving (Eq,Show) + deriving ( Eq -- ^ @since 4.0.0.0 + , Show -- ^ @since 4.0.0.0 + ) ------------------------------------------------------------------------------ @@ -779,7 +798,7 @@ mkRealConstr dt f = case datarep dt of FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f)) _ -> errorWithoutStackTrace $ "Data.Data.mkRealConstr is not supported for " ++ dataTypeName dt ++ - ", as it is not an Real data type." + ", as it is not a Real data type." -- | Makes a constructor for 'Char'. mkCharConstr :: DataType -> Char -> Constr @@ -1137,6 +1156,9 @@ instance Data a => Data [a] where ------------------------------------------------------------------------------ +-- | @since 4.9.0.0 +deriving instance Data a => Data (NonEmpty a) + -- | @since 4.0.0.0 deriving instance Data a => Data (Maybe a) @@ -1189,6 +1211,12 @@ instance Data a => Data (ForeignPtr a) where dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr" dataCast1 x = gcast1 x +-- | @since 4.11.0.0 +deriving instance Data IntPtr + +-- | @since 4.11.0.0 +deriving instance Data WordPtr + ------------------------------------------------------------------------------ -- The Data instance for Array preserves data abstraction at the cost of -- inefficiency. We omit reflection services for the sake of data abstraction. @@ -1254,6 +1282,9 @@ deriving instance Data a => Data (Last a) -- | @since 4.8.0.0 deriving instance (Data (f a), Data a, Typeable f) => Data (Alt f a) +-- | @since 4.12.0.0 +deriving instance (Data (f a), Data a, Typeable f) => Data (Ap f a) + ---------------------------------------------------------------------------- -- Data instances for GHC.Generics representations @@ -1278,7 +1309,7 @@ deriving instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p)) => Data ((f :+: g) p) -- | @since 4.9.0.0 -deriving instance (Typeable (f :: * -> *), Typeable (g :: * -> *), +deriving instance (Typeable (f :: Type -> Type), Typeable (g :: Type -> Type), Data p, Data (f (g p))) => Data ((f :.: g) p) @@ -1303,3 +1334,9 @@ deriving instance Data SourceStrictness -- | @since 4.9.0.0 deriving instance Data DecidedStrictness + +---------------------------------------------------------------------------- +-- Data instances for Data.Ord + +-- | @since 4.12.0.0 +deriving instance Data a => Data (Down a) diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs index 2469e78511..58987a3910 100644 --- a/libraries/base/Data/Either.hs +++ b/libraries/base/Data/Either.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE StandaloneDeriving #-} @@ -33,8 +34,6 @@ import GHC.Base import GHC.Show import GHC.Read -import Data.Type.Equality - -- $setup -- Allow the use of some Prelude functions in doctests. -- >>> import Prelude ( (+), (*), length, putStrLn ) @@ -124,13 +123,28 @@ Left "parse error" -} data Either a b = Left a | Right b - deriving (Eq, Ord, Read, Show) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 3.0 + , Show -- ^ @since 3.0 + ) -- | @since 3.0 instance Functor (Either a) where fmap _ (Left x) = Left x fmap f (Right y) = Right (f y) +-- | @since 4.9.0.0 +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a +#if !defined(__HADDOCK_VERSION__) + -- workaround https://github.com/haskell/haddock/issues/680 + stimes n x + | n <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" + | otherwise = x +#endif + -- | @since 3.0 instance Applicative (Either e) where pure = Right @@ -150,7 +164,7 @@ instance Monad (Either e) where -- -- We create two values of type @'Either' 'String' 'Int'@, one using the -- 'Left' constructor and another using the 'Right' constructor. Then --- we apply \"either\" the 'length' function (if we have a 'String') +-- we apply \"either\" the 'Prelude.length' function (if we have a 'String') -- or the \"times-two\" function (if we have an 'Int'): -- -- >>> let s = Left "foo" :: Either String Int @@ -318,13 +332,6 @@ fromRight :: b -> Either a b -> b fromRight _ (Right b) = b fromRight b _ = b --- instance for the == Boolean type-level equality operator -type family EqEither a b where - EqEither ('Left x) ('Left y) = x == y - EqEither ('Right x) ('Right y) = x == y - EqEither a b = 'False -type instance a == b = EqEither a b - {- {-------------------------------------------------------------------- Testing @@ -333,4 +340,3 @@ prop_partitionEithers :: [Either Int Int] -> Bool prop_partitionEithers x = partitionEithers x == (lefts x, rights x) -} - diff --git a/libraries/base/Data/Fixed.hs b/libraries/base/Data/Fixed.hs index e5e1f2f746..b8db351257 100644 --- a/libraries/base/Data/Fixed.hs +++ b/libraries/base/Data/Fixed.hs @@ -57,8 +57,10 @@ mod' n d = n - (fromInteger f) * d where f = div' n d -- | The type parameter should be an instance of 'HasResolution'. -newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0 - deriving (Eq,Ord) +newtype Fixed a = MkFixed Integer + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) -- We do this because the automatically derived Data instance requires (Data a) context. -- Our manual instance has the more general (Typeable a) context. diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs index 1d9fc92ca5..f5f3112138 100644 --- a/libraries/base/Data/Foldable.hs +++ b/libraries/base/Data/Foldable.hs @@ -99,6 +99,8 @@ infix 4 `elem`, `notElem` -- -- > fold = foldMap id -- +-- > length = getSum . foldMap (Sum . const 1) +-- -- @sum@, @product@, @maximum@, and @minimum@ should all be essentially -- equivalent to @foldMap@ forms, such as -- @@ -170,8 +172,8 @@ class Foldable t where -- -- Also note that if you want an efficient left-fold, you probably want to -- use 'foldl'' instead of 'foldl'. The reason for this is that latter does - -- not force the "inner" results (e.g. @z `f` x1@ in the above example) - -- before applying them to the operator (e.g. to @(`f` x2)@). This results + -- not force the "inner" results (e.g. @z \`f\` x1@ in the above example) + -- before applying them to the operator (e.g. to @(\`f\` x2)@). This results -- in a thunk chain @O(n)@ elements long, which then must be evaluated from -- the outside-in. -- @@ -294,6 +296,32 @@ instance Foldable [] where sum = List.sum toList = id +-- | @since 4.9.0.0 +instance Foldable NonEmpty where + foldr f z ~(a :| as) = f a (List.foldr f z as) + foldl f z (a :| as) = List.foldl f (f z a) as + foldl1 f (a :| as) = List.foldl f a as + + -- GHC isn't clever enough to transform the default definition + -- into anything like this, so we'd end up shuffling a bunch of + -- Maybes around. + foldr1 f (p :| ps) = foldr go id ps p + where + go x r prev = f prev (r x) + + -- We used to say + -- + -- length (_ :| as) = 1 + length as + -- + -- but the default definition is better, counting from 1. + -- + -- The default definition also works great for null and foldl'. + -- As usual for cons lists, foldr' is basically hopeless. + + foldMap f ~(a :| as) = f a `mappend` foldMap f as + fold ~(m :| ms) = m `mappend` fold ms + toList ~(a :| as) = a : as + -- | @since 4.7.0.0 instance Foldable (Either a) where foldMap _ (Left _) = mempty @@ -408,6 +436,14 @@ instance Foldable First where instance Foldable Last where foldMap f = foldMap f . getLast +-- | @since 4.12.0.0 +instance (Foldable f) => Foldable (Alt f) where + foldMap f = foldMap f . getAlt + +-- | @since 4.12.0.0 +instance (Foldable f) => Foldable (Ap f) where + foldMap f = foldMap f . getAp + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance Foldable U1 where @@ -427,38 +463,76 @@ instance Foldable U1 where sum _ = 0 product _ = 1 +-- | @since 4.9.0.0 deriving instance Foldable V1 + +-- | @since 4.9.0.0 deriving instance Foldable Par1 + +-- | @since 4.9.0.0 deriving instance Foldable f => Foldable (Rec1 f) + +-- | @since 4.9.0.0 deriving instance Foldable (K1 i c) + +-- | @since 4.9.0.0 deriving instance Foldable f => Foldable (M1 i c f) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :+: g) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :*: g) + +-- | @since 4.9.0.0 deriving instance (Foldable f, Foldable g) => Foldable (f :.: g) + +-- | @since 4.9.0.0 deriving instance Foldable UAddr + +-- | @since 4.9.0.0 deriving instance Foldable UChar + +-- | @since 4.9.0.0 deriving instance Foldable UDouble + +-- | @since 4.9.0.0 deriving instance Foldable UFloat + +-- | @since 4.9.0.0 deriving instance Foldable UInt + +-- | @since 4.9.0.0 deriving instance Foldable UWord +-- Instances for Data.Ord +-- | @since 4.12.0.0 +deriving instance Foldable Down + -- | Monadic fold over the elements of a structure, -- associating to the right, i.e. from right to left. foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b -foldrM f z0 xs = foldl f' return xs z0 - where f' k x z = f x z >>= k +foldrM f z0 xs = foldl c return xs z0 + -- See Note [List fusion and continuations in 'c'] + where c k x z = f x z >>= k + {-# INLINE c #-} -- | Monadic fold over the elements of a structure, -- associating to the left, i.e. from left to right. foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b -foldlM f z0 xs = foldr f' return xs z0 - where f' x k z = f z x >>= k +foldlM f z0 xs = foldr c return xs z0 + -- See Note [List fusion and continuations in 'c'] + where c x k z = f z x >>= k + {-# INLINE c #-} -- | Map each element of a structure to an action, evaluate these -- actions from left to right, and ignore the results. For a version -- that doesn't ignore the results see 'Data.Traversable.traverse'. traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () -traverse_ f = foldr ((*>) . f) (pure ()) +traverse_ f = foldr c (pure ()) + -- See Note [List fusion and continuations in 'c'] + where c x k = f x *> k + {-# INLINE c #-} -- | 'for_' is 'traverse_' with its arguments flipped. For a version -- that doesn't ignore the results see 'Data.Traversable.for'. @@ -480,7 +554,10 @@ for_ = flip traverse_ -- As of base 4.8.0.0, 'mapM_' is just 'traverse_', specialized to -- 'Monad'. mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () -mapM_ f= foldr ((>>) . f) (return ()) +mapM_ f = foldr c (return ()) + -- See Note [List fusion and continuations in 'c'] + where c x k = f x >> k + {-# INLINE c #-} -- | 'forM_' is 'mapM_' with its arguments flipped. For a version that -- doesn't ignore the results see 'Data.Traversable.forM'. @@ -494,7 +571,10 @@ forM_ = flip mapM_ -- ignore the results. For a version that doesn't ignore the results -- see 'Data.Traversable.sequenceA'. sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () -sequenceA_ = foldr (*>) (pure ()) +sequenceA_ = foldr c (pure ()) + -- See Note [List fusion and continuations in 'c'] + where c m k = m *> k + {-# INLINE c #-} -- | Evaluate each monadic action in the structure from left to right, -- and ignore the results. For a version that doesn't ignore the @@ -503,9 +583,15 @@ sequenceA_ = foldr (*>) (pure ()) -- As of base 4.8.0.0, 'sequence_' is just 'sequenceA_', specialized -- to 'Monad'. sequence_ :: (Foldable t, Monad m) => t (m a) -> m () -sequence_ = foldr (>>) (return ()) +sequence_ = foldr c (return ()) + -- See Note [List fusion and continuations in 'c'] + where c m k = m >> k + {-# INLINE c #-} -- | The sum of a collection of actions, generalizing 'concat'. +-- +-- >>> asum [Just "Hello", Nothing, Just "World"] +-- Just "Hello" asum :: (Foldable t, Alternative f) => t (f a) -> f a {-# INLINE asum #-} asum = foldr (<|>) empty @@ -580,6 +666,84 @@ find :: Foldable t => (a -> Bool) -> t a -> Maybe a find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) {- +Note [List fusion and continuations in 'c'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we define + mapM_ f = foldr ((>>) . f) (return ()) +(this is the way it used to be). + +Now suppose we want to optimise the call + + mapM_ <big> (build g) + where + g c n = ...(c x1 y1)...(c x2 y2)....n... + +GHC used to proceed like this: + + mapM_ <big> (build g) + + = { Defintion of mapM_ } + foldr ((>>) . <big>) (return ()) (build g) + + = { foldr/build rule } + g ((>>) . <big>) (return ()) + + = { Inline g } + let c = (>>) . <big> + n = return () + in ...(c x1 y1)...(c x2 y2)....n... + +The trouble is that `c`, being big, will not be inlined. And that can +be absolutely terrible for performance, as we saw in Trac #8763. + +It's much better to define + + mapM_ f = foldr c (return ()) + where + c x k = f x >> k + {-# INLINE c #-} + +Now we get + mapM_ <big> (build g) + + = { inline mapM_ } + foldr c (return ()) (build g) + where c x k = f x >> k + {-# INLINE c #-} + f = <big> + +Notice that `f` does not inline into the RHS of `c`, +because the INLINE pragma stops it; see +Note [Simplifying inside stable unfoldings] in SimplUtils. +Continuing: + + = { foldr/build rule } + g c (return ()) + where ... + c x k = f x >> k + {-# INLINE c #-} + f = <big> + + = { inline g } + ...(c x1 y1)...(c x2 y2)....n... + where c x k = f x >> k + {-# INLINE c #-} + f = <big> + n = return () + + Now, crucially, `c` does inline + + = { inline c } + ...(f x1 >> y1)...(f x2 >> y2)....n... + where f = <big> + n = return () + +And all is well! The key thing is that the fragment +`(f x1 >> y1)` is inlined into the body of the builder +`g`. +-} + +{- Note [maximumBy/minimumBy space usage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the type signatures of maximumBy and minimumBy were generalized to work diff --git a/libraries/base/Data/Function.hs b/libraries/base/Data/Function.hs index c5ded4cda5..7a77160a60 100644 --- a/libraries/base/Data/Function.hs +++ b/libraries/base/Data/Function.hs @@ -32,21 +32,41 @@ infixl 1 & -- | @'fix' f@ is the least fixed point of the function @f@, -- i.e. the least defined @x@ such that @f x = x@. +-- +-- For example, we can write the factorial function using direct recursion as +-- +-- >>> let fac n = if n <= 1 then 1 else n * fac (n-1) in fac 5 +-- 120 +-- +-- This uses the fact that Haskell’s @let@ introduces recursive bindings. We can +-- rewrite this definition using 'fix', +-- +-- >>> fix (\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5 +-- 120 +-- +-- Instead of making a recursive call, we introduce a dummy parameter @rec@; +-- when used within 'fix', this parameter then refers to 'fix' argument, hence +-- the recursion is reintroduced. fix :: (a -> a) -> a fix f = let x = f x in x --- | @(*) \`on\` f = \\x y -> f x * f y@. +-- | @'on' b u x y@ runs the binary function @b@ /on/ the results of applying +-- unary function @u@ to two arguments @x@ and @y@. From the opposite +-- perspective, it transforms two inputs and combines the outputs. +-- +-- @((+) \``on`\` f) x y = f x + f y@ -- --- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@. +-- Typical usage: @'Data.List.sortBy' ('Prelude.compare' \`on\` 'Prelude.fst')@. -- -- Algebraic properties: -- --- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@) +-- * @(*) \`on\` 'id' = (*) -- (if (*) ∉ {⊥, 'const' ⊥})@ -- -- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@ -- -- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@ - +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +(.*.) `on` f = \x y -> f x .*. f y -- Proofs (so that I don't have to edit the test-suite): -- (*) `on` id @@ -87,14 +107,17 @@ fix f = let x = f x in x -- = -- flip on (g . f) -on :: (b -> b -> c) -> (a -> b) -> a -> a -> c -(.*.) `on` f = \x y -> f x .*. f y - -- | '&' is a reverse application operator. This provides notational -- convenience. Its precedence is one higher than that of the forward -- application operator '$', which allows '&' to be nested in '$'. -- +-- >>> 5 & (+1) & show +-- "6" +-- -- @since 4.8.0.0 (&) :: a -> (a -> b) -> b x & f = f x + +-- $setup +-- >>> import Prelude diff --git a/libraries/base/Data/Functor.hs b/libraries/base/Data/Functor.hs index 62bb70927e..7afcffe05b 100644 --- a/libraries/base/Data/Functor.hs +++ b/libraries/base/Data/Functor.hs @@ -11,8 +11,31 @@ -- Stability : provisional -- Portability : portable -- --- Functors: uniform action over a parameterized type, generalizing the --- 'Data.List.map' function on lists. +-- +-- A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@, +-- lets you apply any function of type @(a -> b)@ to turn an @f a@ into an @f b@, preserving the +-- structure of @f@. +-- +-- ==== __Examples__ +-- +-- >>> fmap show (Just 1) -- (a -> b) -> f a -> f b +-- Just "1" -- (Int -> String) -> Maybe Int -> Maybe String +-- +-- >>> fmap show Nothing -- (a -> b) -> f a -> f b +-- Nothing -- (Int -> String) -> Maybe Int -> Maybe String +-- +-- >>> fmap show [1,2,3] -- (a -> b) -> f a -> f b +-- ["1", "2", "3"] -- (Int -> String) -> [Int] -> [String] +-- +-- >>> fmap show [] -- (a -> b) -> f a -> f b +-- [] -- (Int -> String) -> [Int] -> [String] +-- +-- The 'fmap' function is also available as the infix operator '<$>': +-- +-- >>> fmap show (Just 1) -- (Int -> String) -> Maybe Int -> Maybe String +-- Just "1" +-- >>> show <$> (Just 1) -- (Int -> String) -> Maybe Int -> Maybe String +-- Just "1" module Data.Functor ( @@ -20,6 +43,7 @@ module Data.Functor (<$), ($>), (<$>), + (<&>), void, ) where @@ -33,26 +57,27 @@ infixl 4 <$> -- | An infix synonym for 'fmap'. -- --- The name of this operator is an allusion to '$'. +-- The name of this operator is an allusion to 'Prelude.$'. -- Note the similarities between their types: -- -- > ($) :: (a -> b) -> a -> b -- > (<$>) :: Functor f => (a -> b) -> f a -> f b -- --- Whereas '$' is function application, '<$>' is function +-- Whereas 'Prelude.$' is function application, '<$>' is function -- application lifted over a 'Functor'. -- -- ==== __Examples__ -- --- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show': +-- Convert from a @'Data.Maybe.Maybe' 'Data.Int.Int'@ to a @'Data.Maybe.Maybe' +-- 'Data.String.String'@ using 'Prelude.show': -- -- >>> show <$> Nothing -- Nothing -- >>> show <$> Just 3 -- Just "3" -- --- Convert from an @'Either' 'Int' 'Int'@ to an @'Either' 'Int'@ --- 'String' using 'show': +-- Convert from an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ to an +-- @'Data.Either.Either' 'Data.Int.Int'@ 'Data.String.String' using 'Prelude.show': -- -- >>> show <$> Left 17 -- Left 17 @@ -64,7 +89,7 @@ infixl 4 <$> -- >>> (*2) <$> [1,2,3] -- [2,4,6] -- --- Apply 'even' to the second element of a pair: +-- Apply 'Prelude.even' to the second element of a pair: -- -- >>> even <$> (2,2) -- (2,True) @@ -74,33 +99,60 @@ infixl 4 <$> infixl 4 $> +-- | Flipped version of '<$>'. +-- +-- @ +-- ('<&>') = 'flip' 'fmap' +-- @ +-- +-- @since 4.11.0.0 +-- +-- ==== __Examples__ +-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right': +-- +-- >>> Just 2 <&> (+1) +-- Just 3 +-- +-- >>> [1,2,3] <&> (+1) +-- [2,3,4] +-- +-- >>> Right 3 <&> (+1) +-- Right 4 +-- +(<&>) :: Functor f => f a -> (a -> b) -> f b +as <&> f = f <$> as + +infixl 1 <&> + -- | Flipped version of '<$'. -- -- @since 4.7.0.0 -- -- ==== __Examples__ -- --- Replace the contents of a @'Maybe' 'Int'@ with a constant 'String': +-- Replace the contents of a @'Data.Maybe.Maybe' 'Data.Int.Int'@ with a constant +-- 'Data.String.String': -- -- >>> Nothing $> "foo" -- Nothing -- >>> Just 90210 $> "foo" -- Just "foo" -- --- Replace the contents of an @'Either' 'Int' 'Int'@ with a constant --- 'String', resulting in an @'Either' 'Int' 'String'@: +-- Replace the contents of an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ +-- with a constant 'Data.String.String', resulting in an @'Data.Either.Either' +-- 'Data.Int.Int' 'Data.String.String'@: -- -- >>> Left 8675309 $> "foo" -- Left 8675309 -- >>> Right 8675309 $> "foo" -- Right "foo" -- --- Replace each element of a list with a constant 'String': +-- Replace each element of a list with a constant 'Data.String.String': -- -- >>> [1,2,3] $> "foo" -- ["foo","foo","foo"] -- --- Replace the second element of a pair with a constant 'String': +-- Replace the second element of a pair with a constant 'Data.String.String': -- -- >>> (1,2) $> "foo" -- (1,"foo") @@ -113,15 +165,15 @@ infixl 4 $> -- -- ==== __Examples__ -- --- Replace the contents of a @'Maybe' 'Int'@ with unit: +-- Replace the contents of a @'Data.Maybe.Maybe' 'Data.Int.Int'@ with unit: -- -- >>> void Nothing -- Nothing -- >>> void (Just 3) -- Just () -- --- Replace the contents of an @'Either' 'Int' 'Int'@ with unit, --- resulting in an @'Either' 'Int' '()'@: +-- Replace the contents of an @'Data.Either.Either' 'Data.Int.Int' 'Data.Int.Int'@ +-- with unit, resulting in an @'Data.Either.Either' 'Data.Int.Int' '()'@: -- -- >>> void (Left 8675309) -- Left 8675309 diff --git a/libraries/base/Data/Functor/Classes.hs b/libraries/base/Data/Functor/Classes.hs index 2510da911f..e44c817b64 100644 --- a/libraries/base/Data/Functor/Classes.hs +++ b/libraries/base/Data/Functor/Classes.hs @@ -68,7 +68,9 @@ import Control.Applicative (Alternative((<|>)), Const(Const)) import Data.Functor.Identity (Identity(Identity)) import Data.Proxy (Proxy(Proxy)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (mappend) +import Data.Ord (Down(Down)) import GHC.Read (expectP, list, paren) @@ -452,6 +454,27 @@ instance Read1 [] where instance Show1 [] where liftShowsPrec _ sl _ = sl +-- | @since 4.10.0.0 +instance Eq1 NonEmpty where + liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs + +-- | @since 4.10.0.0 +instance Ord1 NonEmpty where + liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs + +-- | @since 4.10.0.0 +instance Read1 NonEmpty where + liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do + (a, s'') <- rdP 6 s' + (":|", s''') <- lex s'' + (as, s'''') <- rdL s''' + return (a :| as, s'''')) s + +-- | @since 4.10.0.0 +instance Show1 NonEmpty where + liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $ + shwP 6 a . showString " :| " . shwL as + -- | @since 4.9.0.0 instance Eq2 (,) where liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 @@ -622,6 +645,24 @@ instance Read1 Proxy where liftReadListPrec = liftReadListPrecDefault liftReadList = liftReadListDefault +-- | @since 4.12.0.0 +instance Eq1 Down where + liftEq eq (Down x) (Down y) = eq x y + +-- | @since 4.12.0.0 +instance Ord1 Down where + liftCompare comp (Down x) (Down y) = comp x y + +-- | @since 4.12.0.0 +instance Read1 Down where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Down" Down + +-- | @since 4.12.0.0 +instance Show1 Down where + liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x + + -- Building blocks -- | @'readsData' p d@ is a parser for datatypes where each alternative diff --git a/libraries/base/Data/Functor/Compose.hs b/libraries/base/Data/Functor/Compose.hs index 68fbfc630a..8ceadb8572 100644 --- a/libraries/base/Data/Functor/Compose.hs +++ b/libraries/base/Data/Functor/Compose.hs @@ -38,7 +38,10 @@ infixr 9 `Compose` -- 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) } - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- Instances of lifted Prelude classes diff --git a/libraries/base/Data/Functor/Const.hs b/libraries/base/Data/Functor/Const.hs index 9199b7cf94..4e4992dcf6 100644 --- a/libraries/base/Data/Functor/Const.hs +++ b/libraries/base/Data/Functor/Const.hs @@ -37,12 +37,29 @@ import GHC.Show (Show(showsPrec), showParen, showString) -- | The 'Const' functor. newtype Const a b = Const { getConst :: a } - deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional - , Generic, Generic1, Integral, Ix, Monoid, Num, Ord, Real - , RealFrac, RealFloat , Storable) + deriving ( Bits -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , FiniteBits -- ^ @since 4.9.0.0 + , Floating -- ^ @since 4.9.0.0 + , Fractional -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + , Integral -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.9.0.0 + , Monoid -- ^ @since 4.9.0.0 + , Num -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Real -- ^ @since 4.9.0.0 + , RealFrac -- ^ @since 4.9.0.0 + , RealFloat -- ^ @since 4.9.0.0 + , Storable -- ^ @since 4.9.0.0 + ) -- | This instance would be equivalent to the derived instances of the --- 'Const' newtype if the 'runConst' field were removed +-- 'Const' newtype if the 'getConst' field were removed -- -- @since 4.8.0.0 instance Read a => Read (Const a b) where @@ -50,7 +67,7 @@ instance Read a => Read (Const a b) where $ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s] -- | This instance would be equivalent to the derived instances of the --- 'Const' newtype if the 'runConst' field were removed +-- 'Const' newtype if the 'getConst' field were removed -- -- @since 4.8.0.0 instance Show a => Show (Const a b) where diff --git a/libraries/base/Data/Functor/Contravariant.hs b/libraries/base/Data/Functor/Contravariant.hs new file mode 100644 index 0000000000..184eee2772 --- /dev/null +++ b/libraries/base/Data/Functor/Contravariant.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Contravariant +-- Copyright : (C) 2007-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@, +-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor' +-- the definition of 'Contravariant' for a given ADT is unambiguous. +-- +-- @since 4.12.0.0 +---------------------------------------------------------------------------- + +module Data.Functor.Contravariant ( + -- * Contravariant Functors + Contravariant(..) + , phantom + + -- * Operators + , (>$<), (>$$<), ($<) + + -- * Predicates + , Predicate(..) + + -- * Comparisons + , Comparison(..) + , defaultComparison + + -- * Equivalence Relations + , Equivalence(..) + , defaultEquivalence + , comparisonEquivalence + + -- * Dual arrows + , Op(..) + ) where + +import Control.Applicative +import Control.Category +import Data.Function (on) + +import Data.Functor.Product +import Data.Functor.Sum +import Data.Functor.Compose + +import Data.Monoid (Alt(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Proxy +import GHC.Generics + +import Prelude hiding ((.),id) + +-- | The class of contravariant functors. +-- +-- Whereas in Haskell, one can think of a 'Functor' as containing or producing +-- values, a contravariant functor is a functor that can be thought of as +-- /consuming/ values. +-- +-- As an example, consider the type of predicate functions @a -> Bool@. One +-- such predicate might be @negative x = x < 0@, which +-- classifies integers as to whether they are negative. However, given this +-- predicate, we can re-use it in other situations, providing we have a way to +-- map values /to/ integers. For instance, we can use the @negative@ predicate +-- on a person's bank balance to work out if they are currently overdrawn: +-- +-- @ +-- newtype Predicate a = Predicate { getPredicate :: a -> Bool } +-- +-- instance Contravariant Predicate where +-- contramap f (Predicate p) = Predicate (p . f) +-- | `- First, map the input... +-- `----- then apply the predicate. +-- +-- overdrawn :: Predicate Person +-- overdrawn = contramap personBankBalance negative +-- @ +-- +-- Any instance should be subject to the following laws: +-- +-- > contramap id = id +-- > contramap f . contramap g = contramap (g . f) +-- +-- Note, that the second law follows from the free theorem of the type of +-- 'contramap' and the first law, so you need only check that the former +-- condition holds. + +class Contravariant f where + contramap :: (a -> b) -> f b -> f a + + -- | Replace all locations in the output with the same value. + -- The default definition is @'contramap' . 'const'@, but this may be + -- overridden with a more efficient version. + (>$) :: b -> f b -> f a + (>$) = contramap . const + +-- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor +-- in the laws of each of those classes, it can't actually use its argument in +-- any meaningful capacity. +-- +-- This method is surprisingly useful. Where both instances exist and are +-- lawful we have the following laws: +-- +-- @ +-- 'fmap' f ≡ 'phantom' +-- 'contramap' f ≡ 'phantom' +-- @ +phantom :: (Functor f, Contravariant f) => f a -> f b +phantom x = () <$ x $< () + +infixl 4 >$, $<, >$<, >$$< + +-- | This is '>$' with its arguments flipped. +($<) :: Contravariant f => f b -> b -> f a +($<) = flip (>$) + +-- | This is an infix alias for 'contramap'. +(>$<) :: Contravariant f => (a -> b) -> f b -> f a +(>$<) = contramap + +-- | This is an infix version of 'contramap' with the arguments flipped. +(>$$<) :: Contravariant f => f b -> (a -> b) -> f a +(>$$<) = flip contramap + +deriving instance Contravariant f => Contravariant (Alt f) +deriving instance Contravariant f => Contravariant (Rec1 f) +deriving instance Contravariant f => Contravariant (M1 i c f) + +instance Contravariant V1 where + contramap _ x = case x of + +instance Contravariant U1 where + contramap _ _ = U1 + +instance Contravariant (K1 i c) where + contramap _ (K1 c) = K1 c + +instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where + contramap f (xs :*: ys) = contramap f xs :*: contramap f ys + +instance (Functor f, Contravariant g) => Contravariant (f :.: g) where + contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg) + +instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where + contramap f (L1 xs) = L1 (contramap f xs) + contramap f (R1 ys) = R1 (contramap f ys) + +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) + +instance (Contravariant f, Contravariant g) + => Contravariant (Product f g) where + contramap f (Pair a b) = Pair (contramap f a) (contramap f b) + +instance Contravariant (Const a) where + contramap _ (Const a) = Const a + +instance (Functor f, Contravariant g) => Contravariant (Compose f g) where + contramap f (Compose fga) = Compose (fmap (contramap f) fga) + +instance Contravariant Proxy where + contramap _ _ = Proxy + +newtype Predicate a = Predicate { getPredicate :: a -> Bool } + +-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to the input of the predicate. +instance Contravariant Predicate where + contramap f g = Predicate $ getPredicate g . f + +instance Semigroup (Predicate a) where + Predicate p <> Predicate q = Predicate $ \a -> p a && q a + +instance Monoid (Predicate a) where + mempty = Predicate $ const True + +-- | Defines a total ordering on a type as per 'compare'. +-- +-- This condition is not checked by the types. You must ensure that the +-- supplied values are valid total orderings yourself. +newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering } + +deriving instance Semigroup (Comparison a) +deriving instance Monoid (Comparison a) + +-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can +-- apply its function argument to each input of the comparison function. +instance Contravariant Comparison where + contramap f g = Comparison $ on (getComparison g) f + +-- | Compare using 'compare'. +defaultComparison :: Ord a => Comparison a +defaultComparison = Comparison compare + +-- | This data type represents an equivalence relation. +-- +-- Equivalence relations are expected to satisfy three laws: +-- +-- __Reflexivity__: +-- +-- @ +-- 'getEquivalence' f a a = True +-- @ +-- +-- __Symmetry__: +-- +-- @ +-- 'getEquivalence' f a b = 'getEquivalence' f b a +-- @ +-- +-- __Transitivity__: +-- +-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' +-- then so is @'getEquivalence' f a c@. +-- +-- The types alone do not enforce these laws, so you'll have to check them +-- yourself. +newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool } + +-- | Equivalence relations are 'Contravariant', because you can +-- apply the contramapped function to each input to the equivalence +-- relation. +instance Contravariant Equivalence where + contramap f g = Equivalence $ on (getEquivalence g) f + +instance Semigroup (Equivalence a) where + Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b + +instance Monoid (Equivalence a) where + mempty = Equivalence (\_ _ -> True) + +-- | Check for equivalence with '=='. +-- +-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@. +defaultEquivalence :: Eq a => Equivalence a +defaultEquivalence = Equivalence (==) + +comparisonEquivalence :: Comparison a -> Equivalence a +comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ + +-- | Dual function arrows. +newtype Op a b = Op { getOp :: b -> a } + +deriving instance Semigroup a => Semigroup (Op a b) +deriving instance Monoid a => Monoid (Op a b) + +instance Category Op where + id = Op id + Op f . Op g = Op (g . f) + +instance Contravariant (Op a) where + contramap f g = Op (getOp g . f) + +instance Num a => Num (Op a b) where + Op f + Op g = Op $ \a -> f a + g a + Op f * Op g = Op $ \a -> f a * g a + Op f - Op g = Op $ \a -> f a - g a + abs (Op f) = Op $ abs . f + signum (Op f) = Op $ signum . f + fromInteger = Op . const . fromInteger + +instance Fractional a => Fractional (Op a b) where + Op f / Op g = Op $ \a -> f a / g a + recip (Op f) = Op $ recip . f + fromRational = Op . const . fromRational + +instance Floating a => Floating (Op a b) where + pi = Op $ const pi + exp (Op f) = Op $ exp . f + sqrt (Op f) = Op $ sqrt . f + log (Op f) = Op $ log . f + sin (Op f) = Op $ sin . f + tan (Op f) = Op $ tan . f + cos (Op f) = Op $ cos . f + asin (Op f) = Op $ asin . f + atan (Op f) = Op $ atan . f + acos (Op f) = Op $ acos . f + sinh (Op f) = Op $ sinh . f + tanh (Op f) = Op $ tanh . f + cosh (Op f) = Op $ cosh . f + asinh (Op f) = Op $ asinh . f + atanh (Op f) = Op $ atanh . f + acosh (Op f) = Op $ acosh . f + Op f ** Op g = Op $ \a -> f a ** g a + logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a) diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs index 1fe127f310..daaa3a450c 100644 --- a/libraries/base/Data/Functor/Identity.hs +++ b/libraries/base/Data/Functor/Identity.hs @@ -43,7 +43,7 @@ import Data.Functor.Utils ((#.)) import Foreign.Storable (Storable) import GHC.Arr (Ix) import GHC.Base ( Applicative(..), Eq(..), Functor(..), Monad(..) - , Monoid, Ord(..), ($), (.) ) + , Semigroup, Monoid, Ord(..), ($), (.) ) import GHC.Enum (Bounded, Enum) import GHC.Float (Floating, RealFloat) import GHC.Generics (Generic, Generic1) @@ -57,9 +57,26 @@ import GHC.Types (Bool(..)) -- -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a } - deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional - , Generic, Generic1, Integral, Ix, Monoid, Num, Ord - , Real, RealFrac, RealFloat, Storable) + deriving ( Bits -- ^ @since 4.9.0.0 + , Bounded -- ^ @since 4.9.0.0 + , Enum -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.8.0.0 + , FiniteBits -- ^ @since 4.9.0.0 + , Floating -- ^ @since 4.9.0.0 + , Fractional -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.8.0.0 + , Generic1 -- ^ @since 4.8.0.0 + , Integral -- ^ @since 4.9.0.0 + , Ix -- ^ @since 4.9.0.0 + , Semigroup -- ^ @since 4.9.0.0 + , Monoid -- ^ @since 4.9.0.0 + , Num -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.8.0.0 + , Real -- ^ @since 4.9.0.0 + , RealFrac -- ^ @since 4.9.0.0 + , RealFloat -- ^ @since 4.9.0.0 + , Storable -- ^ @since 4.9.0.0 + ) -- | This instance would be equivalent to the derived instances of the -- 'Identity' newtype if the 'runIdentity' field were removed diff --git a/libraries/base/Data/Functor/Product.hs b/libraries/base/Data/Functor/Product.hs index 7676aa5f0c..d98d31ea59 100644 --- a/libraries/base/Data/Functor/Product.hs +++ b/libraries/base/Data/Functor/Product.hs @@ -35,7 +35,10 @@ import Text.Read (Read(..), readListDefault, readListPrecDefault) -- | Lifted product of functors. data Product f g a = Pair (f a) (g a) - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where diff --git a/libraries/base/Data/Functor/Sum.hs b/libraries/base/Data/Functor/Sum.hs index f18feae2f0..68e60fe817 100644 --- a/libraries/base/Data/Functor/Sum.hs +++ b/libraries/base/Data/Functor/Sum.hs @@ -31,7 +31,10 @@ import Text.Read (Read(..), readListDefault, readListPrecDefault) -- | Lifted sum of functors. data Sum f g a = InL (f a) | InR (g a) - deriving (Data, Generic, Generic1) + deriving ( Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where diff --git a/libraries/base/Data/Functor/Utils.hs b/libraries/base/Data/Functor/Utils.hs index 1bd729bcca..57e75424da 100644 --- a/libraries/base/Data/Functor/Utils.hs +++ b/libraries/base/Data/Functor/Utils.hs @@ -11,7 +11,7 @@ module Data.Functor.Utils where import Data.Coerce (Coercible, coerce) import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..) - , ($), otherwise ) + , Semigroup(..), ($), otherwise ) -- We don't expose Max and Min because, as Edward Kmett pointed out to me, -- there are two reasonable ways to define them. One way is to use Maybe, as we @@ -22,29 +22,33 @@ import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..) newtype Max a = Max {getMax :: Maybe a} newtype Min a = Min {getMin :: Maybe a} +-- | @since 4.11.0.0 +instance Ord a => Semigroup (Max a) where + {-# INLINE (<>) #-} + m <> Max Nothing = m + Max Nothing <> n = n + (Max m@(Just x)) <> (Max n@(Just y)) + | x >= y = Max m + | otherwise = Max n + -- | @since 4.8.0.0 instance Ord a => Monoid (Max a) where - mempty = Max Nothing + mempty = Max Nothing - {-# INLINE mappend #-} - m `mappend` Max Nothing = m - Max Nothing `mappend` n = n - (Max m@(Just x)) `mappend` (Max n@(Just y)) - | x >= y = Max m - | otherwise = Max n +-- | @since 4.11.0.0 +instance Ord a => Semigroup (Min a) where + {-# INLINE (<>) #-} + m <> Min Nothing = m + Min Nothing <> n = n + (Min m@(Just x)) <> (Min n@(Just y)) + | x <= y = Min m + | otherwise = Min n -- | @since 4.8.0.0 instance Ord a => Monoid (Min a) where - mempty = Min Nothing - - {-# INLINE mappend #-} - m `mappend` Min Nothing = m - Min Nothing `mappend` n = n - (Min m@(Just x)) `mappend` (Min n@(Just y)) - | x <= y = Min m - | otherwise = Min n + mempty = Min Nothing --- left-to-right state transformer +-- left-to-right state-transforming monad newtype StateL s a = StateL { runStateL :: s -> (s, a) } -- | @since 4.0 @@ -63,7 +67,7 @@ instance Applicative (StateL s) where (s'', y) = ky s' in (s'', f x y) --- right-to-left state transformer +-- right-to-left state-transforming monad newtype StateR s a = StateR { runStateR :: s -> (s, a) } -- | @since 4.0 diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs index c6275f5433..44769268cf 100644 --- a/libraries/base/Data/IORef.hs +++ b/libraries/base/Data/IORef.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -36,8 +37,7 @@ module Data.IORef import GHC.Base import GHC.STRef -import GHC.IORef hiding (atomicModifyIORef) -import qualified GHC.IORef +import GHC.IORef import GHC.Weak -- |Make a 'Weak' pointer to an 'IORef', using the second argument as a finalizer @@ -91,18 +91,9 @@ modifyIORef' ref f = do -- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem. -- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef = GHC.IORef.atomicModifyIORef - --- | Strict version of 'atomicModifyIORef'. This forces both the value stored --- in the 'IORef' as well as the value returned. --- --- @since 4.6.0.0 -atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef' ref f = do - b <- atomicModifyIORef ref $ \a -> - case f a of - v@(a',_) -> a' `seq` v - b `seq` return b +atomicModifyIORef ref f = do + (_old, ~(_new, res)) <- atomicModifyIORef2 ref f + pure res -- | Variant of 'writeIORef' with the \"barrier to reordering\" property that -- 'atomicModifyIORef' has. @@ -110,8 +101,8 @@ atomicModifyIORef' ref f = do -- @since 4.6.0.0 atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref a = do - x <- atomicModifyIORef ref (\_ -> (a, ())) - x `seq` return () + _ <- atomicSwapIORef ref a + pure () {- $memmodel @@ -120,19 +111,23 @@ atomicWriteIORef ref a = do processor architecture. For example, on x86, loads can move ahead of stores, so in the following example: -> maybePrint :: IORef Bool -> IORef Bool -> IO () -> maybePrint myRef yourRef = do -> writeIORef myRef True -> yourVal <- readIORef yourRef -> unless yourVal $ putStrLn "critical section" -> -> main :: IO () -> main = do -> r1 <- newIORef False -> r2 <- newIORef False -> forkIO $ maybePrint r1 r2 -> forkIO $ maybePrint r2 r1 -> threadDelay 1000000 + > import Data.IORef + > import Control.Monad (unless) + > import Control.Concurrent (forkIO, threadDelay) + > + > maybePrint :: IORef Bool -> IORef Bool -> IO () + > maybePrint myRef yourRef = do + > writeIORef myRef True + > yourVal <- readIORef yourRef + > unless yourVal $ putStrLn "critical section" + > + > main :: IO () + > main = do + > r1 <- newIORef False + > r2 <- newIORef False + > forkIO $ maybePrint r1 r2 + > forkIO $ maybePrint r2 r1 + > threadDelay 1000000 it is possible that the string @"critical section"@ is printed twice, even though there is no interleaving of the operations of the diff --git a/libraries/base/Data/Kind.hs b/libraries/base/Data/Kind.hs index 348301347c..9ee7b7ab07 100644 --- a/libraries/base/Data/Kind.hs +++ b/libraries/base/Data/Kind.hs @@ -14,6 +14,6 @@ -- @since 4.9.0.0 ----------------------------------------------------------------------------- -module Data.Kind ( Type, Constraint, type (*), type (★) ) where +module Data.Kind ( Type, Constraint ) where import GHC.Types diff --git a/libraries/base/Data/List.hs b/libraries/base/Data/List.hs index 693c0dd151..4b839e954f 100644 --- a/libraries/base/Data/List.hs +++ b/libraries/base/Data/List.hs @@ -76,6 +76,7 @@ module Data.List -- ** Infinite lists , iterate + , iterate' , repeat , replicate , cycle @@ -177,8 +178,8 @@ module Data.List -- counterpart whose name is suffixed with \`@By@\'. -- -- It is often convenient to use these functions together with - -- 'Data.Function.on', for instance @'sortBy' ('compare' - -- \`on\` 'fst')@. + -- 'Data.Function.on', for instance @'sortBy' ('Prelude.compare' + -- ``Data.Function.on`` 'Prelude.fst')@. -- *** User-supplied equality (replacing an @Eq@ context) -- | The predicate is assumed to define an equivalence. diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs index d1cc28c91f..61c1f3d414 100644 --- a/libraries/base/Data/List/NonEmpty.hs +++ b/libraries/base/Data/List/NonEmpty.hs @@ -102,65 +102,14 @@ import Prelude hiding (break, cycle, drop, dropWhile, import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) -import Control.Monad (ap, liftM2) -import Control.Monad.Fix -import Control.Monad.Zip (MonadZip(..)) -import Data.Data (Data) import Data.Foldable hiding (length, toList) import qualified Data.Foldable as Foldable import Data.Function (on) -import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) import qualified Data.List as List -import Data.Monoid ((<>)) import Data.Ord (comparing) -import qualified GHC.Exts as Exts (IsList(..)) -import GHC.Generics (Generic, Generic1) +import GHC.Base (NonEmpty(..)) -infixr 5 :|, <| - --- | Non-empty (and non-strict) list type. --- --- @since 4.9.0.0 -data NonEmpty a = a :| [a] - deriving ( Eq, Ord, Show, Read, Data, Generic, Generic1 ) - --- | @since 4.10.0.0 -instance Eq1 NonEmpty where - liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs - --- | @since 4.10.0.0 -instance Ord1 NonEmpty where - liftCompare cmp (a :| as) (b :| bs) = cmp a b <> liftCompare cmp as bs - --- | @since 4.10.0.0 -instance Read1 NonEmpty where - liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do - (a, s'') <- rdP 6 s' - (":|", s''') <- lex s'' - (as, s'''') <- rdL s''' - return (a :| as, s'''')) s - --- | @since 4.10.0.0 -instance Show1 NonEmpty where - liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $ - shwP 6 a . showString " :| " . shwL as - --- | @since 4.9.0.0 -instance Exts.IsList (NonEmpty a) where - type Item (NonEmpty a) = a - fromList = fromList - toList = toList - --- | @since 4.9.0.0 -instance MonadFix NonEmpty where - mfix f = case fix (f . head) of - ~(x :| _) -> x :| mfix (tail . f) - --- | @since 4.9.0.0 -instance MonadZip NonEmpty where - mzip = zip - mzipWith = zipWith - munzip = unzip +infixr 5 <| -- | Number of elements in 'NonEmpty' list. length :: NonEmpty a -> Int @@ -203,37 +152,6 @@ unfoldr f a = case f a of go c = case f c of (d, me) -> d : maybe [] go me --- | @since 4.9.0.0 -instance Functor NonEmpty where - fmap f ~(a :| as) = f a :| fmap f as - b <$ ~(_ :| as) = b :| (b <$ as) - --- | @since 4.9.0.0 -instance Applicative NonEmpty where - pure a = a :| [] - (<*>) = ap - liftA2 = liftM2 - --- | @since 4.9.0.0 -instance Monad NonEmpty where - ~(a :| as) >>= f = b :| (bs ++ bs') - where b :| bs = f a - bs' = as >>= toList . f - --- | @since 4.9.0.0 -instance Traversable NonEmpty where - traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as) - --- | @since 4.9.0.0 -instance Foldable NonEmpty where - foldr f z ~(a :| as) = f a (foldr f z as) - foldl f z ~(a :| as) = foldl f (f z a) as - foldl1 f ~(a :| as) = foldl f a as - foldMap f ~(a :| as) = f a `mappend` foldMap f as - fold ~(m :| ms) = m `mappend` fold ms - length = length - toList = toList - -- | Extract the first element of the stream. head :: NonEmpty a -> a head ~(a :| _) = a @@ -462,7 +380,7 @@ groupWith1 f = groupBy1 ((==) `on` f) groupAllWith1 :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) groupAllWith1 f = groupWith1 f . sortWith f --- | The 'isPrefix' function returns @True@ if the first argument is +-- | The 'isPrefixOf' function returns 'True' if the first argument is -- a prefix of the second. isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool isPrefixOf [] _ = True diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs index d8aad53b9e..d41ae92672 100644 --- a/libraries/base/Data/Maybe.hs +++ b/libraries/base/Data/Maybe.hs @@ -55,7 +55,7 @@ import GHC.Base -- >>> maybe False odd Nothing -- False -- --- Read an integer from a string using 'readMaybe'. If we succeed, +-- Read an integer from a string using 'Text.Read.readMaybe'. If we succeed, -- return twice the integer; that is, apply @(*2)@ to it. If instead -- we fail to parse an integer, return @0@ by default: -- @@ -65,7 +65,7 @@ import GHC.Base -- >>> maybe 0 (*2) (readMaybe "") -- 0 -- --- Apply 'show' to a @Maybe Int@. If we have @Just n@, we want to show +-- Apply 'Prelude.show' to a @Maybe Int@. If we have @Just n@, we want to show -- the underlying 'Int' @n@. But if we have 'Nothing', we return the -- empty string instead of (for example) \"Nothing\": -- @@ -161,7 +161,7 @@ fromJust (Just x) = x -- >>> fromMaybe "" Nothing -- "" -- --- Read an integer from a string using 'readMaybe'. If we fail to +-- Read an integer from a string using 'Text.Read.readMaybe'. If we fail to -- parse an integer, we want to return @0@ by default: -- -- >>> import Text.Read ( readMaybe ) @@ -228,9 +228,12 @@ maybeToList (Just x) = [x] -- >>> maybeToList $ listToMaybe [1,2,3] -- [1] -- -listToMaybe :: [a] -> Maybe a -listToMaybe [] = Nothing -listToMaybe (a:_) = Just a +listToMaybe :: [a] -> Maybe a +listToMaybe = foldr (const . Just) Nothing +{-# INLINE listToMaybe #-} +-- We define listToMaybe using foldr so that it can fuse via the foldr/build +-- rule. See #14387 + -- | The 'catMaybes' function takes a list of 'Maybe's and returns -- a list of all the 'Just' values. diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index 6ccdb34045..cf55b2150c 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | @@ -16,8 +16,43 @@ -- Stability : experimental -- Portability : portable -- --- A class for monoids (types with an associative binary operation that --- has an identity) with various general-purpose instances. +-- A type @a@ is a 'Monoid' if it provides an associative function ('<>') +-- that lets you combine any two values of type @a@ into one, and a neutral +-- element (`mempty`) such that +-- +-- > a <> mempty == mempty <> a == a +-- +-- A 'Monoid' is a 'Semigroup' with the added requirement of a neutral element. +-- Thus any 'Monoid' is a 'Semigroup', but not the other way around. +-- +-- ==== __Examples__ +-- +-- The 'Sum' monoid is defined by the numerical addition operator and `0` as neutral element: +-- +-- >>> mempty :: Sum Int +-- Sum 0 +-- >>> Sum 1 <> Sum 2 <> Sum 3 <> Sum 4 :: Sum Int +-- Sum {getSum = 10} +-- +-- We can combine multiple values in a list into a single value using the `mconcat` function. +-- Note that we have to specify the type here since 'Int' is a monoid under several different +-- operations: +-- +-- >>> mconcat [1,2,3,4] :: Sum Int +-- Sum {getSum = 10} +-- >>> mconcat [] :: Sum Int +-- Sum {getSum = 0} +-- +-- Another valid monoid instance of 'Int' is 'Product' It is defined by multiplication +-- and `1` as neutral element: +-- +-- >>> Product 1 <> Product 2 <> Product 3 <> Product 4 :: Product Int +-- Product {getProduct = 24} +-- >>> mconcat [1,2,3,4] :: Product Int +-- Product {getProduct = 24} +-- >>> mconcat [] :: Product Int +-- Product {getProduct = 1} +-- -- ----------------------------------------------------------------------------- @@ -38,131 +73,25 @@ module Data.Monoid ( First(..), Last(..), -- * 'Alternative' wrapper - Alt (..) + Alt(..), + -- * 'Applicative' wrapper + Ap(..) ) where -- Push down the module in the dependency hierarchy. import GHC.Base hiding (Any) import GHC.Enum +import GHC.Generics import GHC.Num import GHC.Read import GHC.Show -import GHC.Generics - -{- --- just for testing -import Data.Maybe -import Test.QuickCheck --- -} - -infixr 6 <> - --- | An infix synonym for 'mappend'. --- --- @since 4.5.0.0 -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} - --- Monoid instances. - --- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'. -newtype Dual a = Dual { getDual :: a } - deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1) - --- | @since 2.01 -instance Monoid a => Monoid (Dual a) where - mempty = Dual mempty - Dual x `mappend` Dual y = Dual (y `mappend` x) - --- | @since 4.8.0.0 -instance Functor Dual where - fmap = coerce - --- | @since 4.8.0.0 -instance Applicative Dual where - pure = Dual - (<*>) = coerce - --- | @since 4.8.0.0 -instance Monad Dual where - m >>= k = k (getDual m) - --- | The monoid of endomorphisms under composition. -newtype Endo a = Endo { appEndo :: a -> a } - deriving (Generic) - --- | @since 2.01 -instance Monoid (Endo a) where - mempty = Endo id - Endo f `mappend` Endo g = Endo (f . g) - --- | Boolean monoid under conjunction ('&&'). -newtype All = All { getAll :: Bool } - deriving (Eq, Ord, Read, Show, Bounded, Generic) - --- | @since 2.01 -instance Monoid All where - mempty = All True - All x `mappend` All y = All (x && y) - --- | Boolean monoid under disjunction ('||'). -newtype Any = Any { getAny :: Bool } - deriving (Eq, Ord, Read, Show, Bounded, Generic) - --- | @since 2.01 -instance Monoid Any where - mempty = Any False - Any x `mappend` Any y = Any (x || y) --- | Monoid under addition. -newtype Sum a = Sum { getSum :: a } - deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) +import Control.Monad.Fail (MonadFail) --- | @since 2.01 -instance Num a => Monoid (Sum a) where - mempty = Sum 0 - mappend = coerce ((+) :: a -> a -> a) --- Sum x `mappend` Sum y = Sum (x + y) - --- | @since 4.8.0.0 -instance Functor Sum where - fmap = coerce - --- | @since 4.8.0.0 -instance Applicative Sum where - pure = Sum - (<*>) = coerce - --- | @since 4.8.0.0 -instance Monad Sum where - m >>= k = k (getSum m) - --- | Monoid under multiplication. -newtype Product a = Product { getProduct :: a } - deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num) - --- | @since 2.01 -instance Num a => Monoid (Product a) where - mempty = Product 1 - mappend = coerce ((*) :: a -> a -> a) --- Product x `mappend` Product y = Product (x * y) - --- | @since 4.8.0.0 -instance Functor Product where - fmap = coerce - --- | @since 4.8.0.0 -instance Applicative Product where - pure = Product - (<*>) = coerce - --- | @since 4.8.0.0 -instance Monad Product where - m >>= k = k (getProduct m) +import Data.Semigroup.Internal -- $MaybeExamples --- To implement @find@ or @findLast@ on any 'Foldable': +-- To implement @find@ or @findLast@ on any 'Data.Foldable.Foldable': -- -- @ -- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a @@ -171,20 +100,20 @@ instance Monad Product where -- else Last Nothing) -- @ -- --- Much of Data.Map's interface can be implemented with --- Data.Map.alter. Some of the rest can be implemented with a new --- @alterA@ function and either 'First' or 'Last': +-- Much of 'Data.Map.Lazy.Map's interface can be implemented with +-- 'Data.Map.Lazy.alter'. Some of the rest can be implemented with a new +-- 'Data.Map.Lazy.alterF' function and either 'First' or 'Last': -- --- > alterA :: (Applicative f, Ord k) => +-- > alterF :: (Functor f, Ord k) => -- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) -- > --- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative +-- > instance Monoid a => Functor ((,) a) -- from Data.Functor -- -- @ -- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v -- -> Map k v -> (Maybe v, Map k v) -- insertLookupWithKey combine key value = --- Arrow.first getFirst . alterA doChange key +-- Arrow.first getFirst . 'Data.Map.Lazy.alterF' doChange key -- where -- doChange Nothing = (First Nothing, Just value) -- doChange (Just oldValue) = @@ -197,41 +126,121 @@ instance Monad Product where -- -- @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it -- historically. +-- +-- >>> getFirst (First (Just "hello") <> First Nothing <> First (Just "world")) +-- Just "hello" +-- +-- Use of this type is discouraged. Note the following equivalence: +-- +-- > Data.Monoid.First x === Maybe (Data.Semigroup.First x) +-- +-- In addition to being equivalent in the structural sense, the two +-- also have 'Monoid' instances that behave the same. This type will +-- be marked deprecated in GHC 8.8, and removed in GHC 8.10. +-- Users are advised to use the variant from "Data.Semigroup" and wrap +-- it in 'Maybe'. newtype First a = First { getFirst :: Maybe a } - deriving (Eq, Ord, Read, Show, Generic, Generic1, - Functor, Applicative, Monad) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + ) + +-- | @since 4.9.0.0 +instance Semigroup (First a) where + First Nothing <> b = b + a <> _ = a + stimes = stimesIdempotentMonoid -- | @since 2.01 instance Monoid (First a) where mempty = First Nothing - First Nothing `mappend` r = r - l `mappend` _ = l -- | Maybe monoid returning the rightmost non-Nothing value. -- -- @'Last' a@ is isomorphic to @'Dual' ('First' a)@, and thus to -- @'Dual' ('Alt' 'Maybe' a)@ +-- +-- >>> getLast (Last (Just "hello") <> Last Nothing <> Last (Just "world")) +-- Just "world" +-- +-- Use of this type is discouraged. Note the following equivalence: +-- +-- > Data.Monoid.Last x === Maybe (Data.Semigroup.Last x) +-- +-- In addition to being equivalent in the structural sense, the two +-- also have 'Monoid' instances that behave the same. This type will +-- be marked deprecated in GHC 8.8, and removed in GHC 8.10. +-- Users are advised to use the variant from "Data.Semigroup" and wrap +-- it in 'Maybe'. newtype Last a = Last { getLast :: Maybe a } - deriving (Eq, Ord, Read, Show, Generic, Generic1, - Functor, Applicative, Monad) + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Functor -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + ) + +-- | @since 4.9.0.0 +instance Semigroup (Last a) where + a <> Last Nothing = a + _ <> b = b + stimes = stimesIdempotentMonoid -- | @since 2.01 instance Monoid (Last a) where mempty = Last Nothing - l `mappend` Last Nothing = l - _ `mappend` r = r --- | Monoid under '<|>'. +-- | This data type witnesses the lifting of a 'Monoid' into an +-- 'Applicative' pointwise. -- --- @since 4.8.0.0 -newtype Alt f a = Alt {getAlt :: f a} - deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum, - Monad, MonadPlus, Applicative, Alternative, Functor) - --- | @since 4.8.0.0 -instance Alternative f => Monoid (Alt f a) where - mempty = Alt empty - mappend = coerce ((<|>) :: f a -> f a -> f a) +-- @since 4.12.0.0 +newtype Ap f a = Ap { getAp :: f a } + deriving ( Alternative -- ^ @since 4.12.0.0 + , Applicative -- ^ @since 4.12.0.0 + , Enum -- ^ @since 4.12.0.0 + , Eq -- ^ @since 4.12.0.0 + , Functor -- ^ @since 4.12.0.0 + , Generic -- ^ @since 4.12.0.0 + , Generic1 -- ^ @since 4.12.0.0 + , Monad -- ^ @since 4.12.0.0 + , MonadFail -- ^ @since 4.12.0.0 + , MonadPlus -- ^ @since 4.12.0.0 + , Ord -- ^ @since 4.12.0.0 + , Read -- ^ @since 4.12.0.0 + , Show -- ^ @since 4.12.0.0 + ) + +-- | @since 4.12.0.0 +instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where + (Ap x) <> (Ap y) = Ap $ liftA2 (<>) x y + +-- | @since 4.12.0.0 +instance (Applicative f, Monoid a) => Monoid (Ap f a) where + mempty = Ap $ pure mempty + +-- | @since 4.12.0.0 +instance (Applicative f, Bounded a) => Bounded (Ap f a) where + minBound = pure minBound + maxBound = pure maxBound + +-- | @since 4.12.0.0 +instance (Applicative f, Num a) => Num (Ap f a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum {- {-------------------------------------------------------------------- @@ -253,3 +262,6 @@ prop_mconcatLast x = where listLastToMaybe [] = Nothing listLastToMaybe lst = Just (last lst) -- -} + +-- $setup +-- >>> import Prelude diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs index bee1b6f98a..ee2dfac982 100644 --- a/libraries/base/Data/OldList.hs +++ b/libraries/base/Data/OldList.hs @@ -77,6 +77,7 @@ module Data.OldList -- ** Infinite lists , iterate + , iterate' , repeat , replicate , cycle @@ -228,8 +229,12 @@ infix 5 \\ -- comment to fool cpp: https://www.haskell.org/ghc/docs/latest/html/ -- | The 'dropWhileEnd' function drops the largest suffix of a list -- in which the given predicate holds for all elements. For example: -- --- > dropWhileEnd isSpace "foo\n" == "foo" --- > dropWhileEnd isSpace "foo bar" == "foo bar" +-- >>> dropWhileEnd isSpace "foo\n" +-- "foo" +-- +-- >>> dropWhileEnd isSpace "foo bar" +-- "foo bar" +-- -- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined -- -- @since 4.5.0.0 @@ -240,10 +245,17 @@ dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] -- It returns 'Nothing' if the list did not start with the prefix -- given, or 'Just' the list after the prefix, if it does. -- --- > stripPrefix "foo" "foobar" == Just "bar" --- > stripPrefix "foo" "foo" == Just "" --- > stripPrefix "foo" "barfoo" == Nothing --- > stripPrefix "foo" "barfoobaz" == Nothing +-- >>> stripPrefix "foo" "foobar" +-- Just "bar" +-- +-- >>> stripPrefix "foo" "foo" +-- Just "" +-- +-- >>> stripPrefix "foo" "barfoo" +-- Nothing +-- +-- >>> stripPrefix "foo" "barfoobaz" +-- Nothing stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] stripPrefix [] ys = Just ys stripPrefix (x:xs) (y:ys) @@ -253,34 +265,54 @@ stripPrefix _ _ = Nothing -- | The 'elemIndex' function returns the index of the first element -- in the given list which is equal (by '==') to the query element, -- or 'Nothing' if there is no such element. +-- +-- >>> elemIndex 4 [0..] +-- Just 4 elemIndex :: Eq a => a -> [a] -> Maybe Int elemIndex x = findIndex (x==) -- | The 'elemIndices' function extends 'elemIndex', by returning the -- indices of all elements equal to the query element, in ascending order. +-- +-- >>> elemIndices 'o' "Hello World" +-- [4,7] elemIndices :: Eq a => a -> [a] -> [Int] elemIndices x = findIndices (x==) -- | The 'find' function takes a predicate and a list and returns the -- first element in the list matching the predicate, or 'Nothing' if -- there is no such element. +-- +-- >>> find (> 4) [1..] +-- Just 5 +-- +-- >>> find (< 0) [1..10] +-- Nothing find :: (a -> Bool) -> [a] -> Maybe a find p = listToMaybe . filter p -- | The 'findIndex' function takes a predicate and a list and returns -- the index of the first element in the list satisfying the predicate, -- or 'Nothing' if there is no such element. +-- +-- >>> findIndex isSpace "Hello World!" +-- Just 5 findIndex :: (a -> Bool) -> [a] -> Maybe Int findIndex p = listToMaybe . findIndices p -- | The 'findIndices' function extends 'findIndex', by returning the -- indices of all elements satisfying the predicate, in ascending order. +-- +-- >>> findIndices (`elem` "aeiou") "Hello World!" +-- [1,4,7] findIndices :: (a -> Bool) -> [a] -> [Int] #if defined(USE_REPORT_PRELUDE) findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] #else -- Efficient definition, adapted from Data.Sequence -{-# INLINE findIndices #-} +-- (Note that making this INLINABLE instead of INLINE allows +-- 'findIndex' to fuse, fixing #15426.) +{-# INLINABLE findIndices #-} findIndices p ls = build $ \c n -> let go x r k | p x = I# k `c` r (k +# 1#) | otherwise = r (k +# 1#) @@ -289,6 +321,12 @@ findIndices p ls = build $ \c n -> -- | The 'isPrefixOf' function takes two lists and returns 'True' -- iff the first list is a prefix of the second. +-- +-- >>> "Hello" `isPrefixOf` "Hello World!" +-- True +-- +-- >>> "Hello" `isPrefixOf` "Wello Horld!" +-- False isPrefixOf :: (Eq a) => [a] -> [a] -> Bool isPrefixOf [] _ = True isPrefixOf _ [] = False @@ -297,6 +335,12 @@ isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys -- | The 'isSuffixOf' function takes two lists and returns 'True' iff -- the first list is a suffix of the second. The second list must be -- finite. +-- +-- >>> "ld!" `isSuffixOf` "Hello World!" +-- True +-- +-- >>> "World" `isSuffixOf` "Hello World!" +-- False isSuffixOf :: (Eq a) => [a] -> [a] -> Bool ns `isSuffixOf` hs = maybe False id $ do delta <- dropLengthMaybe ns hs @@ -311,6 +355,12 @@ ns `isSuffixOf` hs = maybe False id $ do -- entirety. dropLength is also generally faster than (drop . length) -- Both this and dropLengthMaybe could be written as folds over their first -- arguments, but this reduces clarity with no benefit to isSuffixOf. +-- +-- >>> dropLength "Hello" "Holla world" +-- " world" +-- +-- >>> dropLength [1..] [1,2,3] +-- [] dropLength :: [a] -> [b] -> [b] dropLength [] y = y dropLength _ [] = [] @@ -318,6 +368,9 @@ dropLength (_:x') (_:y') = dropLength x' y' -- A version of dropLength that returns Nothing if the second list runs out of -- elements before the first. +-- +-- >>> dropLengthMaybe [1..] [1,2,3] +-- Nothing dropLengthMaybe :: [a] -> [b] -> Maybe [b] dropLengthMaybe [] y = Just y dropLengthMaybe _ [] = Nothing @@ -327,10 +380,11 @@ dropLengthMaybe (_:x') (_:y') = dropLengthMaybe x' y' -- iff the first list is contained, wholly and intact, -- anywhere within the second. -- --- Example: +-- >>> isInfixOf "Haskell" "I really like Haskell." +-- True -- --- >isInfixOf "Haskell" "I really like Haskell." == True --- >isInfixOf "Ial" "I really like Haskell." == False +-- >>> isInfixOf "Ial" "I really like Haskell." +-- False isInfixOf :: (Eq a) => [a] -> [a] -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) @@ -339,12 +393,18 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- (The name 'nub' means \`essence\'.) -- It is a special case of 'nubBy', which allows the programmer to supply -- their own equality test. +-- +-- >>> nub [1,2,3,4,3,2,1,2,4,3,5] +-- [1,2,3,4,5] nub :: (Eq a) => [a] -> [a] nub = nubBy (==) -- | The 'nubBy' function behaves just like 'nub', except it uses a -- user-supplied equality predicate instead of the overloaded '==' -- function. +-- +-- >>> nubBy (\x y -> mod x 3 == mod y 3) [1,2,4,5,6] +-- [1,2,6] nubBy :: (a -> a -> Bool) -> [a] -> [a] #if defined(USE_REPORT_PRELUDE) nubBy eq [] = [] @@ -374,16 +434,19 @@ elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs -- | 'delete' @x@ removes the first occurrence of @x@ from its list argument. -- For example, -- --- > delete 'a' "banana" == "bnana" +-- >>> delete 'a' "banana" +-- "bnana" -- -- It is a special case of 'deleteBy', which allows the programmer to -- supply their own equality test. - delete :: (Eq a) => a -> [a] -> [a] delete = deleteBy (==) -- | The 'deleteBy' function behaves like 'delete', but takes a -- user-supplied equality predicate. +-- +-- >>> deleteBy (<=) 4 [1..10] +-- [1,2,3,5,6,7,8,9,10] deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] deleteBy _ _ [] = [] deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys @@ -394,6 +457,9 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- -- > (xs ++ ys) \\ xs == ys. -- +-- >>> "Hello World!" \\ "ell W" +-- "Hoorld!" +-- -- It is a special case of 'deleteFirstsBy', which allows the programmer -- to supply their own equality test. @@ -403,7 +469,8 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- | The 'union' function returns the list union of the two lists. -- For example, -- --- > "dog" `union` "cow" == "dogcw" +-- >>> "dog" `union` "cow" +-- "dogcw" -- -- Duplicates, and elements of the first list, are removed from the -- the second list, but if the first list contains duplicates, so will @@ -421,11 +488,13 @@ unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs -- | The 'intersect' function takes the list intersection of two lists. -- For example, -- --- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4] +-- >>> [1,2,3,4] `intersect` [2,4,6,8] +-- [2,4] -- -- If the first list contains duplicates, so will the result. -- --- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4] +-- >>> [1,2,2,3,4] `intersect` [6,4,4,2] +-- [2,2,4] -- -- It is a special case of 'intersectBy', which allows the programmer to -- supply their own equality test. If the element is found in both the first @@ -444,8 +513,8 @@ intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -- \`intersperses\' that element between the elements of the list. -- For example, -- --- > intersperse ',' "abcde" == "a,b,c,d,e" - +-- >>> intersperse ',' "abcde" +-- "a,b,c,d,e" intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse sep (x:xs) = x : prependToAll sep xs @@ -462,18 +531,22 @@ prependToAll sep (x:xs) = sep : x : prependToAll sep xs -- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the -- result. +-- +-- >>> intercalate ", " ["Lorem", "ipsum", "dolor"] +-- "Lorem, ipsum, dolor" intercalate :: [a] -> [[a]] -> [a] intercalate xs xss = concat (intersperse xs xss) -- | The 'transpose' function transposes the rows and columns of its argument. -- For example, -- --- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]] +-- >>> transpose [[1,2,3],[4,5,6]] +-- [[1,4],[2,5],[3,6]] -- -- If some of the rows are shorter than the following rows, their elements are skipped: -- --- > transpose [[10,11],[20],[],[30,31,32]] == [[10,20,30],[11,31],[32]] - +-- >>> transpose [[10,11],[20],[],[30,31,32]] +-- [[10,20,30],[11,31],[32]] transpose :: [[a]] -> [[a]] transpose [] = [] transpose ([] : xss) = transpose xss @@ -485,7 +558,9 @@ transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t -- predicate, respectively; i.e., -- -- > partition p xs == (filter p xs, filter (not . p) xs) - +-- +-- >>> partition (`elem` "aeiou") "Hello World!" +-- ("eoo","Hll Wrld!") partition :: (a -> Bool) -> [a] -> ([a],[a]) {-# INLINE partition #-} partition p xs = foldr (select p) ([],[]) xs @@ -549,6 +624,9 @@ mapAccumR f s (x:xs) = (s'', y:ys) -- is sorted before the call, the result will also be sorted. -- It is a special case of 'insertBy', which allows the programmer to -- supply their own comparison function. +-- +-- >>> insert 4 [1,2,3,5,6,7] +-- [1,2,3,4,5,6,7] insert :: Ord a => a -> [a] -> [a] insert e ls = insertBy (compare) e ls @@ -563,6 +641,11 @@ insertBy cmp x ys@(y:ys') -- | The 'maximumBy' function takes a comparison function and a list -- and returns the greatest element of the list by the comparison function. -- The list must be finite and non-empty. +-- +-- We can use this to find the longest entry of a list: +-- +-- >>> maximumBy (\x y -> compare (length x) (length y)) ["Hello", "World", "!", "Longest", "bar"] +-- "Longest" maximumBy :: (a -> a -> Ordering) -> [a] -> a maximumBy _ [] = errorWithoutStackTrace "List.maximumBy: empty list" maximumBy cmp xs = foldl1 maxBy xs @@ -574,6 +657,11 @@ maximumBy cmp xs = foldl1 maxBy xs -- | The 'minimumBy' function takes a comparison function and a list -- and returns the least element of the list by the comparison function. -- The list must be finite and non-empty. +-- +-- We can use this to find the shortest entry of a list: +-- +-- >>> minimumBy (\x y -> compare (length x) (length y)) ["Hello", "World", "!", "Longest", "bar"] +-- "!" minimumBy :: (a -> a -> Ordering) -> [a] -> a minimumBy _ [] = errorWithoutStackTrace "List.minimumBy: empty list" minimumBy cmp xs = foldl1 minBy xs @@ -734,7 +822,8 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- that the concatenation of the result is equal to the argument. Moreover, -- each sublist in the result contains only equal elements. For example, -- --- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- >>> group "Mississippi" +-- ["M","i","ss","i","ss","i","pp","i"] -- -- It is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. @@ -750,7 +839,8 @@ groupBy eq (x:xs) = (x:ys) : groupBy eq zs -- | The 'inits' function returns all initial segments of the argument, -- shortest first. For example, -- --- > inits "abc" == ["","a","ab","abc"] +-- >>> inits "abc" +-- ["","a","ab","abc"] -- -- Note that 'inits' has the following strictness property: -- @inits (xs ++ _|_) = inits xs ++ _|_@ @@ -768,7 +858,8 @@ inits = map toListSB . scanl' snocSB emptySB -- | The 'tails' function returns all final segments of the argument, -- longest first. For example, -- --- > tails "abc" == ["abc", "bc", "c",""] +-- >>> tails "abc" +-- ["abc","bc","c",""] -- -- Note that 'tails' has the following strictness property: -- @tails _|_ = _|_ : _|_@ @@ -782,14 +873,16 @@ tails lst = build (\c n -> -- | The 'subsequences' function returns the list of all subsequences of the argument. -- --- > subsequences "abc" == ["","a","b","ab","c","ac","bc","abc"] +-- >>> subsequences "abc" +-- ["","a","b","ab","c","ac","bc","abc"] subsequences :: [a] -> [[a]] subsequences xs = [] : nonEmptySubsequences xs -- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument, -- except for the empty list. -- --- > nonEmptySubsequences "abc" == ["a","b","ab","c","ac","bc","abc"] +-- >>> nonEmptySubsequences "abc" +-- ["a","b","ab","c","ac","bc","abc"] nonEmptySubsequences :: [a] -> [[a]] nonEmptySubsequences [] = [] nonEmptySubsequences (x:xs) = [x] : foldr f [] (nonEmptySubsequences xs) @@ -798,7 +891,8 @@ nonEmptySubsequences (x:xs) = [x] : foldr f [] (nonEmptySubsequences xs) -- | The 'permutations' function returns the list of all permutations of the argument. -- --- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"] +-- >>> permutations "abc" +-- ["abc","bac","cba","bca","cab","acb"] permutations :: [a] -> [[a]] permutations xs0 = xs0 : perms xs0 [] where @@ -819,9 +913,15 @@ permutations xs0 = xs0 : perms xs0 [] -- -- Elements are arranged from from lowest to highest, keeping duplicates in -- the order they appeared in the input. +-- +-- >>> sort [1,6,4,3,2,5] +-- [1,2,3,4,5,6] sort :: (Ord a) => [a] -> [a] -- | The 'sortBy' function is the non-overloaded version of 'sort'. +-- +-- >>> sortBy (\(a,_) (b,_) -> compare a b) [(2, "world"), (4, "!"), (1, "Hello")] +-- [(1,"Hello"),(2,"world"),(4,"!")] sortBy :: (a -> a -> Ordering) -> [a] -> [a] #if defined(USE_REPORT_PRELUDE) @@ -987,6 +1087,9 @@ rqpart cmp x (y:ys) rle rgt r = -- Elements are arranged from from lowest to highest, keeping duplicates in -- the order they appeared in the input. -- +-- >>> sortOn fst [(2, "world"), (4, "!"), (1, "Hello")] +-- [(1,"Hello"),(2,"world"),(4,"!")] +-- -- @since 4.8.0.0 sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f = @@ -1012,8 +1115,8 @@ sortOn f = -- -- A simple use of unfoldr: -- --- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10 --- > [10,9,8,7,6,5,4,3,2,1] +-- >>> unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10 +-- [10,9,8,7,6,5,4,3,2,1] -- -- Note [INLINE unfoldr] @@ -1058,13 +1161,26 @@ unfoldr f b0 = build (\c n -> -- last part of the string is considered a line even if it doesn't end -- with a newline. For example, -- --- > lines "" == [] --- > lines "\n" == [""] --- > lines "one" == ["one"] --- > lines "one\n" == ["one"] --- > lines "one\n\n" == ["one",""] --- > lines "one\ntwo" == ["one","two"] --- > lines "one\ntwo\n" == ["one","two"] +-- >>> lines "" +-- [] +-- +-- >>> lines "\n" +-- [""] +-- +-- >>> lines "one" +-- ["one"] +-- +-- >>> lines "one\n" +-- ["one"] +-- +-- >>> lines "one\n\n" +-- ["one",""] +-- +-- >>> lines "one\ntwo" +-- ["one","two"] +-- +-- >>> lines "one\ntwo\n" +-- ["one","two"] -- -- Thus @'lines' s@ contains at least as many elements as newlines in @s@. lines :: String -> [String] @@ -1082,6 +1198,9 @@ lines s = cons (case break (== '\n') s of -- | 'unlines' is an inverse operation to 'lines'. -- It joins lines, after appending a terminating newline to each. +-- +-- >>> unlines ["Hello", "World", "!"] +-- "Hello\nWorld\n!\n" unlines :: [String] -> String #if defined(USE_REPORT_PRELUDE) unlines = concatMap (++ "\n") @@ -1094,6 +1213,9 @@ unlines (l:ls) = l ++ '\n' : unlines ls -- | 'words' breaks a string up into a list of words, which were delimited -- by white space. +-- +-- >>> words "Lorem ipsum\ndolor" +-- ["Lorem","ipsum","dolor"] words :: String -> [String] {-# NOINLINE [1] words #-} words s = case dropWhile {-partain:Char.-}isSpace s of @@ -1117,6 +1239,9 @@ wordsFB c n = go -- | 'unwords' is an inverse operation to 'words'. -- It joins words with separating spaces. +-- +-- >>> unwords ["Lorem", "ipsum", "dolor"] +-- "Lorem ipsum dolor" unwords :: [String] -> String #if defined(USE_REPORT_PRELUDE) unwords [] = "" diff --git a/libraries/base/Data/Ord.hs b/libraries/base/Data/Ord.hs index 11d6967134..c6b7e59543 100644 --- a/libraries/base/Data/Ord.hs +++ b/libraries/base/Data/Ord.hs @@ -48,11 +48,12 @@ comparing p x y = compare (p x) (p y) -- @since 4.6.0.0 newtype Down a = Down a deriving - ( Eq - , Show -- ^ @since 4.7.0.0 - , Read -- ^ @since 4.7.0.0 - , Num -- ^ @since 4.11.0.0 - , Monoid -- ^ @since 4.11.0.0 + ( Eq -- ^ @since 4.6.0.0 + , Show -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.11.0.0 + , Semigroup -- ^ @since 4.11.0.0 + , Monoid -- ^ @since 4.11.0.0 ) -- | @since 4.6.0.0 diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index d6f03548f3..557cc1e4dd 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -28,12 +28,38 @@ import GHC.Read import GHC.Enum import GHC.Arr --- | A concrete, poly-kinded proxy type -data Proxy t = Proxy deriving Bounded +-- $setup +-- >>> import Data.Void +-- >>> import Prelude + +-- | 'Proxy' is a type that holds no data, but has a phantom parameter of +-- arbitrary type (or even kind). Its use is to provide type information, even +-- though there is no value available of that type (or it may be too costly to +-- create one). +-- +-- Historically, @'Proxy' :: 'Proxy' a@ is a safer alternative to the +-- @'undefined :: a'@ idiom. +-- +-- >>> Proxy :: Proxy (Void, Int -> Int) +-- Proxy +-- +-- Proxy can even hold types of higher kinds, +-- +-- >>> Proxy :: Proxy Either +-- Proxy +-- +-- >>> Proxy :: Proxy Functor +-- Proxy +-- +-- >>> Proxy :: Proxy complicatedStructure +-- Proxy +data Proxy t = Proxy deriving ( Bounded -- ^ @since 4.7.0.0 + , Read -- ^ @since 4.7.0.0 + ) -- | A concrete, promotable proxy type, for use at the kind level -- There are no instances for this because it is intended at the kind level only -data KProxy (t :: *) = KProxy +data KProxy (t :: Type) = KProxy -- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t) -- interchangeably, so all of these instances are hand-written to be @@ -52,10 +78,6 @@ instance Show (Proxy s) where showsPrec _ _ = showString "Proxy" -- | @since 4.7.0.0 -instance Read (Proxy s) where - readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) - --- | @since 4.7.0.0 instance Enum (Proxy s) where succ _ = errorWithoutStackTrace "Proxy.succ" pred _ = errorWithoutStackTrace "Proxy.pred" @@ -76,10 +98,15 @@ instance Ix (Proxy s) where unsafeIndex _ _ = 0 unsafeRangeSize _ = 1 +-- | @since 4.9.0.0 +instance Semigroup (Proxy s) where + _ <> _ = Proxy + sconcat _ = Proxy + stimes _ _ = Proxy + -- | @since 4.7.0.0 instance Monoid (Proxy s) where mempty = Proxy - mappend _ _ = Proxy mconcat _ = Proxy -- | @since 4.7.0.0 @@ -113,6 +140,19 @@ instance MonadPlus Proxy -- It is usually used as an infix operator, and its typing forces its first -- argument (which is usually overloaded) to have the same type as the tag -- of the second. +-- +-- >>> import Data.Word +-- >>> :type asProxyTypeOf 123 (Proxy :: Proxy Word8) +-- asProxyTypeOf 123 (Proxy :: Proxy Word8) :: Word8 +-- +-- Note the lower-case @proxy@ in the definition. This allows any type +-- constructor with just one argument to be passed to the function, for example +-- we could also write +-- +-- >>> import Data.Word +-- >>> :type asProxyTypeOf 123 (Just (undefined :: Word8)) +-- asProxyTypeOf 123 (Just (undefined :: Word8)) :: Word8 asProxyTypeOf :: a -> proxy a -> a asProxyTypeOf = const {-# INLINE asProxyTypeOf #-} + diff --git a/libraries/base/Data/Ratio.hs b/libraries/base/Data/Ratio.hs index 8517e485ff..946824fec2 100644 --- a/libraries/base/Data/Ratio.hs +++ b/libraries/base/Data/Ratio.hs @@ -47,27 +47,32 @@ import GHC.Real -- The basic defns for Ratio -- and abs r' < d', and the simplest rational is q%1 + the reciprocal of -- the simplest rational between d'%r' and d%r. -approxRational :: (RealFrac a) => a -> a -> Rational -approxRational rat eps = simplest (rat-eps) (rat+eps) - where simplest x y | y < x = simplest y x - | x == y = xr - | x > 0 = simplest' n d n' d' - | y < 0 = - simplest' (-n') d' (-n) d - | otherwise = 0 :% 1 - where xr = toRational x - n = numerator xr - d = denominator xr - nd' = toRational y - n' = numerator nd' - d' = denominator nd' +approxRational :: (RealFrac a) => a -> a -> Rational +approxRational rat eps = + -- We convert rat and eps to rational *before* subtracting/adding since + -- otherwise we may overflow. This was the cause of #14425. + simplest (toRational rat - toRational eps) (toRational rat + toRational eps) + where + simplest x y + | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr = toRational x + n = numerator xr + d = denominator xr + nd' = toRational y + n' = numerator nd' + d' = denominator nd' - simplest' n d n' d' -- assumes 0 < n%d < n'%d' - | r == 0 = q :% 1 - | q /= q' = (q+1) :% 1 - | otherwise = (q*n''+d'') :% n'' - where (q,r) = quotRem n d - (q',r') = quotRem n' d' - nd'' = simplest' d' r' d r - n'' = numerator nd'' - d'' = denominator nd'' + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + nd'' = simplest' d' r' d r + n'' = numerator nd'' + d'' = denominator nd'' diff --git a/libraries/base/Data/STRef.hs b/libraries/base/Data/STRef.hs index 60bccf50cb..46ca08361b 100644 --- a/libraries/base/Data/STRef.hs +++ b/libraries/base/Data/STRef.hs @@ -5,7 +5,7 @@ -- Module : Data.STRef -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (uses Control.Monad.ST) @@ -29,16 +29,30 @@ import GHC.STRef -- | Mutate the contents of an 'STRef'. -- +-- >>> :{ +-- runST (do +-- ref <- newSTRef "" +-- modifySTRef ref (const "world") +-- modifySTRef ref (++ "!") +-- modifySTRef ref ("Hello, " ++) +-- readSTRef ref ) +-- :} +-- "Hello, world!" +-- -- Be warned that 'modifySTRef' does not apply the function strictly. This -- means if the program calls 'modifySTRef' many times, but seldomly uses the -- value, thunks will pile up in memory resulting in a space leak. This is a -- common mistake made when using an STRef as a counter. For example, the --- following will leak memory and likely produce a stack overflow: +-- following will leak memory and may produce a stack overflow: -- --- >print $ runST $ do --- > ref <- newSTRef 0 --- > replicateM_ 1000000 $ modifySTRef ref (+1) --- > readSTRef ref +-- >>> import Control.Monad (replicateM_) +-- >>> :{ +-- print (runST (do +-- ref <- newSTRef 0 +-- replicateM_ 1000 $ modifySTRef ref (+1) +-- readSTRef ref )) +-- :} +-- 1000 -- -- To avoid this problem, use 'modifySTRef'' instead. modifySTRef :: STRef s a -> (a -> a) -> ST s () diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index fae207ef97..fad1b206c4 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -19,15 +19,52 @@ -- Stability : provisional -- Portability : portable -- --- In mathematics, a semigroup is an algebraic structure consisting of a --- set together with an associative binary operation. A semigroup --- generalizes a monoid in that there might not exist an identity --- element. It also (originally) generalized a group (a monoid with all --- inverses) to a type where every element did not have to have an inverse, --- thus the name semigroup. +-- A type @a@ is a 'Semigroup' if it provides an associative function ('<>') +-- that lets you combine any two values of type @a@ into one. Where being +-- associative means that the following must always hold: -- --- The use of @(\<\>)@ in this module conflicts with an operator with the same --- name that is being exported by Data.Monoid. However, this package +-- >>> (a <> b) <> c == a <> (b <> c) +-- +-- ==== __Examples__ +-- +-- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller +-- number: +-- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int +-- Min {getMin = 1} +-- +-- If we need to combine multiple values we can use the 'sconcat' function +-- to do so. We need to ensure however that we have at least one value to +-- operate on, since otherwise our result would be undefined. It is for this +-- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that +-- can never be empty: +-- +-- >>> (1 :| []) +-- 1 :| [] -- equivalent to [1] but guaranteed to be non-empty +-- >>> (1 :| [2, 3, 4]) +-- 1 :| [2,3,4] -- equivalent to [1,2,3,4] but guaranteed to be non-empty +-- +-- Equipped with this guaranteed to be non-empty data structure, we can combine +-- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min' +-- and 'Max' instances of 'Int' which pick the smallest, or largest number +-- respectively: +-- +-- >>> sconcat (1 :| [2, 3, 4]) :: Min Int +-- Min {getMin = 1} +-- >>> sconcat (1 :| [2, 3, 4]) :: Max Int +-- Max {getMax = 4} +-- +-- String concatenation is another example of a 'Semigroup' instance: +-- +-- >>> "foo" <> "bar" +-- "foobar" +-- +-- A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid' +-- requires the presence of a neutral element ('mempty') in addition to the associative +-- operator. The requirement for a neutral element prevents many types from being a full Monoid, +-- like "Data.List.NonEmpty.NonEmpty". +-- +-- Note that the use of @(\<\>)@ in this module conflicts with an operator with the same +-- name that is being exported by "Data.Monoid". However, this package -- re-exports (most of) the contents of Data.Monoid, so to use semigroups -- and monoids in the same package just -- @@ -48,7 +85,6 @@ module Data.Semigroup ( , Last(..) , WrappedMonoid(..) -- * Re-exported monoids from Data.Monoid - , Monoid(..) , Dual(..) , Endo(..) , All(..) @@ -69,6 +105,10 @@ module Data.Semigroup ( import Prelude hiding (foldr1) +import GHC.Base (Semigroup(..)) + +import Data.Semigroup.Internal + import Control.Applicative import Control.Monad import Control.Monad.Fix @@ -77,261 +117,30 @@ import Data.Bifunctor import Data.Bitraversable import Data.Coerce import Data.Data -import Data.Functor.Identity -import Data.List.NonEmpty import Data.Monoid (All (..), Any (..), Dual (..), Endo (..), Product (..), Sum (..)) -import Data.Monoid (Alt (..)) -import qualified Data.Monoid as Monoid -import Data.Ord (Down(..)) -import Data.Void -#if !defined(mingw32_HOST_OS) -import GHC.Event (Event, Lifetime) -#endif +-- import qualified Data.Monoid as Monoid import GHC.Generics -infixr 6 <> - --- | The class of semigroups (types with an associative binary operation). --- --- @since 4.9.0.0 -class Semigroup a where - -- | An associative operation. - -- - -- @ - -- (a '<>' b) '<>' c = a '<>' (b '<>' c) - -- @ - -- - -- If @a@ is also a 'Monoid' we further require - -- - -- @ - -- ('<>') = 'mappend' - -- @ - (<>) :: a -> a -> a - - default (<>) :: Monoid a => a -> a -> a - (<>) = mappend - - -- | Reduce a non-empty list with @\<\>@ - -- - -- The default definition should be sufficient, but this can be - -- overridden for efficiency. - -- - sconcat :: NonEmpty a -> a - sconcat (a :| as) = go a as where - go b (c:cs) = b <> go c cs - go b [] = b - - -- | Repeat a value @n@ times. - -- - -- Given that this works on a 'Semigroup' it is allowed to fail if - -- you request 0 or fewer repetitions, and the default definition - -- will do so. - -- - -- By making this a member of the class, idempotent semigroups and monoids can - -- upgrade this to execute in /O(1)/ by picking - -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ - -- respectively. - stimes :: Integral b => b -> a -> a - stimes y0 x0 - | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" - | otherwise = f x0 y0 - where - f x y - | even y = f (x <> x) (y `quot` 2) - | y == 1 = x - | otherwise = g (x <> x) (pred y `quot` 2) x - g x y z - | even y = g (x <> x) (y `quot` 2) z - | y == 1 = x <> z - | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) - -- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. -- May fail to terminate for some values in some semigroups. cycle1 :: Semigroup m => m -> m cycle1 xs = xs' where xs' = xs <> xs' --- | @since 4.9.0.0 -instance Semigroup () where - _ <> _ = () - sconcat _ = () - stimes _ _ = () - --- | @since 4.9.0.0 -instance Semigroup b => Semigroup (a -> b) where - f <> g = \a -> f a <> g a - stimes n f e = stimes n (f e) - --- | @since 4.9.0.0 -instance Semigroup [a] where - (<>) = (++) - stimes n x - | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" - | otherwise = rep n - where - rep 0 = [] - rep i = x ++ rep (i - 1) - --- | @since 4.9.0.0 -instance Semigroup a => Semigroup (Maybe a) where - Nothing <> b = b - a <> Nothing = a - Just a <> Just b = Just (a <> b) - stimes _ Nothing = Nothing - stimes n (Just a) = case compare n 0 of - LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" - EQ -> Nothing - GT -> Just (stimes n a) - --- | @since 4.9.0.0 -instance Semigroup (Either a b) where - Left _ <> b = b - a <> _ = a - stimes = stimesIdempotent - --- | @since 4.9.0.0 -instance (Semigroup a, Semigroup b) => Semigroup (a, b) where - (a,b) <> (a',b') = (a<>a',b<>b') - stimes n (a,b) = (stimes n a, stimes n b) - --- | @since 4.9.0.0 -instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where - (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') - stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) - --- | @since 4.9.0.0 -instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) - => Semigroup (a, b, c, d) where - (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') - stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) - --- | @since 4.9.0.0 -instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) - => Semigroup (a, b, c, d, e) where - (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') - stimes n (a,b,c,d,e) = - (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) - --- | @since 4.9.0.0 -instance Semigroup Ordering where - LT <> _ = LT - EQ <> y = y - GT <> _ = GT - stimes = stimesIdempotentMonoid - --- | @since 4.9.0.0 -instance Semigroup a => Semigroup (Dual a) where - Dual a <> Dual b = Dual (b <> a) - stimes n (Dual a) = Dual (stimes n a) - --- | @since 4.9.0.0 -instance Semigroup (Endo a) where - (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) - stimes = stimesMonoid - --- | @since 4.9.0.0 -instance Semigroup All where - (<>) = coerce (&&) - stimes = stimesIdempotentMonoid - --- | @since 4.9.0.0 -instance Semigroup Any where - (<>) = coerce (||) - stimes = stimesIdempotentMonoid - --- | @since 4.11.0.0 -instance Semigroup a => Semigroup (Down a) where - Down a <> Down b = Down (a <> b) - stimes n (Down a) = Down (stimes n a) - - --- | @since 4.9.0.0 -instance Num a => Semigroup (Sum a) where - (<>) = coerce ((+) :: a -> a -> a) - stimes n (Sum a) = Sum (fromIntegral n * a) - --- | @since 4.9.0.0 -instance Num a => Semigroup (Product a) where - (<>) = coerce ((*) :: a -> a -> a) - stimes n (Product a) = Product (a ^ n) - --- | This is a valid definition of 'stimes' for a 'Monoid'. --- --- Unlike the default definition of 'stimes', it is defined for 0 --- and so it should be preferred where possible. -stimesMonoid :: (Integral b, Monoid a) => b -> a -> a -stimesMonoid n x0 = case compare n 0 of - LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" - EQ -> mempty - GT -> f x0 n - where - f x y - | even y = f (x `mappend` x) (y `quot` 2) - | y == 1 = x - | otherwise = g (x `mappend` x) (pred y `quot` 2) x - g x y z - | even y = g (x `mappend` x) (y `quot` 2) z - | y == 1 = x `mappend` z - | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) - --- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. --- --- When @mappend x x = x@, this definition should be preferred, because it --- works in /O(1)/ rather than /O(log n)/ -stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a -stimesIdempotentMonoid n x = case compare n 0 of - LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" - EQ -> mempty - GT -> x - --- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. --- --- When @x <> x = x@, this definition should be preferred, because it --- works in /O(1)/ rather than /O(log n)/. -stimesIdempotent :: Integral b => b -> a -> a -stimesIdempotent n x - | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" - | otherwise = x - --- | @since 4.9.0.0 -instance Semigroup a => Semigroup (Identity a) where - (<>) = coerce ((<>) :: a -> a -> a) - stimes n (Identity a) = Identity (stimes n a) - --- | @since 4.9.0.0 -instance Semigroup a => Semigroup (Const a b) where - (<>) = coerce ((<>) :: a -> a -> a) - stimes n (Const a) = Const (stimes n a) - --- | @since 4.9.0.0 -instance Semigroup (Monoid.First a) where - Monoid.First Nothing <> b = b - a <> _ = a - stimes = stimesIdempotentMonoid - --- | @since 4.9.0.0 -instance Semigroup (Monoid.Last a) where - a <> Monoid.Last Nothing = a - _ <> b = b - stimes = stimesIdempotentMonoid - --- | @since 4.9.0.0 -instance Alternative f => Semigroup (Alt f a) where - (<>) = coerce ((<|>) :: f a -> f a -> f a) - stimes = stimesMonoid - --- | @since 4.9.0.0 -instance Semigroup Void where - a <> _ = a - stimes = stimesIdempotent - --- | @since 4.9.0.0 -instance Semigroup (NonEmpty a) where - (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) - +-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. +diff :: Semigroup m => m -> Endo m +diff = Endo . (<>) newtype Min a = Min { getMin :: a } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Min a) where @@ -353,7 +162,6 @@ instance Ord a => Semigroup (Min a) where -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Min a) where mempty = maxBound - mappend = (<>) -- | @since 4.9.0.0 instance Functor Min where @@ -395,7 +203,15 @@ instance Num a => Num (Min a) where fromInteger = Min . fromInteger newtype Max a = Max { getMax :: a } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Max a) where @@ -416,7 +232,6 @@ instance Ord a => Semigroup (Max a) where -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Max a) where mempty = minBound - mappend = (<>) -- | @since 4.9.0.0 instance Functor Max where @@ -460,7 +275,12 @@ instance Num a => Num (Max a) where -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be -- placed inside 'Min' and 'Max' to compute an arg min or arg max. data Arg a b = Arg a b deriving - (Show, Read, Data, Generic, Generic1) + ( Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) type ArgMin a b = Min (Arg a b) type ArgMax a b = Max (Arg a b) @@ -497,7 +317,7 @@ instance Bifunctor Arg where -- | @since 4.10.0.0 instance Bifoldable Arg where - bifoldMap f g (Arg a b) = f a `mappend` g b + bifoldMap f g (Arg a b) = f a <> g b -- | @since 4.10.0.0 instance Bitraversable Arg where @@ -505,8 +325,16 @@ instance Bitraversable Arg where -- | Use @'Option' ('First' a)@ to get the behavior of -- 'Data.Monoid.First' from "Data.Monoid". -newtype First a = First { getFirst :: a } deriving - (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) +newtype First a = First { getFirst :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (First a) where @@ -555,8 +383,16 @@ instance MonadFix First where -- | Use @'Option' ('Last' a)@ to get the behavior of -- 'Data.Monoid.Last' from "Data.Monoid" -newtype Last a = Last { getLast :: a } deriving - (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) +newtype Last a = Last { getLast :: a } + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Enum a => Enum (Last a) where @@ -605,8 +441,19 @@ instance MonadFix Last where mfix f = fix (f . getLast) -- | Provide a Semigroup for an arbitrary Monoid. +-- +-- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of +-- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future. newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } - deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Bounded -- ^ @since 4.9.0.0 + , Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Monoid m => Semigroup (WrappedMonoid m) where @@ -615,7 +462,6 @@ instance Monoid m => Semigroup (WrappedMonoid m) where -- | @since 4.9.0.0 instance Monoid m => Monoid (WrappedMonoid m) where mempty = WrapMonoid mempty - mappend = (<>) -- | @since 4.9.0.0 instance Enum a => Enum (WrappedMonoid a) where @@ -646,9 +492,21 @@ mtimesDefault n x -- underlying 'Monoid'. -- -- Ideally, this type would not exist at all and we would just fix the --- 'Monoid' instance of 'Maybe' +-- 'Monoid' instance of 'Maybe'. +-- +-- In GHC 8.4 and higher, the 'Monoid' instance for 'Maybe' has been +-- corrected to lift a 'Semigroup' instance instead of a 'Monoid' +-- instance. Consequently, this type is no longer useful. It will be +-- marked deprecated in GHC 8.8 and removed in GHC 8.10. newtype Option a = Option { getOption :: Maybe a } - deriving (Eq, Ord, Show, Read, Data, Generic, Generic1) + deriving ( Eq -- ^ @since 4.9.0.0 + , Ord -- ^ @since 4.9.0.0 + , Show -- ^ @since 4.9.0.0 + , Read -- ^ @since 4.9.0.0 + , Data -- ^ @since 4.9.0.0 + , Generic -- ^ @since 4.9.0.0 + , Generic1 -- ^ @since 4.9.0.0 + ) -- | @since 4.9.0.0 instance Functor Option where @@ -699,40 +557,15 @@ option n j (Option m) = maybe n j m -- | @since 4.9.0.0 instance Semigroup a => Semigroup (Option a) where (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) - +#if !defined(__HADDOCK_VERSION__) + -- workaround https://github.com/haskell/haddock/issues/680 stimes _ (Option Nothing) = Option Nothing stimes n (Option (Just a)) = case compare n 0 of LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" EQ -> Option Nothing GT -> Option (Just (stimes n a)) +#endif -- | @since 4.9.0.0 instance Semigroup a => Monoid (Option a) where mempty = Option Nothing - mappend = (<>) - --- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. -diff :: Semigroup m => m -> Endo m -diff = Endo . (<>) - --- | @since 4.9.0.0 -instance Semigroup (Proxy s) where - _ <> _ = Proxy - sconcat _ = Proxy - stimes _ _ = Proxy - --- | @since 4.10.0.0 -instance Semigroup a => Semigroup (IO a) where - (<>) = liftA2 (<>) - -#if !defined(mingw32_HOST_OS) --- | @since 4.10.0.0 -instance Semigroup Event where - (<>) = mappend - stimes = stimesMonoid - --- | @since 4.10.0.0 -instance Semigroup Lifetime where - (<>) = mappend - stimes = stimesMonoid -#endif diff --git a/libraries/base/Data/Semigroup/Internal.hs b/libraries/base/Data/Semigroup/Internal.hs new file mode 100644 index 0000000000..7484608c24 --- /dev/null +++ b/libraries/base/Data/Semigroup/Internal.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Auxilary definitions for 'Semigroup' +-- +-- This module provides some @newtype@ wrappers and helpers which are +-- reexported from the "Data.Semigroup" module or imported directly +-- by some other modules. +-- +-- This module also provides internal definitions related to the +-- 'Semigroup' class some. +-- +-- This module exists mostly to simplify or workaround import-graph +-- issues; there is also a .hs-boot file to allow "GHC.Base" and other +-- modules to import method default implementations for 'stimes' +-- +-- @since 4.11.0.0 +module Data.Semigroup.Internal where + +import GHC.Base hiding (Any) +import GHC.Enum +import GHC.Num +import GHC.Read +import GHC.Show +import GHC.Generics +import GHC.Real + +-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. +-- +-- When @x <> x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/. +stimesIdempotent :: Integral b => b -> a -> a +stimesIdempotent n x + | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" + | otherwise = x + +-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. +-- +-- When @mappend x x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/ +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesIdempotentMonoid n x = case compare n 0 of + LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x + +-- | This is a valid definition of 'stimes' for a 'Monoid'. +-- +-- Unlike the default definition of 'stimes', it is defined for 0 +-- and so it should be preferred where possible. +stimesMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesMonoid n x0 = case compare n 0 of + LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" + EQ -> mempty + GT -> f x0 n + where + f x y + | even y = f (x `mappend` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `mappend` x) (y `quot` 2) x -- See Note [Half of y - 1] + g x y z + | even y = g (x `mappend` x) (y `quot` 2) z + | y == 1 = x `mappend` z + | otherwise = g (x `mappend` x) (y `quot` 2) (x `mappend` z) -- See Note [Half of y - 1] + +-- this is used by the class definitionin GHC.Base; +-- it lives here to avoid cycles +stimesDefault :: (Integral b, Semigroup a) => b -> a -> a +stimesDefault y0 x0 + | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | even y = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) (y `quot` 2) x -- See Note [Half of y - 1] + g x y z + | even y = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) (y `quot` 2) (x <> z) -- See Note [Half of y - 1] + +{- Note [Half of y - 1] + ~~~~~~~~~~~~~~~~~~~~~ + Since y is guaranteed to be odd and positive here, + half of y - 1 can be computed as y `quot` 2, optimising subtraction away. +-} + +stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a +stimesMaybe _ Nothing = Nothing +stimesMaybe n (Just a) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" + EQ -> Nothing + GT -> Just (stimes n a) + +stimesList :: Integral b => b -> [a] -> [a] +stimesList n x + | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" + | otherwise = rep n + where + rep 0 = [] + rep i = x ++ rep (i - 1) + +-- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'. +-- +-- >>> getDual (mappend (Dual "Hello") (Dual "World")) +-- "WorldHello" +newtype Dual a = Dual { getDual :: a } + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + ) + +-- | @since 4.9.0.0 +instance Semigroup a => Semigroup (Dual a) where + Dual a <> Dual b = Dual (b <> a) + stimes n (Dual a) = Dual (stimes n a) + +-- | @since 2.01 +instance Monoid a => Monoid (Dual a) where + mempty = Dual mempty + +-- | @since 4.8.0.0 +instance Functor Dual where + fmap = coerce + +-- | @since 4.8.0.0 +instance Applicative Dual where + pure = Dual + (<*>) = coerce + +-- | @since 4.8.0.0 +instance Monad Dual where + m >>= k = k (getDual m) + +-- | The monoid of endomorphisms under composition. +-- +-- >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!") +-- >>> appEndo computation "Haskell" +-- "Hello, Haskell!" +newtype Endo a = Endo { appEndo :: a -> a } + deriving ( Generic -- ^ @since 4.7.0.0 + ) + +-- | @since 4.9.0.0 +instance Semigroup (Endo a) where + (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) + stimes = stimesMonoid + +-- | @since 2.01 +instance Monoid (Endo a) where + mempty = Endo id + +-- | Boolean monoid under conjunction ('&&'). +-- +-- >>> getAll (All True <> mempty <> All False) +-- False +-- +-- >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8])) +-- False +newtype All = All { getAll :: Bool } + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + ) + +-- | @since 4.9.0.0 +instance Semigroup All where + (<>) = coerce (&&) + stimes = stimesIdempotentMonoid + +-- | @since 2.01 +instance Monoid All where + mempty = All True + +-- | Boolean monoid under disjunction ('||'). +-- +-- >>> getAny (Any True <> mempty <> Any False) +-- True +-- +-- >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8])) +-- True +newtype Any = Any { getAny :: Bool } + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + ) + +-- | @since 4.9.0.0 +instance Semigroup Any where + (<>) = coerce (||) + stimes = stimesIdempotentMonoid + +-- | @since 2.01 +instance Monoid Any where + mempty = Any False + +-- | Monoid under addition. +-- +-- >>> getSum (Sum 1 <> Sum 2 <> mempty) +-- 3 +newtype Sum a = Sum { getSum :: a } + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.7.0.0 + ) + +-- | @since 4.9.0.0 +instance Num a => Semigroup (Sum a) where + (<>) = coerce ((+) :: a -> a -> a) + stimes n (Sum a) = Sum (fromIntegral n * a) + +-- | @since 2.01 +instance Num a => Monoid (Sum a) where + mempty = Sum 0 + +-- | @since 4.8.0.0 +instance Functor Sum where + fmap = coerce + +-- | @since 4.8.0.0 +instance Applicative Sum where + pure = Sum + (<*>) = coerce + +-- | @since 4.8.0.0 +instance Monad Sum where + m >>= k = k (getSum m) + +-- | Monoid under multiplication. +-- +-- >>> getProduct (Product 3 <> Product 4 <> mempty) +-- 12 +newtype Product a = Product { getProduct :: a } + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + , Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Bounded -- ^ @since 2.01 + , Generic -- ^ @since 4.7.0.0 + , Generic1 -- ^ @since 4.7.0.0 + , Num -- ^ @since 4.7.0.0 + ) + +-- | @since 4.9.0.0 +instance Num a => Semigroup (Product a) where + (<>) = coerce ((*) :: a -> a -> a) + stimes n (Product a) = Product (a ^ n) + + +-- | @since 2.01 +instance Num a => Monoid (Product a) where + mempty = Product 1 + +-- | @since 4.8.0.0 +instance Functor Product where + fmap = coerce + +-- | @since 4.8.0.0 +instance Applicative Product where + pure = Product + (<*>) = coerce + +-- | @since 4.8.0.0 +instance Monad Product where + m >>= k = k (getProduct m) + + +-- | Monoid under '<|>'. +-- +-- @since 4.8.0.0 +newtype Alt f a = Alt {getAlt :: f a} + deriving ( Generic -- ^ @since 4.8.0.0 + , Generic1 -- ^ @since 4.8.0.0 + , Read -- ^ @since 4.8.0.0 + , Show -- ^ @since 4.8.0.0 + , Eq -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + , Num -- ^ @since 4.8.0.0 + , Enum -- ^ @since 4.8.0.0 + , Monad -- ^ @since 4.8.0.0 + , MonadPlus -- ^ @since 4.8.0.0 + , Applicative -- ^ @since 4.8.0.0 + , Alternative -- ^ @since 4.8.0.0 + , Functor -- ^ @since 4.8.0.0 + ) + +-- | @since 4.9.0.0 +instance Alternative f => Semigroup (Alt f a) where + (<>) = coerce ((<|>) :: f a -> f a -> f a) + stimes = stimesMonoid + +-- | @since 4.8.0.0 +instance Alternative f => Monoid (Alt f a) where + mempty = Alt empty diff --git a/libraries/base/Data/Semigroup/Internal.hs-boot b/libraries/base/Data/Semigroup/Internal.hs-boot new file mode 100644 index 0000000000..36249294e7 --- /dev/null +++ b/libraries/base/Data/Semigroup/Internal.hs-boot @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Semigroup.Internal where + +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe) +import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base + +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a + +stimesDefault :: (Integral b, Semigroup a) => b -> a -> a +stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a +stimesList :: Integral b => b -> [a] -> [a] diff --git a/libraries/base/Data/String.hs b/libraries/base/Data/String.hs index e9f34a82a9..a7295a2144 100644 --- a/libraries/base/Data/String.hs +++ b/libraries/base/Data/String.hs @@ -88,4 +88,6 @@ instance (a ~ Char) => IsString [a] where -- | @since 4.9.0.0 deriving instance IsString a => IsString (Const a b) + +-- | @since 4.9.0.0 deriving instance IsString a => IsString (Identity a) diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs index 5c2745edeb..93c42258e2 100644 --- a/libraries/base/Data/Traversable.hs +++ b/libraries/base/Data/Traversable.hs @@ -60,11 +60,13 @@ import Data.Foldable ( Foldable ) import Data.Functor import Data.Functor.Identity ( Identity(..) ) import Data.Functor.Utils ( StateL(..), StateR(..) ) -import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) ) +import Data.Monoid ( Dual(..), Sum(..), Product(..), + First(..), Last(..), Alt(..), Ap(..) ) +import Data.Ord ( Down(..) ) import Data.Proxy ( Proxy(..) ) import GHC.Arr -import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), +import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), NonEmpty(..), ($), (.), id, flip ) import GHC.Generics import qualified GHC.List as List ( foldr ) @@ -163,7 +165,7 @@ class (Functor t, Foldable t) => Traversable t where traverse f = sequenceA . fmap f -- | Evaluate each action in the structure from left to right, and - -- and collect the results. For a version that ignores the results + -- collect the results. For a version that ignores the results -- see 'Data.Foldable.sequenceA_'. sequenceA :: Applicative f => t (f a) -> f (t a) {-# INLINE sequenceA #-} -- See Note [Inline default methods] @@ -198,8 +200,8 @@ Consider This gives rise to a list-instance of mapM looking like this - $fTraversable[]_$ctaverse = ...code for traverse on lists... - {-# INLINE $fTraversable[]_$ctaverse #-} + $fTraversable[]_$ctraverse = ...code for traverse on lists... + {-# INLINE $fTraversable[]_$ctraverse #-} $fTraversable[]_$cmapM = $fTraversable[]_$ctraverse Now the $ctraverse obediently inlines into the RHS of $cmapM, /but/ @@ -237,6 +239,10 @@ instance Traversable [] where traverse f = List.foldr cons_f (pure []) where cons_f x ys = liftA2 (:) (f x) ys +-- | @since 4.9.0.0 +instance Traversable NonEmpty where + traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as) + -- | @since 4.7.0.0 instance Traversable (Either a) where traverse _ (Left x) = pure (Left x) @@ -285,12 +291,22 @@ instance Traversable First where instance Traversable Last where traverse f (Last x) = Last <$> traverse f x +-- | @since 4.12.0.0 +instance (Traversable f) => Traversable (Alt f) where + traverse f (Alt x) = Alt <$> traverse f x + +-- | @since 4.12.0.0 +instance (Traversable f) => Traversable (Ap f) where + traverse f (Ap x) = Ap <$> traverse f x + -- | @since 4.9.0.0 instance Traversable ZipList where traverse f (ZipList x) = ZipList <$> traverse f x +-- | @since 4.9.0.0 deriving instance Traversable Identity + -- Instances for GHC.Generics -- | @since 4.9.0.0 instance Traversable U1 where @@ -303,21 +319,52 @@ instance Traversable U1 where sequence _ = pure U1 {-# INLINE sequence #-} +-- | @since 4.9.0.0 deriving instance Traversable V1 + +-- | @since 4.9.0.0 deriving instance Traversable Par1 + +-- | @since 4.9.0.0 deriving instance Traversable f => Traversable (Rec1 f) + +-- | @since 4.9.0.0 deriving instance Traversable (K1 i c) + +-- | @since 4.9.0.0 deriving instance Traversable f => Traversable (M1 i c f) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :+: g) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :*: g) + +-- | @since 4.9.0.0 deriving instance (Traversable f, Traversable g) => Traversable (f :.: g) + +-- | @since 4.9.0.0 deriving instance Traversable UAddr + +-- | @since 4.9.0.0 deriving instance Traversable UChar + +-- | @since 4.9.0.0 deriving instance Traversable UDouble + +-- | @since 4.9.0.0 deriving instance Traversable UFloat + +-- | @since 4.9.0.0 deriving instance Traversable UInt + +-- | @since 4.9.0.0 deriving instance Traversable UWord +-- Instance for Data.Ord +-- | @since 4.12.0.0 +deriving instance Traversable Down + -- general functions -- | 'for' is 'traverse' with its arguments flipped. For a version @@ -333,14 +380,14 @@ forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM = flip mapM -- |The 'mapAccumL' function behaves like a combination of 'fmap' --- and 'foldl'; it applies a function to each element of a structure, +-- and 'Data.Foldable.foldl'; it applies a function to each element of a structure, -- passing an accumulating parameter from left to right, and returning -- a final value of this accumulator together with the new structure. mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s -- |The 'mapAccumR' function behaves like a combination of 'fmap' --- and 'foldr'; it applies a function to each element of a structure, +-- and 'Data.Foldable.foldr'; it applies a function to each element of a structure, -- passing an accumulating parameter from right to left, and returning -- a final value of this accumulator together with the new structure. mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) diff --git a/libraries/base/Data/Tuple.hs b/libraries/base/Data/Tuple.hs index 372e2b8a86..569dd14da0 100644 --- a/libraries/base/Data/Tuple.hs +++ b/libraries/base/Data/Tuple.hs @@ -6,7 +6,7 @@ -- Module : Data.Tuple -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable @@ -39,13 +39,32 @@ snd :: (a,b) -> b snd (_,y) = y -- | 'curry' converts an uncurried function to a curried function. +-- +-- ==== __Examples__ +-- +-- >>> curry fst 1 2 +-- 1 curry :: ((a, b) -> c) -> a -> b -> c curry f x y = f (x, y) -- | 'uncurry' converts a curried function to a function on pairs. +-- +-- ==== __Examples__ +-- +-- >>> uncurry (+) (1,2) +-- 3 +-- +-- >>> uncurry ($) (show, 1) +-- "1" +-- +-- >>> map (uncurry max) [(1,2), (3,4), (6,8)] +-- [2,4,8] uncurry :: (a -> b -> c) -> ((a, b) -> c) uncurry f p = f (fst p) (snd p) -- | Swap the components of a pair. swap :: (a,b) -> (b,a) swap (a,b) = (b,a) + +-- $setup +-- >>> import Prelude hiding (curry, uncurry, fst, snd) diff --git a/libraries/base/Data/Type/Coercion.hs b/libraries/base/Data/Type/Coercion.hs index 2358115c6d..b757682a62 100644 --- a/libraries/base/Data/Type/Coercion.hs +++ b/libraries/base/Data/Type/Coercion.hs @@ -76,13 +76,17 @@ trans Coercion Coercion = Coercion repr :: (a Eq.:~: b) -> Coercion a b repr Eq.Refl = Coercion +-- | @since 4.7.0.0 deriving instance Eq (Coercion a b) + +-- | @since 4.7.0.0 deriving instance Show (Coercion a b) + +-- | @since 4.7.0.0 deriving instance Ord (Coercion a b) -- | @since 4.7.0.0 -instance Coercible a b => Read (Coercion a b) where - readsPrec d = readParen (d > 10) (\r -> [(Coercion, s) | ("Coercion",s) <- lex r ]) +deriving instance Coercible a b => Read (Coercion a b) -- | @since 4.7.0.0 instance Coercible a b => Enum (Coercion a b) where diff --git a/libraries/base/Data/Type/Equality.hs b/libraries/base/Data/Type/Equality.hs index 8cc34f687d..dfdf23b5f0 100644 --- a/libraries/base/Data/Type/Equality.hs +++ b/libraries/base/Data/Type/Equality.hs @@ -4,14 +4,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- @@ -53,30 +53,6 @@ import GHC.Read import GHC.Base import Data.Type.Bool --- | Lifted, homogeneous equality. By lifted, we mean that it can be --- bogus (deferred type error). By homogeneous, the two types @a@ --- and @b@ must have the same kind. -class a ~~ b => (a :: k) ~ (b :: k) - -- See Note [The equality types story] in TysPrim - -- NB: All this class does is to wrap its superclass, which is - -- the "real", inhomogeneous equality; this is needed when - -- we have a Given (a~b), and we want to prove things from it - -- NB: Not exported, as (~) is magical syntax. That's also why there's - -- no fixity. - - -- It's tempting to put functional dependencies on (~), but it's not - -- necessary because the functional-dependency coverage check looks - -- through superclasses, and (~#) is handled in that check. - --- | @since 4.9.0.0 -instance {-# INCOHERENT #-} a ~~ b => a ~ b - -- See Note [The equality types story] in TysPrim - -- If we have a Wanted (t1 ~ t2), we want to immediately - -- simplify it to (t1 ~~ t2) and solve that instead - -- - -- INCOHERENT because we want to use this instance eagerly, even when - -- the tyvars are partially unknown. - infix 4 :~:, :~~: -- | Propositional equality. If @a :~: b@ is inhabited by some terminating @@ -120,13 +96,17 @@ inner Refl = Refl outer :: (f a :~: g b) -> (f :~: g) outer Refl = Refl +-- | @since 4.7.0.0 deriving instance Eq (a :~: b) + +-- | @since 4.7.0.0 deriving instance Show (a :~: b) + +-- | @since 4.7.0.0 deriving instance Ord (a :~: b) -- | @since 4.7.0.0 -instance a ~ b => Read (a :~: b) where - readsPrec d = readParen (d > 10) (\r -> [(Refl, s) | ("Refl",s) <- lex r ]) +deriving instance a ~ b => Read (a :~: b) -- | @since 4.7.0.0 instance a ~ b => Enum (a :~: b) where @@ -138,7 +118,7 @@ instance a ~ b => Enum (a :~: b) where -- | @since 4.7.0.0 deriving instance a ~ b => Bounded (a :~: b) --- | Kind heterogeneous propositional equality. Like '(:~:)', @a :~~: b@ is +-- | Kind heterogeneous propositional equality. Like ':~:', @a :~~: b@ is -- inhabited by a terminating value if and only if @a@ is the same type as @b@. -- -- @since 4.10.0.0 @@ -153,8 +133,7 @@ deriving instance Show (a :~~: b) deriving instance Ord (a :~~: b) -- | @since 4.10.0.0 -instance a ~~ b => Read (a :~~: b) where - readsPrec d = readParen (d > 10) (\r -> [(HRefl, s) | ("HRefl",s) <- lex r ]) +deriving instance a ~~ b => Read (a :~~: b) -- | @since 4.10.0.0 instance a ~~ b => Enum (a :~~: b) where @@ -181,164 +160,47 @@ instance TestEquality ((:~:) a) where instance TestEquality ((:~~:) a) where testEquality HRefl HRefl = Just Refl --- | A type family to compute Boolean equality. Instances are provided --- only for /open/ kinds, such as @*@ and function kinds. Instances are --- also provided for datatypes exported from base. A poly-kinded instance --- is /not/ provided, as a recursive definition for algebraic kinds is --- generally more useful. -type family (a :: k) == (b :: k) :: Bool infix 4 == -{- -This comment explains more about why a poly-kinded instance for (==) is -not provided. To be concrete, here would be the poly-kinded instance: - -type family EqPoly (a :: k) (b :: k) where - EqPoly a a = True - EqPoly a b = False -type instance (a :: k) == (b :: k) = EqPoly a b - -Note that this overlaps with every other instance -- if this were defined, -it would be the only instance for (==). - -Now, consider -data Nat = Zero | Succ Nat - -Suppose I want -foo :: (Succ n == Succ m) ~ True => ((n == m) :~: True) -foo = Refl - -This would not type-check with the poly-kinded instance. `Succ n == Succ m` -quickly becomes `EqPoly (Succ n) (Succ m)` but then is stuck. We don't know -enough about `n` and `m` to reduce further. - -On the other hand, consider this: - -type family EqNat (a :: Nat) (b :: Nat) where - EqNat Zero Zero = True - EqNat (Succ n) (Succ m) = EqNat n m - EqNat n m = False -type instance (a :: Nat) == (b :: Nat) = EqNat a b - -With this instance, `foo` type-checks fine. `Succ n == Succ m` becomes `EqNat -(Succ n) (Succ m)` which becomes `EqNat n m`. Thus, we can conclude `(n == m) -~ True` as desired. - -So, the Nat-specific instance allows strictly more reductions, and is thus -preferable to the poly-kinded instance. But, if we introduce the poly-kinded -instance, we are barred from writing the Nat-specific instance, due to -overlap. - -Even better than the current instance for * would be one that does this sort -of recursion for all datatypes, something like this: - -type family EqStar (a :: *) (b :: *) where - EqStar Bool Bool = True - EqStar (a,b) (c,d) = a == c && b == d - EqStar (Maybe a) (Maybe b) = a == b - ... - EqStar a b = False - -The problem is the (...) is extensible -- we would want to add new cases for -all datatypes in scope. This is not currently possible for closed type -families. --} - --- all of the following closed type families are local to this module -type family EqStar (a :: *) (b :: *) where - EqStar a a = 'True - EqStar a b = 'False - --- This looks dangerous, but it isn't. This allows == to be defined --- over arbitrary type constructors. -type family EqArrow (a :: k1 -> k2) (b :: k1 -> k2) where - EqArrow a a = 'True - EqArrow a b = 'False - -type family EqBool a b where - EqBool 'True 'True = 'True - EqBool 'False 'False = 'True - EqBool a b = 'False - -type family EqOrdering a b where - EqOrdering 'LT 'LT = 'True - EqOrdering 'EQ 'EQ = 'True - EqOrdering 'GT 'GT = 'True - EqOrdering a b = 'False - -type EqUnit (a :: ()) (b :: ()) = 'True - -type family EqList a b where - EqList '[] '[] = 'True - EqList (h1 ': t1) (h2 ': t2) = (h1 == h2) && (t1 == t2) - EqList a b = 'False - -type family EqMaybe a b where - EqMaybe 'Nothing 'Nothing = 'True - EqMaybe ('Just x) ('Just y) = x == y - EqMaybe a b = 'False - -type family Eq2 a b where - Eq2 '(a1, b1) '(a2, b2) = a1 == a2 && b1 == b2 - -type family Eq3 a b where - Eq3 '(a1, b1, c1) '(a2, b2, c2) = a1 == a2 && b1 == b2 && c1 == c2 - -type family Eq4 a b where - Eq4 '(a1, b1, c1, d1) '(a2, b2, c2, d2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 - -type family Eq5 a b where - Eq5 '(a1, b1, c1, d1, e1) '(a2, b2, c2, d2, e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 - -type family Eq6 a b where - Eq6 '(a1, b1, c1, d1, e1, f1) '(a2, b2, c2, d2, e2, f2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 - -type family Eq7 a b where - Eq7 '(a1, b1, c1, d1, e1, f1, g1) '(a2, b2, c2, d2, e2, f2, g2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 - -type family Eq8 a b where - Eq8 '(a1, b1, c1, d1, e1, f1, g1, h1) '(a2, b2, c2, d2, e2, f2, g2, h2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 - -type family Eq9 a b where - Eq9 '(a1, b1, c1, d1, e1, f1, g1, h1, i1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 - -type family Eq10 a b where - Eq10 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 - -type family Eq11 a b where - Eq11 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 - -type family Eq12 a b where - Eq12 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 - -type family Eq13 a b where - Eq13 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 - -type family Eq14 a b where - Eq14 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 - -type family Eq15 a b where - Eq15 '(a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) '(a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 && o1 == o2 - --- these all look to be overlapping, but they are differentiated by their kinds -type instance a == b = EqStar a b -type instance a == b = EqArrow a b -type instance a == b = EqBool a b -type instance a == b = EqOrdering a b -type instance a == b = EqUnit a b -type instance a == b = EqList a b -type instance a == b = EqMaybe a b -type instance a == b = Eq2 a b -type instance a == b = Eq3 a b -type instance a == b = Eq4 a b -type instance a == b = Eq5 a b -type instance a == b = Eq6 a b -type instance a == b = Eq7 a b -type instance a == b = Eq8 a b -type instance a == b = Eq9 a b -type instance a == b = Eq10 a b -type instance a == b = Eq11 a b -type instance a == b = Eq12 a b -type instance a == b = Eq13 a b -type instance a == b = Eq14 a b -type instance a == b = Eq15 a b +-- | A type family to compute Boolean equality. +type family (a :: k) == (b :: k) :: Bool where + f a == g b = f == g && a == b + a == a = 'True + _ == _ = 'False + +-- The idea here is to recognize equality of *applications* using +-- the first case, and of *constructors* using the second and third +-- ones. It would be wonderful if GHC recognized that the +-- first and second cases are compatible, which would allow us to +-- prove +-- +-- a ~ b => a == b +-- +-- but it (understandably) does not. +-- +-- It is absolutely critical that the three cases occur in precisely +-- this order. In particular, if +-- +-- a == a = 'True +-- +-- came first, then the type application case would only be reached +-- (uselessly) when GHC discovered that the types were not equal. +-- +-- One might reasonably ask what's wrong with a simpler version: +-- +-- type family (a :: k) == (b :: k) where +-- a == a = True +-- a == b = False +-- +-- Consider +-- data Nat = Zero | Succ Nat +-- +-- Suppose I want +-- foo :: (Succ n == Succ m) ~ True => ((n == m) :~: True) +-- foo = Refl +-- +-- This would not type-check with the simple version. `Succ n == Succ m` +-- is stuck. We don't know enough about `n` and `m` to reduce the family. +-- With the recursive version, `Succ n == Succ m` reduces to +-- `Succ == Succ && n == m`, which can reduce to `'True && n == m` and +-- finally to `n == m`. diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index 6157e82b1f..c9a8711d79 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -86,8 +86,6 @@ module Data.Typeable -- * For backwards compatibility , typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7 - , Typeable1, Typeable2, Typeable3, Typeable4 - , Typeable5, Typeable6, Typeable7 ) where import qualified Data.Typeable.Internal as I @@ -200,44 +198,30 @@ rnfTypeRep = I.rnfSomeTypeRep -- Keeping backwards-compatibility -typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep +typeOf1 :: forall t (a :: Type). Typeable t => t a -> TypeRep typeOf1 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep +typeOf2 :: forall t (a :: Type) (b :: Type). Typeable t => t a b -> TypeRep typeOf2 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t - => t a b c -> TypeRep +typeOf3 :: forall t (a :: Type) (b :: Type) (c :: Type). + Typeable t => t a b c -> TypeRep typeOf3 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t - => t a b c d -> TypeRep +typeOf4 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type). + Typeable t => t a b c d -> TypeRep typeOf4 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t - => t a b c d e -> TypeRep +typeOf5 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type). + Typeable t => t a b c d e -> TypeRep typeOf5 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *). - Typeable t => t a b c d e f -> TypeRep +typeOf6 :: forall t (a :: Type) (b :: Type) (c :: Type) + (d :: Type) (e :: Type) (f :: Type). + Typeable t => t a b c d e f -> TypeRep typeOf6 _ = I.someTypeRep (Proxy :: Proxy t) -typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *) - (g :: *). Typeable t => t a b c d e f g -> TypeRep +typeOf7 :: forall t (a :: Type) (b :: Type) (c :: Type) + (d :: Type) (e :: Type) (f :: Type) (g :: Type). + Typeable t => t a b c d e f g -> TypeRep typeOf7 _ = I.someTypeRep (Proxy :: Proxy t) - -type Typeable1 (a :: * -> *) = Typeable a -type Typeable2 (a :: * -> * -> *) = Typeable a -type Typeable3 (a :: * -> * -> * -> *) = Typeable a -type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a -type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a -type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a -type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a - -{-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8 diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index cf3ea0732d..0d4fc825cf 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} @@ -18,6 +17,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -32,6 +32,11 @@ ----------------------------------------------------------------------------- module Data.Typeable.Internal ( + -- * Typeable and kind polymorphism + -- + -- #kind_instantiation + + -- * Miscellaneous Fingerprint(..), -- * Typeable class @@ -70,7 +75,7 @@ module Data.Typeable.Internal ( -- * Construction -- | These are for internal use only - mkTrCon, mkTrApp, mkTrFun, + mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, typeSymbolTypeRep, typeNatTypeRep, ) where @@ -79,10 +84,10 @@ import GHC.Base import qualified GHC.Arr as A import GHC.Types ( TYPE ) import Data.Type.Equality -import GHC.List ( splitAt, foldl' ) +import GHC.List ( splitAt, foldl', elem ) import GHC.Word import GHC.Show -import GHC.TypeLits ( KnownSymbol, symbolVal' ) +import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol ) import GHC.TypeNats ( KnownNat, natVal' ) import Unsafe.Coerce ( unsafeCoerce ) @@ -92,6 +97,7 @@ import {-# SOURCE #-} GHC.Fingerprint -- Better to break the loop here, because we want non-SOURCE imports -- of Data.Typeable as much as possible so we can optimise the derived -- instances. +-- import {-# SOURCE #-} Debug.Trace (trace) #include "MachDeps.h" @@ -173,20 +179,111 @@ rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k -- | A concrete representation of a (monomorphic) type. -- 'TypeRep' supports reasonably efficient equality. data TypeRep (a :: k) where - TrTyCon :: {-# UNPACK #-} !Fingerprint -> !TyCon -> [SomeTypeRep] + -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2 + TrType :: TypeRep Type + TrTyCon :: { -- See Note [TypeRep fingerprints] + trTyConFingerprint :: {-# UNPACK #-} !Fingerprint + + -- The TypeRep represents the application of trTyCon + -- to the kind arguments trKindVars. So for + -- 'Just :: Bool -> Maybe Bool, the trTyCon will be + -- 'Just and the trKindVars will be [Bool]. + , trTyCon :: !TyCon + , trKindVars :: [SomeTypeRep] + , trTyConKind :: !(TypeRep k) } -- See Note [Kind caching] -> TypeRep (a :: k) + + -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@) + -- are represented with @'TrFun' a b@, not @TrApp (TrApp funTyCon a) b@. TrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). - {-# UNPACK #-} !Fingerprint - -> TypeRep (a :: k1 -> k2) - -> TypeRep (b :: k1) + { -- See Note [TypeRep fingerprints] + trAppFingerprint :: {-# UNPACK #-} !Fingerprint + + -- The TypeRep represents the application of trAppFun + -- to trAppArg. For Maybe Int, the trAppFun will be Maybe + -- and the trAppArg will be Int. + , trAppFun :: !(TypeRep (a :: k1 -> k2)) + , trAppArg :: !(TypeRep (b :: k1)) + , trAppKind :: !(TypeRep k2) } -- See Note [Kind caching] -> TypeRep (a b) + + -- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for + -- the sake of efficiency as functions are quite ubiquitous. TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). - {-# UNPACK #-} !Fingerprint - -> TypeRep a - -> TypeRep b + { -- See Note [TypeRep fingerprints] + trFunFingerprint :: {-# UNPACK #-} !Fingerprint + + -- The TypeRep represents a function from trFunArg to + -- trFunRes. + , trFunArg :: !(TypeRep a) + , trFunRes :: !(TypeRep b) } -> TypeRep (a -> b) +{- Note [TypeRep fingerprints] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We store a Fingerprint of each TypeRep in its constructor. This allows +us to test whether two TypeReps are equal in constant time, rather than +having to walk their full structures. +-} + +{- Note [Kind caching] + ~~~~~~~~~~~~~~~~~~~ + +We cache the kind of the TypeRep in each TrTyCon and TrApp constructor. +This is necessary to ensure that typeRepKind (which is used, at least, in +deserialization and dynApply) is cheap. There are two reasons for this: + +1. Calculating the kind of a nest of type applications, such as + + F X Y Z W (App (App (App (App F X) Y) Z) W) + +is linear in the depth, which is already a bit pricy. In deserialization, +we build up such a nest from the inside out, so without caching, that ends +up taking quadratic time, and calculating the KindRep of the constructor, +F, a linear number of times. See #14254. + +2. Calculating the kind of a type constructor, in instantiateTypeRep, +requires building (allocating) a TypeRep for the kind "from scratch". +This can get pricy. When combined with point (1), we can end up with +a large amount of extra allocation deserializing very deep nests. +See #14337. + +It is quite possible to speed up deserialization by structuring that process +very carefully. Unfortunately, that doesn't help dynApply or anything else +that may use typeRepKind. Since caching the kind isn't terribly expensive, it +seems better to just do that and solve all the potential problems at once. + +There are two things we need to be careful about when caching kinds. + +Wrinkle 1: + +We want to do it eagerly. Suppose we have + + tf :: TypeRep (f :: j -> k) + ta :: TypeRep (a :: j) + +Then the cached kind of App tf ta should be eagerly evaluated to k, rather +than being stored as a thunk that will strip the (j ->) off of j -> k if +and when it is forced. + +Wrinkle 2: + +We need to be able to represent TypeRep Type. This is a bit tricky because +typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the +typerep of the kind of Type, we will have a loop. One simple way to do this +is to make the cached kind fields lazy and allow TypeRep Type to be cyclical. + +But we *do not* want TypeReps to have cyclical structure! Most importantly, +a cyclical structure cannot be stored in a compact region. Secondarily, +using :force in GHCi on a cyclical structure will lead to non-termination. + +To avoid this trouble, we use a separate constructor for TypeRep Type. +mkTrApp is responsible for recognizing that TYPE is being applied to +'LiftedRep and produce trType; other functions must recognize that TrType +represents an application. +-} + -- Compare keys for equality -- | @since 2.01 @@ -221,6 +318,14 @@ instance Ord SomeTypeRep where SomeTypeRep a `compare` SomeTypeRep b = typeRepFingerprint a `compare` typeRepFingerprint b +-- | The function type constructor. +-- +-- For instance, +-- +-- @ +-- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char) +-- @ +-- pattern Fun :: forall k (fun :: k). () => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (arg :: TYPE r1) (res :: TYPE r2). @@ -228,16 +333,21 @@ pattern Fun :: forall k (fun :: k). () => TypeRep arg -> TypeRep res -> TypeRep fun -pattern Fun arg res <- TrFun _ arg res +pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res} where Fun arg res = mkTrFun arg res -- | Observe the 'Fingerprint' of a type representation -- -- @since 4.8.0.0 typeRepFingerprint :: TypeRep a -> Fingerprint -typeRepFingerprint (TrTyCon fpr _ _) = fpr -typeRepFingerprint (TrApp fpr _ _) = fpr -typeRepFingerprint (TrFun fpr _ _) = fpr +typeRepFingerprint TrType = fpTYPELiftedRep +typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr +typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr +typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr + +-- For compiler use +mkTrType :: TypeRep Type +mkTrType = TrType -- | Construct a representation for a type constructor -- applied at a monomorphic kind. @@ -245,54 +355,195 @@ typeRepFingerprint (TrFun fpr _ _) = fpr -- Note that this is unsafe as it allows you to construct -- ill-kinded types. mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a -mkTrCon tc kind_vars = TrTyCon fpr tc kind_vars +mkTrCon tc kind_vars = TrTyCon + { trTyConFingerprint = fpr + , trTyCon = tc + , trKindVars = kind_vars + , trTyConKind = kind } where fpr_tc = tyConFingerprint tc fpr_kvs = map someTypeRepFingerprint kind_vars fpr = fingerprintFingerprints (fpr_tc:fpr_kvs) + kind = unsafeCoerceRep $ tyConKind tc kind_vars + +-- The fingerprint of Type. We don't store this in the TrType +-- constructor, so we need to build it here. +fpTYPELiftedRep :: Fingerprint +fpTYPELiftedRep = fingerprintFingerprints + [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep] +-- There is absolutely nothing to gain and everything to lose +-- by inlining the worker. The wrapper should inline anyway. +{-# NOINLINE fpTYPELiftedRep #-} + +trTYPE :: TypeRep TYPE +trTYPE = typeRep + +trLiftedRep :: TypeRep 'LiftedRep +trLiftedRep = typeRep + +-- | Construct a representation for a type application that is +-- NOT a saturated arrow type. This is not checked! --- | Construct a representation for a type application. --- -- Note that this is known-key to the compiler, which uses it in desugar -- 'Typeable' evidence. mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). TypeRep (a :: k1 -> k2) -> TypeRep (b :: k1) -> TypeRep (a b) -mkTrApp a b = TrApp fpr a b +mkTrApp a b -- See Note [Kind caching], Wrinkle 2 + | Just HRefl <- a `eqTypeRep` trTYPE + , Just HRefl <- b `eqTypeRep` trLiftedRep + = TrType + + | TrFun {trFunRes = res_kind} <- typeRepKind a + = TrApp + { trAppFingerprint = fpr + , trAppFun = a + , trAppArg = b + , trAppKind = res_kind } + + | otherwise = error ("Ill-kinded type application: " + ++ show (typeRepKind a)) where fpr_a = typeRepFingerprint a fpr_b = typeRepFingerprint b fpr = fingerprintFingerprints [fpr_a, fpr_b] --- | Pattern match on a type application +-- | Construct a representation for a type application that +-- may be a saturated arrow type. This is renamed to mkTrApp in +-- Type.Reflection.Unsafe +mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + TypeRep (a :: k1 -> k2) + -> TypeRep (b :: k1) + -> TypeRep (a b) +mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x}) + (y :: TypeRep y) + | TrTyCon {trTyCon=con} <- p + , con == funTyCon -- cheap check first + , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x) + , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y) + , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry + $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep + = mkTrFun x y +mkTrAppChecked a b = mkTrApp a b + +-- | A type application. +-- +-- For instance, +-- +-- @ +-- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int) +-- @ +-- +-- Note that this will also match a function type, +-- +-- @ +-- typeRep \@(Int# -> Char) +-- === +-- App (App arrow (typeRep \@Int#)) (typeRep \@Char) +-- @ +-- +-- where @arrow :: TypeRep ((->) :: TYPE IntRep -> Type -> Type)@. +-- pattern App :: forall k2 (t :: k2). () => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b) => TypeRep a -> TypeRep b -> TypeRep t -pattern App f x <- TrApp _ f x - where App f x = mkTrApp f x +pattern App f x <- (splitApp -> IsApp f x) + where App f x = mkTrAppChecked f x + +data AppOrCon (a :: k) where + IsApp :: forall k k' (f :: k' -> k) (x :: k'). () + => TypeRep f -> TypeRep x -> AppOrCon (f x) + -- See Note [Con evidence] + IsCon :: IsApplication a ~ "" => TyCon -> [SomeTypeRep] -> AppOrCon a + +type family IsApplication (x :: k) :: Symbol where + IsApplication (_ _) = "An error message about this unifying with \"\" " + `AppendSymbol` "means that you tried to match a TypeRep with Con or " + `AppendSymbol` "Con' when the represented type was known to be an " + `AppendSymbol` "application." + IsApplication _ = "" + +splitApp :: forall k (a :: k). () + => TypeRep a + -> AppOrCon a +splitApp TrType = IsApp trTYPE trLiftedRep +splitApp (TrApp {trAppFun = f, trAppArg = x}) = IsApp f x +splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = IsApp (mkTrApp arr a) b + where arr = bareArrow rep +splitApp (TrTyCon{trTyCon = con, trKindVars = kinds}) + = case unsafeCoerce Refl :: IsApplication a :~: "" of + Refl -> IsCon con kinds -- | Use a 'TypeRep' as 'Typeable' evidence. -withTypeable :: forall a r. TypeRep a -> (Typeable a => r) -> r +withTypeable :: forall k (a :: k) rep (r :: TYPE rep). () + => TypeRep a -> (Typeable a => r) -> r withTypeable rep k = unsafeCoerce k' rep where k' :: Gift a r k' = Gift k -- | A helper to satisfy the type checker in 'withTypeable'. -newtype Gift a r = Gift (Typeable a => r) +newtype Gift a (r :: TYPE rep) = Gift (Typeable a => r) -- | Pattern match on a type constructor -pattern Con :: forall k (a :: k). TyCon -> TypeRep a -pattern Con con <- TrTyCon _ con _ +pattern Con :: forall k (a :: k). () + => IsApplication a ~ "" -- See Note [Con evidence] + => TyCon -> TypeRep a +pattern Con con <- (splitApp -> IsCon con _) -- | Pattern match on a type constructor including its instantiated kind -- variables. -pattern Con' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a -pattern Con' con ks <- TrTyCon _ con ks +-- +-- For instance, +-- +-- @ +-- App (Con' proxyTyCon ks) intRep = typeRep @(Proxy \@Int) +-- @ +-- +-- will bring into scope, +-- +-- @ +-- proxyTyCon :: TyCon +-- ks == [someTypeRep @Type] :: [SomeTypeRep] +-- intRep == typeRep @Int +-- @ +-- +pattern Con' :: forall k (a :: k). () + => IsApplication a ~ "" -- See Note [Con evidence] + => TyCon -> [SomeTypeRep] -> TypeRep a +pattern Con' con ks <- (splitApp -> IsCon con ks) +-- TODO: Remove Fun when #14253 is fixed {-# COMPLETE Fun, App, Con #-} {-# COMPLETE Fun, App, Con' #-} +{- Note [Con evidence] + ~~~~~~~~~~~~~~~~~~~ + +Matching TypeRep t on Con or Con' fakes up evidence that + + IsApplication t ~ "". + +Why should anyone care about the value of strange internal type family? +Well, almost nobody cares about it, but the pattern checker does! +For example, suppose we have TypeRep (f x) and we want to get +TypeRep f and TypeRep x. There is no chance that the Con constructor +will match, because (f x) is not a constructor, but without the +IsApplication evidence, omitting it will lead to an incomplete pattern +warning. With the evidence, the pattern checker will see that +Con wouldn't typecheck, so everything works out as it should. + +Why do we use Symbols? We would really like to use something like + + type family NotApplication (t :: k) :: Constraint where + NotApplication (f a) = TypeError ... + NotApplication _ = () + +Unfortunately, #11503 means that the pattern checker and type checker +will fail to actually reject the mistaken patterns. So we describe the +error in the result type. It's a horrible hack. +-} + ----------------- Observation --------------------- -- | Observe the type constructor of a quantified type representation. @@ -301,9 +552,10 @@ someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t -- | Observe the type constructor of a type representation typeRepTyCon :: TypeRep a -> TyCon -typeRepTyCon (TrTyCon _ tc _) = tc -typeRepTyCon (TrApp _ a _) = typeRepTyCon a -typeRepTyCon (TrFun _ _ _) = typeRepTyCon $ typeRep @(->) +typeRepTyCon TrType = tyConTYPE +typeRepTyCon (TrTyCon {trTyCon = tc}) = tc +typeRepTyCon (TrApp {trAppFun = a}) = typeRepTyCon a +typeRepTyCon (TrFun {}) = typeRepTyCon $ typeRep @(->) -- | Type equality -- @@ -311,9 +563,17 @@ typeRepTyCon (TrFun _ _ _) = typeRepTyCon $ typeRep @(->) eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~~: b) eqTypeRep a b - | typeRepFingerprint a == typeRepFingerprint b = Just (unsafeCoerce HRefl) - | otherwise = Nothing - + | sameTypeRep a b = Just (unsafeCoerce# HRefl) + | otherwise = Nothing +-- We want GHC to inline eqTypeRep to get rid of the Maybe +-- in the usual case that it is scrutinized immediately. We +-- split eqTypeRep into a worker and wrapper because otherwise +-- it's much larger than anything we'd want to inline. +{-# INLINABLE eqTypeRep #-} + +sameTypeRep :: forall k1 k2 (a :: k1) (b :: k2). + TypeRep a -> TypeRep b -> Bool +sameTypeRep a b = typeRepFingerprint a == typeRepFingerprint b ------------------------------------------------------------- -- @@ -323,14 +583,10 @@ eqTypeRep a b -- | Observe the kind of a type. typeRepKind :: TypeRep (a :: k) -> TypeRep k -typeRepKind (TrTyCon _ tc args) - = unsafeCoerceRep $ tyConKind tc args -typeRepKind (TrApp _ f _) - | Fun _ res <- typeRepKind f - = res - | otherwise - = error ("Ill-kinded type application: " ++ show (typeRepKind f)) -typeRepKind (TrFun _ _ _) = typeRep @Type +typeRepKind TrType = TrType +typeRepKind (TrTyCon {trTyConKind = kind}) = kind +typeRepKind (TrApp {trAppKind = kind}) = kind +typeRepKind (TrFun {}) = typeRep @Type tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars = @@ -351,14 +607,15 @@ instantiateKindRep vars = go applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep applyTy (SomeTypeRep acc) ty | SomeTypeRep ty' <- go ty - = SomeTypeRep $ mkTrApp (unsafeCoerce acc) (unsafeCoerce ty') + = SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty' in foldl' applyTy tycon_app ty_args go (KindRepVar var) = vars A.! var go (KindRepApp f a) - = SomeTypeRep $ App (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a) + = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a) go (KindRepFun a b) - = SomeTypeRep $ Fun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) + = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) + go (KindRepTYPE LiftedRep) = SomeTypeRep TrType go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r go (KindRepTypeLitS sort s) = mkTypeLitFromString sort (unpackCStringUtf8# s) @@ -374,16 +631,16 @@ unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x data SomeKindedTypeRep k where - SomeKindedTypeRep :: forall (a :: k). TypeRep a + SomeKindedTypeRep :: forall k (a :: k). TypeRep a -> SomeKindedTypeRep k kApp :: SomeKindedTypeRep (k -> k') -> SomeKindedTypeRep k -> SomeKindedTypeRep k' kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) = - SomeKindedTypeRep (App f a) + SomeKindedTypeRep (mkTrApp f a) -kindedTypeRep :: forall (a :: k). Typeable a => SomeKindedTypeRep k +kindedTypeRep :: forall k (a :: k). Typeable a => SomeKindedTypeRep k kindedTypeRep = SomeKindedTypeRep (typeRep @a) buildList :: forall k. Typeable k @@ -447,6 +704,34 @@ vecElemTypeRep e = rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem rep = kindedTypeRep @VecElem @a +bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). () + => TypeRep (a -> b) + -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type) +bareArrow (TrFun _ a b) = + mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2] + where + rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1 + rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2 +bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible" + +data IsTYPE (a :: Type) where + IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r) + +-- | Is a type of the form @TYPE rep@? +isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a) +isTYPE TrType = Just (IsTYPE trLiftedRep) +isTYPE (TrApp {trAppFun=f, trAppArg=r}) + | Just HRefl <- f `eqTypeRep` typeRep @TYPE + = Just (IsTYPE r) +isTYPE _ = Nothing + +getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r +getRuntimeRep TrType = trLiftedRep +getRuntimeRep (TrApp {trAppArg=r}) = r +getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible" + + ------------------------------------------------------------- -- -- The Typeable class and friends @@ -484,25 +769,24 @@ instance Show (TypeRep (a :: k)) where showTypeable :: Int -> TypeRep (a :: k) -> ShowS +showTypeable _ TrType = showChar '*' showTypeable _ rep - | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) = - showChar '*' | isListTyCon tc, [ty] <- tys = showChar '[' . shows ty . showChar ']' | isTupleTyCon tc = showChar '(' . showArgs (showChar ',') tys . showChar ')' where (tc, tys) = splitApps rep -showTypeable p (TrTyCon _ tycon []) - = showsPrec p tycon -showTypeable p (TrTyCon _ tycon args) +showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []}) + = showTyCon tycon +showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args}) = showParen (p > 9) $ - showsPrec p tycon . + showTyCon tycon . showChar ' ' . showArgs (showChar ' ') args -showTypeable p (TrFun _ x r) +showTypeable p (TrFun {trFunArg = x, trFunRes = r}) = showParen (p > 8) $ showsPrec 9 x . showString " -> " . showsPrec 8 r -showTypeable p (TrApp _ f x) +showTypeable p (TrApp {trAppFun = f, trAppArg = x}) = showParen (p > 9) $ showsPrec 8 f . showChar ' ' . @@ -516,23 +800,68 @@ splitApps :: TypeRep a -> (TyCon, [SomeTypeRep]) splitApps = go [] where go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep]) - go xs (TrTyCon _ tc _) = (tc, xs) - go xs (TrApp _ f x) = go (SomeTypeRep x : xs) f - go [] (TrFun _ a b) = (funTyCon, [SomeTypeRep a, SomeTypeRep b]) - go _ (TrFun _ _ _) = - errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible" + go xs (TrTyCon {trTyCon = tc}) + = (tc, xs) + go xs (TrApp {trAppFun = f, trAppArg = x}) + = go (SomeTypeRep x : xs) f + go [] (TrFun {trFunArg = a, trFunRes = b}) + = (funTyCon, [SomeTypeRep a, SomeTypeRep b]) + go _ (TrFun {}) + = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1" + go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep]) + go _ TrType + = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2" + +-- This is incredibly shady! We don't really want to do this here; we +-- should really have the compiler reveal the TYPE TyCon directly +-- somehow. We need to construct this by hand because otherwise +-- we end up with horrible and somewhat mysterious loops trying to calculate +-- typeRep @TYPE. For the moment, we use the fact that we can get the proper +-- name of the ghc-prim package from the TyCon of LiftedRep (which we can +-- produce a TypeRep for without difficulty), and then just substitute in the +-- appropriate module and constructor names. +-- +-- The ticket to find a better way to deal with this is +-- Trac #14480. +tyConTYPE :: TyCon +tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0 + (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep)) + where + liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep) funTyCon :: TyCon funTyCon = typeRepTyCon (typeRep @(->)) isListTyCon :: TyCon -> Bool -isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [Int]) +isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep []) isTupleTyCon :: TyCon -> Bool isTupleTyCon tc | ('(':',':_) <- tyConName tc = True | otherwise = False +-- This is only an approximation. We don't have the general +-- character-classification machinery here, so we just do our best. +-- This should work for promoted Haskell 98 data constructors and +-- for TypeOperators type constructors that begin with ASCII +-- characters, but it will miss Unicode operators. +-- +-- If we wanted to catch Unicode as well, we ought to consider moving +-- GHC.Lexeme from ghc-boot-th to base. Then we could just say: +-- +-- startsVarSym symb || startsConSym symb +-- +-- But this is a fair deal of work just for one corner case, so I think I'll +-- leave it like this unless someone shouts. +isOperatorTyCon :: TyCon -> Bool +isOperatorTyCon tc + | symb : _ <- tyConName tc + , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True + | otherwise = False + +showTyCon :: TyCon -> ShowS +showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon) + showArgs :: Show a => ShowS -> [a] -> ShowS showArgs _ [] = id showArgs _ [a] = showsPrec 10 a @@ -542,9 +871,11 @@ showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as -- -- @since 4.8.0.0 rnfTypeRep :: TypeRep a -> () -rnfTypeRep (TrTyCon _ tyc _) = rnfTyCon tyc -rnfTypeRep (TrApp _ f x) = rnfTypeRep f `seq` rnfTypeRep x -rnfTypeRep (TrFun _ x y) = rnfTypeRep x `seq` rnfTypeRep y +-- The TypeRep structure is almost entirely strict by definition. The +-- fingerprinting and strict kind caching ensure that everything +-- else is forced anyway. So we don't need to do anything special +-- to reduce to normal form. +rnfTypeRep !_ = () -- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@ -- implementation @@ -649,13 +980,65 @@ tcNat :: TyCon tcNat = typeRepTyCon (typeRep @Nat) -- | An internal function, to make representations for type literals. -typeLitTypeRep :: forall (a :: k). (Typeable k) => String -> TyCon -> TypeRep a +typeLitTypeRep :: forall k (a :: k). (Typeable k) => + String -> TyCon -> TypeRep a typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) [] -- | For compiler use. mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type) -mkTrFun arg res = TrFun fpr arg res +mkTrFun arg res = TrFun + { trFunFingerprint = fpr + , trFunArg = arg + , trFunRes = res } where fpr = fingerprintFingerprints [ typeRepFingerprint arg , typeRepFingerprint res] + +{- $kind_instantiation + +Consider a type like 'Data.Proxy.Proxy', + +@ +data Proxy :: forall k. k -> Type +@ + +One might think that one could decompose an instantiation of this type like +@Proxy Int@ into two applications, + +@ +'App' (App a b) c === typeRep @(Proxy Int) +@ + +where, + +@ +a = typeRep @Proxy +b = typeRep @Type +c = typeRep @Int +@ + +However, this isn't the case. Instead we can only decompose into an application +and a constructor, + +@ +'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int) +@ + +The reason for this is that 'Typeable' can only represent /kind-monomorphic/ +types. That is, we must saturate enough of @Proxy@\'s arguments to +fully determine its kind. In the particular case of @Proxy@ this means we must +instantiate the kind variable @k@ such that no @forall@-quantified variables +remain. + +While it is not possible to decompose the 'Con' above into an application, it is +possible to observe the kind variable instantiations of the constructor with the +'Con\'' pattern, + +@ +'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int) +@ + +Here @kinds@ will be @[typeRep \@Type]@. + +-} diff --git a/libraries/base/Data/Unique.hs b/libraries/base/Data/Unique.hs index 2db9247572..eef6256395 100644 --- a/libraries/base/Data/Unique.hs +++ b/libraries/base/Data/Unique.hs @@ -6,7 +6,7 @@ -- Module : Data.Unique -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable @@ -30,6 +30,15 @@ import Data.IORef -- | An abstract unique object. Objects of type 'Unique' may be -- compared for equality and ordering and hashed into 'Int'. +-- +-- >>> :{ +-- do x <- newUnique +-- print (x == x) +-- y <- newUnique +-- print (x == y) +-- :} +-- True +-- False newtype Unique = Unique Integer deriving (Eq,Ord) uniqSource :: IORef Integer diff --git a/libraries/base/Data/Version.hs b/libraries/base/Data/Version.hs index 310d7387fb..6fb0169d12 100644 --- a/libraries/base/Data/Version.hs +++ b/libraries/base/Data/Version.hs @@ -94,7 +94,10 @@ data Version = -- The interpretation of the list of tags is entirely dependent -- on the entity that this version applies to. } - deriving (Read,Show,Generic) + deriving ( Read -- ^ @since 2.01 + , Show -- ^ @since 2.01 + , Generic -- ^ @since 4.9.0.0 + ) {-# DEPRECATED versionTags "See GHC ticket #2496" #-} -- TODO. Remove all references to versionTags in GHC 8.0 release. diff --git a/libraries/base/Data/Void.hs b/libraries/base/Data/Void.hs index fd4c0b5b21..beb6041f62 100644 --- a/libraries/base/Data/Void.hs +++ b/libraries/base/Data/Void.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} @@ -28,31 +29,22 @@ import Control.Exception import Data.Data import Data.Ix import GHC.Generics +import Data.Semigroup (Semigroup(..), stimesIdempotent) -- | Uninhabited data type -- -- @since 4.8.0.0 -data Void deriving (Generic) - -deriving instance Data Void - --- | @since 4.8.0.0 -instance Eq Void where - _ == _ = True - --- | @since 4.8.0.0 -instance Ord Void where - compare _ _ = EQ - --- | Reading a 'Void' value is always a parse error, considering --- 'Void' as a data type with no constructors. --- | @since 4.8.0.0 -instance Read Void where - readsPrec _ _ = [] - --- | @since 4.8.0.0 -instance Show Void where - showsPrec _ = absurd +data Void deriving + ( Eq -- ^ @since 4.8.0.0 + , Data -- ^ @since 4.8.0.0 + , Generic -- ^ @since 4.8.0.0 + , Ord -- ^ @since 4.8.0.0 + , Read -- ^ Reading a 'Void' value is always a parse error, considering + -- 'Void' as a data type with no constructors. + -- + -- @since 4.8.0.0 + , Show -- ^ @since 4.8.0.0 + ) -- | @since 4.8.0.0 instance Ix Void where @@ -64,9 +56,22 @@ instance Ix Void where -- | @since 4.8.0.0 instance Exception Void +-- | @since 4.9.0.0 +instance Semigroup Void where + a <> _ = a + stimes = stimesIdempotent + -- | Since 'Void' values logically don't exist, this witnesses the -- logical reasoning tool of \"ex falso quodlibet\". -- +-- >>> let x :: Either Void Int; x = Right 5 +-- >>> :{ +-- case x of +-- Right r -> r +-- Left l -> absurd l +-- :} +-- 5 +-- -- @since 4.8.0.0 absurd :: Void -> a absurd a = case a of {} |