diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 3c5f2b5..55d38b3 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20241021 +# version: 0.19.20241202 # -# REGENDATA ("0.19.20241021",["github","--config=cabal.haskell-ci","cabal.project"]) +# REGENDATA ("0.19.20241202",["github","--config=cabal.haskell-ci","cabal.project"]) # name: Haskell-CI on: @@ -28,6 +28,11 @@ jobs: strategy: matrix: include: + - compiler: ghc-9.12.0.20241128 + compilerKind: ghc + compilerVersion: 9.12.0.20241128 + setup-method: ghcup-prerelease + allow-failure: false - compiler: ghc-9.10.1 compilerKind: ghc compilerVersion: 9.10.1 @@ -90,41 +95,60 @@ jobs: allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev + - name: Install GHCup + run: | mkdir -p "$HOME/.ghcup/bin" curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + - name: Install cabal-install + run: | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} HCVER: ${{ matrix.compilerVersion }} - - name: Set PATH and environment variables + - name: Install GHC (GHCup prerelease) + if: matrix.setup-method == 'ghcup-prerelease' run: | - echo "$HOME/.cabal/bin" >> $GITHUB_PATH - echo "LANG=C.UTF-8" >> "$GITHUB_ENV" - echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" - echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER + "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -151,6 +175,18 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF + if $HEADHACKAGE; then + cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> cabal.project + fi $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(base-orphans)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local @@ -235,8 +274,8 @@ jobs: run: | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all - name: save cache - uses: actions/cache/save@v4 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store diff --git a/CHANGES.markdown b/CHANGES.markdown index f99a628..cb865d9 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,4 +1,9 @@ ## Changes in next [????.??.??] + - Backport new instances from GHC 9.12/`base-4.21`: + * `MonadFix` instance for `(,) a` + * `Eq1`, `Ord1`, `Read1`, and `Show1` instances for basic `GHC.Generics` + representation types + * `Show` instance for `UAddr` - Drop support for pre-8.0 versions of GHC. ## Changes in 0.9.2 [2024.04.30] diff --git a/README.markdown b/README.markdown index f4de810..268c383 100644 --- a/README.markdown +++ b/README.markdown @@ -60,6 +60,7 @@ To use `base-orphans`, simply `import Data.Orphans ()`. * `Eq` and `Ord` instances for `SChar`, `SNat`, and `SSymbol` * `Eq1`, `Read1`, and `Show1` instances for `Complex` * `Eq1`, `Ord1`, `Read1`, and `Show1` instances for `NonEmpty` + * `Eq1`, `Ord1`, `Read1`, and `Show1` instances for basic `GHC.Generics` representation types * `Enum`, `Bounded`, `Num`, `Real`, `Integral`, `Fractional`, `RealFrac`, `Floating`, and `RealFloat` instances for `Compose` * `Foldable` instance for `Either`, `(,)` and `Const` * `Foldable` and `Traversable` instances for `Alt` from `Data.Monoid` @@ -76,6 +77,7 @@ To use `base-orphans`, simply `import Data.Orphans ()`. * `Monad` instance for `(,)` * `Monad` instance for `WrappedMonad` * `MonadFail`, `Monoid`, and `Semigroup` instances for strict `ST` + * `MonadFix` instance for `(,) a` * `MonadFix` and `MonadZip` instances for `Complex` * `MonadZip` instance for `Maybe` * `Monoid`, `Eq`, `Ord`, `Read`, and `Show` instances for `Const` @@ -87,6 +89,7 @@ To use `base-orphans`, simply `import Data.Orphans ()`. `Monoid` instances for the same types (except `V1`). * `Semigroup` and `Monoid` instances for `Data.Functor.Product` and `Data.Functor.Compose` * `Show` instance for `Fingerprint` + * `Show` instance for `UAddr` * `Storable` instance for `()`, `Complex`, and `Ratio` * `TestEquality` instance for `Compose` * `Traversable` instance for `Either`, `(,)` and `Const` @@ -106,6 +109,7 @@ To use `base-orphans`, simply `import Data.Orphans ()`. ## Supported versions of GHC/`base` + * `ghc-9.12.*` / `base-4.21.*` * `ghc-9.10.*` / `base-4.20.*` * `ghc-9.8.*` / `base-4.19.*` * `ghc-9.6.*` / `base-4.18.*` diff --git a/base-orphans.cabal b/base-orphans.cabal index 852d11d..3344fc3 100644 --- a/base-orphans.cabal +++ b/base-orphans.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e780edc5dc880fffe83b74901fddf088070190f9ad366383292cb74d36ae668f +-- hash: 970bf80fafc189c3f60b26e4c6e2198e6314edf540a5f337edc0056110c41a30 name: base-orphans version: 0.9.2 @@ -36,7 +36,7 @@ license: MIT license-file: LICENSE build-type: Simple tested-with: - GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.6 , GHC == 9.8.2 , GHC == 9.10.1 + GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.6 , GHC == 9.8.2 , GHC == 9.10.1 , GHC == 9.12.1 extra-source-files: CHANGES.markdown README.markdown diff --git a/package.yaml b/package.yaml index b28e6e3..e2e7376 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ tested-with: GHC == 8.0.2 , GHC == 9.6.6 , GHC == 9.8.2 , GHC == 9.10.1 + , GHC == 9.12.1 extra-source-files: - CHANGES.markdown diff --git a/src/Data/Orphans.hs b/src/Data/Orphans.hs index 09c2c25..f3f1bfc 100644 --- a/src/Data/Orphans.hs +++ b/src/Data/Orphans.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} @@ -28,10 +29,6 @@ To use them, simply @import Data.Orphans ()@. -} module Data.Orphans () where -#if !(MIN_VERSION_base(4,12,0)) -import GHC.Generics as Generics hiding (prec) -#endif - #if !(MIN_VERSION_base(4,11,0)) import qualified Control.Monad.Fail as Fail (MonadFail(..)) #endif @@ -40,10 +37,6 @@ import qualified Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Functor.Product as Functor #endif -#if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,16,0)) -import GHC.Read (expectP, paren) -#endif - #if !(MIN_VERSION_base(4,10,0)) import Data.Data as Data #endif @@ -52,6 +45,10 @@ import Data.Data as Data import Control.Monad.ST as Strict #endif +#if MIN_VERSION_base(4,11,0) && !(MIN_VERSION_base(4,21,0)) +import GHC.Read (readField) +#endif + #if !(MIN_VERSION_base(4,12,0)) import qualified Data.Foldable as F (Foldable(..)) import qualified Data.Traversable as T (Traversable(..)) @@ -61,8 +58,9 @@ import qualified Data.Traversable as T (Traversable(..)) import GHC.Tuple (Solo(..)) #endif -#if !(MIN_VERSION_base(4,20,0)) +#if !(MIN_VERSION_base(4,21,0)) import Data.Orphans.Prelude +import GHC.Generics as Generics hiding (prec) #endif #include "HsBaseConfig.h" @@ -1150,3 +1148,374 @@ deriving instance (RealFrac (f (g a)), Ord1 f, Ord1 g, Ord a) => RealFrac (Compo deriving instance (RealFloat (f (g a)), Ord1 f, Ord1 g, Ord a) => RealFloat (Compose f g a) # endif #endif + +#if !(MIN_VERSION_base(4,21,0)) +instance Monoid a => MonadFix ((,) a) where + -- See the CLC proposal thread for discussion and proofs of the laws: https://github.com/haskell/core-libraries-committee/issues/238 + mfix f = let a = f (snd a) in a + +instance Eq1 V1 where + liftEq _ = \_ _ -> True + +instance Ord1 V1 where + liftCompare _ = \_ _ -> EQ + +instance Show1 V1 where + liftShowsPrec _ _ _ = \_ -> showString "V1" + +instance Read1 V1 where + liftReadsPrec _ _ = readPrec_to_S pfail + +# if MIN_VERSION_base(4,10,0) + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# endif + +instance Eq1 U1 where + liftEq _ = \_ _ -> True + +instance Ord1 U1 where + liftCompare _ = \_ _ -> EQ + +instance Show1 U1 where + liftShowsPrec _ _ _ = \U1 -> showString "U1" + +instance Read1 U1 where +# if MIN_VERSION_base(4,10,0) + liftReadPrec _ _ = + parens (expectP (Ident "U1") *> pure U1) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec _ _ = + readPrec_to_S $ + parens (expectP (Ident "U1") *> pure U1) +# endif + +instance Eq1 Par1 where + liftEq eq = \(Par1 a) (Par1 a') -> eq a a' + +instance Ord1 Par1 where + liftCompare cmp = \(Par1 a) (Par1 a') -> cmp a a' + +instance Show1 Par1 where + liftShowsPrec sp _ d = \(Par1 { unPar1 = a }) -> + showsSingleFieldRecordWith sp "Par1" "unPar1" d a + +instance Read1 Par1 where +# if MIN_VERSION_base(4,10,0) + liftReadPrec rp _ = + readSingleFieldRecordWith rp "Par1" "unPar1" Par1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec rp _ = + readPrec_to_S $ + readSingleFieldRecordWith (readS_to_Prec rp) "Par1" "unPar1" Par1 +# endif + +instance Eq1 f => Eq1 (Rec1 f) where + liftEq eq = \(Rec1 a) (Rec1 a') -> liftEq eq a a' + +instance Ord1 f => Ord1 (Rec1 f) where + liftCompare cmp = \(Rec1 a) (Rec1 a') -> liftCompare cmp a a' + +instance Show1 f => Show1 (Rec1 f) where + liftShowsPrec sp sl d = \(Rec1 { unRec1 = a }) -> + showsSingleFieldRecordWith (liftShowsPrec sp sl) "Rec1" "unRec1" d a + +instance Read1 f => Read1 (Rec1 f) where +# if MIN_VERSION_base(4,10,0) + liftReadPrec rp rl = + readSingleFieldRecordWith (liftReadPrec rp rl) "Rec1" "unRec1" Rec1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec rp rl = + readPrec_to_S $ + readSingleFieldRecordWith + (readS_to_Prec (liftReadsPrec rp rl)) + "Rec1" + "unRec1" + Rec1 +# endif + +instance Eq c => Eq1 (K1 i c) where + liftEq _ = \(K1 a) (K1 a') -> a == a' + +instance Ord c => Ord1 (K1 i c) where + liftCompare _ = \(K1 a) (K1 a') -> compare a a' + +instance Show c => Show1 (K1 i c) where + liftShowsPrec _ _ d = \(K1 { unK1 = a }) -> + showsSingleFieldRecordWith showsPrec "K1" "unK1" d a + +instance Read c => Read1 (K1 i c) where +# if MIN_VERSION_base(4,10,0) + liftReadPrec _ _ = readData $ + readSingleFieldRecordWith readPrec "K1" "unK1" K1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec _ _ = + readPrec_to_S $ + readData $ + readSingleFieldRecordWith readPrec "K1" "unK1" K1 +# endif + +instance Eq1 f => Eq1 (M1 i c f) where + liftEq eq = \(M1 a) (M1 a') -> liftEq eq a a' + +instance Ord1 f => Ord1 (M1 i c f) where + liftCompare cmp = \(M1 a) (M1 a') -> liftCompare cmp a a' + +instance Show1 f => Show1 (M1 i c f) where + liftShowsPrec sp sl d = \(M1 { unM1 = a }) -> + showsSingleFieldRecordWith (liftShowsPrec sp sl) "M1" "unM1" d a + +instance Read1 f => Read1 (M1 i c f) where +# if MIN_VERSION_base(4,10,0) + liftReadPrec rp rl = readData $ + readSingleFieldRecordWith (liftReadPrec rp rl) "M1" "unM1" M1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec rp rl = + readPrec_to_S $ + readData $ + readSingleFieldRecordWith + (readS_to_Prec (liftReadsPrec rp rl)) + "M1" + "unM1" + M1 +# endif + +instance (Eq1 f, Eq1 g) => Eq1 (f :+: g) where + liftEq eq = \lhs rhs -> case (lhs, rhs) of + (L1 a, L1 a') -> liftEq eq a a' + (R1 b, R1 b') -> liftEq eq b b' + _ -> False + +instance (Ord1 f, Ord1 g) => Ord1 (f :+: g) where + liftCompare cmp = \lhs rhs -> case (lhs, rhs) of + (L1 _, R1 _) -> LT + (R1 _, L1 _) -> GT + (L1 a, L1 a') -> liftCompare cmp a a' + (R1 b, R1 b') -> liftCompare cmp b b' + +instance (Show1 f, Show1 g) => Show1 (f :+: g) where + liftShowsPrec sp sl d = \x -> case x of + L1 a -> showsUnaryWith (liftShowsPrec sp sl) "L1" d a + R1 b -> showsUnaryWith (liftShowsPrec sp sl) "R1" d b + +instance (Read1 f, Read1 g) => Read1 (f :+: g) where +# if MIN_VERSION_base(4,10,0) + liftReadPrec rp rl = readData $ + readUnaryWith (liftReadPrec rp rl) "L1" L1 <|> + readUnaryWith (liftReadPrec rp rl) "R1" R1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec rp rl = + readPrec_to_S $ + readData $ + readUnaryWith (readS_to_Prec (liftReadsPrec rp rl)) "L1" L1 <|> + readUnaryWith (readS_to_Prec (liftReadsPrec rp rl)) "R1" R1 +# endif + +instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where + liftEq eq = \(f :*: g) (f' :*: g') -> liftEq eq f f' && liftEq eq g g' + +instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where + liftCompare cmp = \(f :*: g) (f' :*: g') -> liftCompare cmp f f' <> liftCompare cmp g g' + +instance (Show1 f, Show1 g) => Show1 (f :*: g) where + liftShowsPrec sp sl d = \(a :*: b) -> + showsBinaryOpWith + (liftShowsPrec sp sl) + (liftShowsPrec sp sl) + 7 + ":*:" + d + a + b + +instance (Read1 f, Read1 g) => Read1 (f :*: g) where +# if MIN_VERSION_base(4,10,0) + liftReadPrec rp rl = parens $ prec 6 $ + readBinaryOpWith (liftReadPrec rp rl) (liftReadPrec rp rl) ":*:" (:*:) + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec rp rl = + readPrec_to_S $ + parens $ prec 6 $ + readBinaryOpWith + (readS_to_Prec (liftReadsPrec rp rl)) + (readS_to_Prec (liftReadsPrec rp rl)) + ":*:" + (:*:) +# endif + +instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where + liftEq eq = \(Comp1 a) (Comp1 a') -> liftEq (liftEq eq) a a' + +instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where + liftCompare cmp = \(Comp1 a) (Comp1 a') -> liftCompare (liftCompare cmp) a a' + +instance (Show1 f, Show1 g) => Show1 (f :.: g) where + liftShowsPrec sp sl d = \(Comp1 { unComp1 = a }) -> + showsSingleFieldRecordWith + (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl)) + "Comp1" + "unComp1" + d + a + +instance (Read1 f, Read1 g) => Read1 (f :.: g) where +# if MIN_VERSION_base(4,10,0) + liftReadPrec rp rl = readData $ + readSingleFieldRecordWith + (liftReadPrec (liftReadPrec rp rl) (liftReadListPrec rp rl)) + "Comp1" + "unComp1" + Comp1 + + liftReadListPrec = liftReadListPrecDefault + liftReadList = liftReadListDefault +# else + liftReadsPrec rp rl = + readPrec_to_S $ + readData $ + readSingleFieldRecordWith + (readS_to_Prec (liftReadsPrec (liftReadsPrec rp rl) (liftReadList rp rl))) + "Comp1" + "unComp1" + Comp1 +# endif + +instance Eq1 UAddr where + -- NB cannot use eqAddr# because its module isn't safe + liftEq _ = \(UAddr a) (UAddr b) -> UAddr a == UAddr b + +instance Ord1 UAddr where + liftCompare _ = \(UAddr a) (UAddr b) -> compare (UAddr a) (UAddr b) + +instance Show1 UAddr where + liftShowsPrec _ _ = showsPrec + +-- NB no Read1 for URec (Ptr ()) because there's no Read for Ptr. + +instance Eq1 UChar where + liftEq _ = \(UChar a) (UChar b) -> UChar a == UChar b + +instance Ord1 UChar where + liftCompare _ = \(UChar a) (UChar b) -> compare (UChar a) (UChar b) + +instance Show1 UChar where + liftShowsPrec _ _ = showsPrec + +instance Eq1 UDouble where + liftEq _ = \(UDouble a) (UDouble b) -> UDouble a == UDouble b + +instance Ord1 UDouble where + liftCompare _ = \(UDouble a) (UDouble b) -> compare (UDouble a) (UDouble b) + +instance Show1 UDouble where + liftShowsPrec _ _ = showsPrec + +instance Eq1 UFloat where + liftEq _ = \(UFloat a) (UFloat b) -> UFloat a == UFloat b + +instance Ord1 UFloat where + liftCompare _ = \(UFloat a) (UFloat b) -> compare (UFloat a) (UFloat b) + +instance Show1 UFloat where + liftShowsPrec _ _ = showsPrec + +instance Eq1 UInt where + liftEq _ = \(UInt a) (UInt b) -> UInt a == UInt b + +instance Ord1 UInt where + liftCompare _ = \(UInt a) (UInt b) -> compare (UInt a) (UInt b) + +instance Show1 UInt where + liftShowsPrec _ _ = showsPrec + +instance Eq1 UWord where + liftEq _ = \(UWord a) (UWord b) -> UWord a == UWord b + +instance Ord1 UWord where + liftCompare _ = \(UWord a) (UWord b) -> compare (UWord a) (UWord b) + +instance Show1 UWord where + liftShowsPrec _ _ = showsPrec + +readSingleFieldRecordWith :: ReadPrec a -> String -> String -> (a -> t) -> ReadPrec t +readSingleFieldRecordWith rp name field cons = parens $ prec 11 $ do + expectP $ Ident name + expectP $ Punc "{" + x <- readField field $ reset rp + expectP $ Punc "}" + pure $ cons x + +readBinaryOpWith + :: ReadPrec a + -> ReadPrec b + -> String + -> (a -> b -> t) + -> ReadPrec t +readBinaryOpWith rp1 rp2 name cons = + cons <$> step rp1 <* expectP (Symbol name) <*> step rp2 + +# if !(MIN_VERSION_base(4,10,0)) +readData :: ReadPrec a -> ReadPrec a +readData reader = parens $ prec 10 reader + +readUnaryWith :: ReadPrec a -> String -> (a -> t) -> ReadPrec t +readUnaryWith rp name cons = do + expectP $ Ident name + x <- step rp + return $ cons x +# endif + +# if !(MIN_VERSION_base(4,11,0)) +readField :: String -> ReadPrec a -> ReadPrec a +readField fieldName readVal = do + expectP (Ident fieldName) + expectP (Punc "=") + readVal +{-# NOINLINE readField #-} +# endif + +showsSingleFieldRecordWith :: (Int -> a -> ShowS) -> String -> String -> Int -> a -> ShowS +showsSingleFieldRecordWith sp name field d x = + showParen (d > appPrec) $ + showString name . showString " {" . showString field . showString " = " . sp 0 x . showChar '}' + +showsBinaryOpWith + :: (Int -> a -> ShowS) + -> (Int -> b -> ShowS) + -> Int + -> String + -> Int + -> a + -> b + -> ShowS +showsBinaryOpWith sp1 sp2 opPrec name d x y = showParen (d >= opPrec) $ + sp1 opPrec x . showChar ' ' . showString name . showChar ' ' . sp2 opPrec y + +instance Show (UAddr p) where + -- This Show instance would be equivalent to what deriving Show would generate, + -- but because deriving Show doesn't support Addr# fields we define it manually. + showsPrec d (UAddr x) = + showParen (d > appPrec) + (\y -> showString "UAddr {uAddr# = " (showsPrec 0 (Ptr x) (showChar '}' y))) +#endif diff --git a/src/Data/Orphans/Prelude.hs b/src/Data/Orphans/Prelude.hs index d282bdf..57ee9aa 100644 --- a/src/Data/Orphans/Prelude.hs +++ b/src/Data/Orphans/Prelude.hs @@ -18,7 +18,7 @@ This makes it much easier to be -Wall-compliant. Note that this module does not export any modules that could introduce name clashes. -} module Data.Orphans.Prelude -#if MIN_VERSION_base(4,20,0) +#if MIN_VERSION_base(4,21,0) () where #else ( module OrphansPrelude @@ -73,7 +73,7 @@ import GHC.Arr as OrphansPrelude (Ix(..)) import GHC.Base as OrphansPrelude import GHC.Conc as OrphansPrelude import GHC.Desugar as OrphansPrelude (AnnotationWrapper) -import GHC.Exts as OrphansPrelude (IsList(..)) +import GHC.Exts as OrphansPrelude (IsList(..), Ptr(..)) import GHC.Fingerprint as OrphansPrelude import GHC.ForeignPtr as OrphansPrelude import GHC.GHCi as OrphansPrelude @@ -84,8 +84,10 @@ import GHC.IO.Encoding as OrphansPrelude import GHC.IO.Encoding.Failure as OrphansPrelude import GHC.IO.Handle as OrphansPrelude import GHC.IO.Handle.Types as OrphansPrelude +import GHC.Read as OrphansPrelude (expectP, paren) import GHC.Real as OrphansPrelude (Ratio(..), (%)) import GHC.ST as OrphansPrelude +import GHC.Show as OrphansPrelude (appPrec) import GHC.Stack as OrphansPrelude import GHC.Stats as OrphansPrelude import GHC.TypeLits as OrphansPrelude hiding (type (*))