Teo Camarasu pushed to branch wip/T26834 at Glasgow Haskell Compiler / GHC Commits: 2af36711 by Teo Camarasu at 2026-01-29T13:06:59+00:00 Split out GHC.Internal.Data.Ord.Down - - - - - 13 changed files: - libraries/base/src/Data/Foldable1.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/Data/Ord.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - + libraries/ghc-internal/src/GHC/Internal/Data/Ord/Down.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs Changes: ===================================== libraries/base/src/Data/Foldable1.hs ===================================== @@ -45,7 +45,7 @@ import Data.Complex (Complex (..)) import GHC.Generics (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..)) -import GHC.Internal.Data.Ord (Down (..)) +import GHC.Internal.Data.Ord.Down (Down (..)) import qualified GHC.Internal.Data.Monoid as Mon ===================================== libraries/base/src/Data/Functor/Classes.hs ===================================== @@ -76,7 +76,7 @@ import Control.Applicative (Alternative((<|>)), Const(Const)) import GHC.Internal.Data.Functor.Identity (Identity(Identity)) import GHC.Internal.Data.Proxy (Proxy(Proxy)) import Data.List.NonEmpty (NonEmpty(..)) -import GHC.Internal.Data.Ord (Down(Down)) +import GHC.Internal.Data.Ord.Down (Down(Down)) import Data.Complex (Complex((:+))) import GHC.Generics (Generic1(..), Generically1(..), V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..), URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord) ===================================== libraries/base/src/Data/Ord.hs ===================================== @@ -21,4 +21,5 @@ module Data.Ord clamp ) where -import GHC.Internal.Data.Ord \ No newline at end of file +import GHC.Internal.Data.Ord +import GHC.Internal.Data.Ord.Down ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -160,6 +160,7 @@ Library GHC.Internal.Data.NonEmpty GHC.Internal.Data.OldList GHC.Internal.Data.Ord + GHC.Internal.Data.Ord.Down GHC.Internal.Data.Proxy GHC.Internal.Data.Semigroup.Internal GHC.Internal.Data.STRef @@ -576,4 +577,4 @@ Library ghc-options: -this-unit-id ghc-internal -- Make sure we don't accidentally regress into anti-patterns - ghc-options: -Wcompat -Wnoncanonical-monad-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Werror=unused-imports ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs ===================================== @@ -33,7 +33,6 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Monoid ( Monoid, Dual(..), Sum(..), Product(..) , First(..), Last(..), Alt(..), Ap(..) ) import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) -import GHC.Internal.Data.Ord ( Down(..) ) import GHC.Internal.Data.Tuple ( Solo(..), snd ) import GHC.Internal.Base ( Monad, errorWithoutStackTrace, (.) ) import GHC.Internal.Generics @@ -167,13 +166,6 @@ instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where fstP (a :*: _) = a sndP (_ :*: b) = b --- Instances for Data.Ord - --- | @since base-4.12.0.0 -instance MonadFix Down where - mfix f = Down (fix (getDown . f)) - - -- | @since base-4.8.0.0 instance MonadFix Identity where mfix f = Identity (fix (runIdentity . f)) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs ===================================== @@ -23,7 +23,6 @@ import GHC.Internal.Data.Functor.Identity import qualified GHC.Internal.Data.Functor import GHC.Internal.Data.Monoid import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) -import GHC.Internal.Data.Ord ( Down(..) ) import GHC.Internal.Data.Proxy --import qualified Data.List.NonEmpty as NE import GHC.Internal.Generics @@ -136,9 +135,3 @@ instance MonadZip f => MonadZip (M1 i c f) where -- | @since 4.9.0.0 instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2 - --- instances for GHC.Internal.Data.Ord - --- | @since 4.12.0.0 -instance MonadZip Down where - mzipWith = liftM2 ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Data.hs ===================================== @@ -116,7 +116,7 @@ import GHC.Internal.Data.Eq import GHC.Internal.Data.Maybe import GHC.Internal.Data.Monoid import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) -import GHC.Internal.Data.Ord +import GHC.Internal.Data.Ord.Down import GHC.Internal.Data.OldList (findIndex) import GHC.Internal.Data.Typeable import GHC.Internal.Data.Version( Version(..) ) ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs ===================================== @@ -921,9 +921,6 @@ deriving instance Foldable UInt -- | @since base-4.9.0.0 deriving instance Foldable UWord --- Instances for Data.Ord --- | @since base-4.12.0.0 -deriving instance Foldable Down -- | Right-to-left monadic fold over the elements of a structure. -- ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs ===================================== @@ -19,21 +19,11 @@ module GHC.Internal.Data.Ord ( Ord(..), Ordering(..), - Down(..), comparing, clamp, ) where -import GHC.Internal.Data.Bits (Bits, FiniteBits, complement) -import GHC.Internal.Foreign.Storable (Storable) -import GHC.Internal.Ix (Ix) import GHC.Internal.Base -import GHC.Internal.Enum (Bounded(..), Enum(..)) -import GHC.Internal.Float (Floating, RealFloat) -import GHC.Internal.Num -import GHC.Internal.Read -import GHC.Internal.Real (Fractional, Real, RealFrac) -import GHC.Internal.Show -- $setup -- >>> import Prelude @@ -68,115 +58,3 @@ comparing p x y = compare (p x) (p y) -- @since base-4.16.0.0 clamp :: (Ord a) => (a, a) -> a -> a clamp (low, high) a = min high (max a low) - --- | The 'Down' type allows you to reverse sort order conveniently. A value of type --- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@). --- --- If @a@ has an @'Ord'@ instance associated with it then comparing two --- values thus wrapped will give you the opposite of their normal sort order. --- This is particularly useful when sorting in generalised list comprehensions, --- as in: @then sortWith by 'Down' x@. --- --- >>> compare True False --- GT --- --- >>> compare (Down True) (Down False) --- LT --- --- If @a@ has a @'Bounded'@ instance then the wrapped instance also respects --- the reversed ordering by exchanging the values of @'minBound'@ and --- @'maxBound'@. --- --- >>> minBound :: Int --- -9223372036854775808 --- --- >>> minBound :: Down Int --- Down 9223372036854775807 --- --- All other instances of @'Down' a@ behave as they do for @a@. --- --- @since base-4.6.0.0 -newtype Down a = Down - { getDown :: a -- ^ @since base-4.14.0.0 - } - deriving - ( Eq -- ^ @since base-4.6.0.0 - , Num -- ^ @since base-4.11.0.0 - , Semigroup -- ^ @since base-4.11.0.0 - , Monoid -- ^ @since base-4.11.0.0 - , Bits -- ^ @since base-4.14.0.0 - , FiniteBits -- ^ @since base-4.14.0.0 - , Floating -- ^ @since base-4.14.0.0 - , Fractional -- ^ @since base-4.14.0.0 - , Ix -- ^ @since base-4.14.0.0 - , Real -- ^ @since base-4.14.0.0 - , RealFrac -- ^ @since base-4.14.0.0 - , RealFloat -- ^ @since base-4.14.0.0 - , Storable -- ^ @since base-4.14.0.0 - ) - --- | This instance would be equivalent to the derived instances of the --- 'Down' newtype if the 'getDown' field were removed --- --- @since base-4.7.0.0 -instance (Read a) => Read (Down a) where - readsPrec d = readParen (d > 10) $ \ r -> - [(Down x,t) | ("Down",s) <- lex r, (x,t) <- readsPrec 11 s] - --- | This instance would be equivalent to the derived instances of the --- 'Down' newtype if the 'getDown' field were removed --- --- @since base-4.7.0.0 -instance (Show a) => Show (Down a) where - showsPrec d (Down x) = showParen (d > 10) $ - showString "Down " . showsPrec 11 x - --- | @since base-4.6.0.0 -instance Ord a => Ord (Down a) where - compare (Down x) (Down y) = y `compare` x - Down x < Down y = y < x - Down x > Down y = y > x - Down x <= Down y = y <= x - Down x >= Down y = y >= x - min (Down x) (Down y) = Down (max y x) - max (Down x) (Down y) = Down (min y x) - --- | Swaps @'minBound'@ and @'maxBound'@ of the underlying type. --- --- @since base-4.14.0.0 -instance Bounded a => Bounded (Down a) where - minBound = Down maxBound - maxBound = Down minBound - --- | Swaps @'succ'@ and @'pred'@ of the underlying type. --- --- @since base-4.18.0.0 -instance (Enum a, Bounded a, Eq a) => Enum (Down a) where - succ = fmap pred - pred = fmap succ - - -- Here we use the fact that 'comparing (complement @Int)' behaves - -- as an order-swapping `compare @Int`. - fromEnum = complement . fromEnum . getDown - toEnum = Down . toEnum . complement - - enumFrom (Down x) - | x == minBound - = [Down x] -- We can't rely on 'enumFromThen _ (pred @a minBound)` behaving nicely, - -- since 'enumFromThen _' might be strict and 'pred minBound' might throw - | otherwise - = coerce $ enumFromThen x (pred x) - enumFromThen (Down x) (Down y) = coerce $ enumFromThen x y - --- | @since base-4.11.0.0 -instance Functor Down where - fmap = coerce - --- | @since base-4.11.0.0 -instance Applicative Down where - pure = Down - (<*>) = coerce - --- | @since base-4.11.0.0 -instance Monad Down where - Down a >>= k = k a ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ord/Down.hs ===================================== @@ -0,0 +1,169 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Internal.Data.Ord.Down +-- Copyright : (c) The University of Glasgow 2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- Orderings +-- +----------------------------------------------------------------------------- + +module GHC.Internal.Data.Ord.Down ( + Down(..), + ) where + +import GHC.Internal.Data.Bits (Bits, FiniteBits, complement) +import GHC.Internal.Ix (Ix) +import GHC.Internal.Foreign.Storable (Storable) +import GHC.Internal.Base +import GHC.Internal.Enum (Bounded(..), Enum(..)) +import GHC.Internal.Float (Floating, RealFloat) +import GHC.Internal.Num +import GHC.Internal.Read +import GHC.Internal.Real (Fractional, Real, RealFrac) +import GHC.Internal.Show +import GHC.Internal.Generics +import GHC.Internal.Data.Foldable +import GHC.Internal.Data.Traversable +import GHC.Internal.Control.Monad.Zip + +-- $setup +-- >>> import Prelude + +-- | The 'Down' type allows you to reverse sort order conveniently. A value of type +-- @'Down' a@ contains a value of type @a@ (represented as @'Down' a@). +-- +-- If @a@ has an @'Ord'@ instance associated with it then comparing two +-- values thus wrapped will give you the opposite of their normal sort order. +-- This is particularly useful when sorting in generalised list comprehensions, +-- as in: @then sortWith by 'Down' x@. +-- +-- >>> compare True False +-- GT +-- +-- >>> compare (Down True) (Down False) +-- LT +-- +-- If @a@ has a @'Bounded'@ instance then the wrapped instance also respects +-- the reversed ordering by exchanging the values of @'minBound'@ and +-- @'maxBound'@. +-- +-- >>> minBound :: Int +-- -9223372036854775808 +-- +-- >>> minBound :: Down Int +-- Down 9223372036854775807 +-- +-- All other instances of @'Down' a@ behave as they do for @a@. +-- +-- @since base-4.6.0.0 +newtype Down a = Down + { getDown :: a -- ^ @since base-4.14.0.0 + } + deriving + ( Eq -- ^ @since base-4.6.0.0 + , Num -- ^ @since base-4.11.0.0 + , Semigroup -- ^ @since base-4.11.0.0 + , Monoid -- ^ @since base-4.11.0.0 + , Bits -- ^ @since base-4.14.0.0 + , FiniteBits -- ^ @since base-4.14.0.0 + , Floating -- ^ @since base-4.14.0.0 + , Fractional -- ^ @since base-4.14.0.0 + , Ix -- ^ @since base-4.14.0.0 + , Real -- ^ @since base-4.14.0.0 + , RealFrac -- ^ @since base-4.14.0.0 + , RealFloat -- ^ @since base-4.14.0.0 + , Storable -- ^ @since base-4.14.0.0 + , Generic -- ^ @since base-4.12.0.0 + ) + +-- | @since base-4.12.0.0 +deriving instance Generic1 Down + +-- | @since base-4.12.0.0 +deriving instance Foldable Down + +-- | @since base-4.12.0.0 +deriving instance Traversable Down + +-- | @since 4.12.0.0 +instance MonadZip Down where + mzipWith = liftM2 + +-- | This instance would be equivalent to the derived instances of the +-- 'Down' newtype if the 'getDown' field were removed +-- +-- @since base-4.7.0.0 +instance (Read a) => Read (Down a) where + readsPrec d = readParen (d > 10) $ \ r -> + [(Down x,t) | ("Down",s) <- lex r, (x,t) <- readsPrec 11 s] + +-- | This instance would be equivalent to the derived instances of the +-- 'Down' newtype if the 'getDown' field were removed +-- +-- @since base-4.7.0.0 +instance (Show a) => Show (Down a) where + showsPrec d (Down x) = showParen (d > 10) $ + showString "Down " . showsPrec 11 x + +-- | @since base-4.6.0.0 +instance Ord a => Ord (Down a) where + compare (Down x) (Down y) = y `compare` x + Down x < Down y = y < x + Down x > Down y = y > x + Down x <= Down y = y <= x + Down x >= Down y = y >= x + min (Down x) (Down y) = Down (max y x) + max (Down x) (Down y) = Down (min y x) + +-- | Swaps @'minBound'@ and @'maxBound'@ of the underlying type. +-- +-- @since base-4.14.0.0 +instance Bounded a => Bounded (Down a) where + minBound = Down maxBound + maxBound = Down minBound + +-- | Swaps @'succ'@ and @'pred'@ of the underlying type. +-- +-- @since base-4.18.0.0 +instance (Enum a, Bounded a, Eq a) => Enum (Down a) where + succ = fmap pred + pred = fmap succ + + -- Here we use the fact that 'comparing (complement @Int)' behaves + -- as an order-swapping `compare @Int`. + fromEnum = complement . fromEnum . getDown + toEnum = Down . toEnum . complement + + enumFrom (Down x) + | x == minBound + = [Down x] -- We can't rely on 'enumFromThen _ (pred @a minBound)` behaving nicely, + -- since 'enumFromThen _' might be strict and 'pred minBound' might throw + | otherwise + = coerce $ enumFromThen x (pred x) + enumFromThen (Down x) (Down y) = coerce $ enumFromThen x y + +-- | @since base-4.11.0.0 +instance Functor Down where + fmap = coerce + +-- | @since base-4.11.0.0 +instance Applicative Down where + pure = Down + (<*>) = coerce + +-- | @since base-4.11.0.0 +instance Monad Down where + Down a >>= k = k a ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs ===================================== @@ -46,7 +46,6 @@ import GHC.Internal.Data.Functor.Identity ( Identity(..) ) import GHC.Internal.Data.Functor.Utils ( StateL(..), StateR(..), StateT(..), (#.) ) import GHC.Internal.Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..), Alt(..), Ap(..) ) -import GHC.Internal.Data.Ord ( Down(..) ) import GHC.Internal.Data.Proxy ( Proxy(..) ) import GHC.Internal.Arr @@ -364,10 +363,6 @@ deriving instance Traversable UInt -- | @since base-4.9.0.0 deriving instance Traversable UWord --- Instance for Data.Ord --- | @since base-4.12.0.0 -deriving instance Traversable Down - -- general functions -- | 'for' is 'traverse' with its arguments flipped. For a version ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -318,7 +318,7 @@ import qualified GHC.Internal.Data.Coerce import GHC.Internal.Data.String import GHC.Internal.Data.OldList import GHC.Internal.Data.Data -import GHC.Internal.Data.Ord +import GHC.Internal.Data.Ord.Down import qualified GHC.Internal.Debug.Trace import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export ===================================== libraries/ghc-internal/src/GHC/Internal/Generics.hs ===================================== @@ -732,7 +732,6 @@ module GHC.Internal.Generics ( -- We use some base types import GHC.Internal.Data.Either ( Either (..) ) import GHC.Internal.Data.Maybe ( Maybe(..), fromMaybe ) -import GHC.Internal.Data.Ord ( Down(..) ) import GHC.Internal.Bignum.Integer ( Integer, integerToInt ) import GHC.Internal.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Internal.Ptr ( Ptr(..) ) @@ -1629,9 +1628,6 @@ deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n) -- | @since base-4.16.0.0 deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o) --- | @since base-4.12.0.0 -deriving instance Generic (Down a) - -- | @since base-4.15.0.0 deriving instance Generic SrcLoc @@ -1701,9 +1697,6 @@ deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) -- | @since base-4.16.0.0 deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) --- | @since base-4.12.0.0 -deriving instance Generic1 Down - -------------------------------------------------------------------------------- -- Copied from the singletons package -------------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2af36711d6167174c151c6a311ba0df8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2af36711d6167174c151c6a311ba0df8... You're receiving this email because of your account on gitlab.haskell.org.