diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,74 @@ +## 3.10 [2022.10.05] +* The instances in `TextShow.FromStringTextShow` module have been scaled back + somewhat for forward compatibility with Core Libraries proposal #10, which + will add quantified `Show` superclasses to `Show1` and `Show2`: + * `FromStringShow` and `FromTextShow` no longer have `Show1` or `TextShow1` + instances. If you want to derive instances of `Show1` or `TextShow1` via + a newtype, use `FromStringShow1` or `FromTextShow1` instead. + * The `Show` instances for `FromTextShow1` and `FromTextShow2` have had their + instance contexts changed to accommodate the new superclasses in `Show1` + and `Show2`: + + ```diff + -instance (TextShow1 f, TextShow a) => Show (FromTextShow1 f a) + +instance (TextShow1 f, Show a) => Show (FromTextShow1 f a) + + -instance (TextShow2 f, TextShow a, TextShow b) => Show (FromTextShow2 f a b) + +instance (TextShow2 f, Show a, Show b) => Show (FromTextShow2 f a b) + ``` + + While these instances do technically work, they are probably not what you + would have in mind if you wanted to derive a `Show` instance purely in + terms of `TextShow` classes. For this reason, if you want to derive an + instance of `Show` via a newtype, use `FromTextShow` instead. + * By similar reasoning, the `Show1` instance for `FromTextShow2` has had its + instance context changed: + + ```diff + -instance (TextShow2 f, TextShow a) => Show1 (FromTextShow2 f a) + +instance (TextShow2 f, Show a) => Show1 (FromTextShow2 f a) + ``` + * By similar reasoning, the `TextShow` instances for `FromStringShow1` and + `FromStringShow2`, as well as the `TextShow1` instance for + `FromStringShow2`, have had their instance contexts changed: + + ```diff + -instance (Show1 f, Show a) => TextShow (FromStringShow1 f a) + +instance (Show1 f, TextShow a) => TextShow (FromStringShow1 f a) + + -instance (Show2 f, Show a, Show b) => TextShow (FromStringShow2 f a b) + +instance (Show2 f, TextShow a, TextShow b) => TextShow (FromStringShow2 f a b) + + -instance (Show2 f, Show a) => TextShow1 (FromStringShow2 f a) + +instance (Show2 f, TextShow a) => TextShow1 (FromStringShow2 f a) + ``` +* The `TextShow{1,2}` classes now have quantified superclasses: + + ```hs + class (forall a. TextShow a => TextShow (f a)) => TextShow1 f where ... + class (forall a. TextShow a => TextShow1 (f a)) => TextShow2 f where ... + ``` + + This mirrors corresponding changes made to `Show1` and `Show2` in the `base` + library. See https://github.com/haskell/core-libraries-committee/issues/10. + + Because of this change, any code that defines a `TextShow1` instance for a + data type without a corresponding `TextShow` instance will no longer compile, + so you may need to define more `TextShow` instances to adapt to this change. + Similarly, `TextShow2` instances will now also require corresponding + `TextShow` and `TextShow1` instances. +* The `GTextShow*` classes in `TextShow.Generic`, which power generic + derivation of `TextShow` and `TextShow1` instances, have been split up to + facilitate the addition of a quantified superclass to `TextShow1`. Moreover, + the `ShowFuns*` data types, the `Zero` data type, and the `One data type have + been removed, as they are no longer necessary in light of this split. + + Although this is a breaking API change, the changes should be invisible to + most users of the module, especially if your code only uses it to derive + `TextShow{,1}` instances. +* Add a `TextShow` instance for `ByteArray` from `Data.Array.Byte` when + building with `base-4.17.0.0` or later. + ### 3.9.7 [2022.05.28] * Allow the test suite to build with GHC 9.4. * Allow building with `transformers-0.6.*`. diff --git a/src/TextShow/Classes.hs b/src/TextShow/Classes.hs --- a/src/TextShow/Classes.hs +++ b/src/TextShow/Classes.hs @@ -2,6 +2,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} + +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + {-| Module: TextShow.Classes Copyright: (C) 2014-2017 Ryan Scott @@ -392,7 +397,11 @@ -- | Lifting of the 'TextShow' class to unary type constructors. -- -- /Since: 2/ -class TextShow1 f where +class +#if __GLASGOW_HASKELL__ >= 806 + (forall a. TextShow a => TextShow (f a)) => +#endif + TextShow1 f where -- | 'showbPrec' function for an application of the type constructor -- based on 'showbPrec' and 'showbList' functions for the argument type. -- @@ -457,7 +466,21 @@ -- | Lifting of the 'TextShow' class to binary type constructors. -- -- /Since: 2/ -class TextShow2 f where +class +#if __GLASGOW_HASKELL__ >= 806 + ( forall a. TextShow a => TextShow1 (f a) +# if __GLASGOW_HASKELL__ < 900 + -- Sadly, pre-9.0 versions of GHC have difficulty inferring this + -- superclass from the one above due to + -- https://gitlab.haskell.org/ghc/ghc/-/issues/17202. + -- As a workaround, we manually expand the superclass above to assist + -- type inference. Without doing this, the text-show test suite would + -- not compile on pre-9.0 versions of GHC. + , forall a b. (TextShow a, TextShow b) => TextShow (f a b) +# endif + ) => +#endif + TextShow2 f where -- | 'showbPrec' function for an application of the type constructor -- based on 'showbPrec' and 'showbList' functions for the argument types. -- diff --git a/src/TextShow/Data/Array/Byte.hs b/src/TextShow/Data/Array/Byte.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Data/Array/Byte.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: TextShow.Data.Array.Byte +Copyright: (C) 2022 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Provides a 'TextShow' instance for 'ByteArray' from the "Data.Array.Byte" +module. Only provided if using @base-4.17.0.0@ or later. + +/Since: 3.10/ +-} +module TextShow.Data.Array.Byte () where + +#if MIN_VERSION_base(4,17,0) +import Data.Array.Byte (ByteArray(..)) +import Data.Bits (Bits(..)) +import Data.Char (intToDigit) +import Data.Text.Lazy.Builder (Builder, fromString, singleton) + +import GHC.Exts (Int(..), indexWord8Array#, sizeofByteArray#) +import GHC.Word (Word8(..)) + +import Prelude () +import Prelude.Compat + +import TextShow.Classes (TextShow(..)) + +-- | /Since: 3.10/ +instance TextShow ByteArray where + showbPrec _ ba = + fromString "[" <> go 0 + where + showW8 :: Word8 -> Builder + showW8 !w = + singleton '0' + <> singleton 'x' + <> singleton (intToDigit (fromIntegral (unsafeShiftR w 4))) + <> singleton (intToDigit (fromIntegral (w .&. 0x0F))) + go i + | i < sizeofByteArray ba = comma <> showW8 (indexByteArray ba i :: Word8) <> go (i+1) + | otherwise = singleton ']' + where + comma | i == 0 = mempty + | otherwise = fromString ", " + +-- | Read byte at specific index. +indexByteArray :: ByteArray -> Int -> Word8 +{-# INLINE indexByteArray #-} +indexByteArray (ByteArray arr#) (I# i#) = W8# (indexWord8Array# arr# i#) + +-- | Size of the byte array in bytes. +sizeofByteArray :: ByteArray -> Int +{-# INLINE sizeofByteArray #-} +sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) +#endif diff --git a/src/TextShow/Debug/Trace/Generic.hs b/src/TextShow/Debug/Trace/Generic.hs --- a/src/TextShow/Debug/Trace/Generic.hs +++ b/src/TextShow/Debug/Trace/Generic.hs @@ -25,22 +25,22 @@ import Prelude.Compat import TextShow.Debug.Trace -import TextShow.Generic (GTextShowT, Zero, genericShowt) +import TextShow.Generic (GTextShowT, genericShowt) -- | A 'Generic' implementation of 'traceTextShow'. -- -- /Since: 2/ -genericTraceTextShow :: (Generic a, GTextShowT Zero (Rep a)) => a -> b -> b +genericTraceTextShow :: (Generic a, GTextShowT (Rep a ())) => a -> b -> b genericTraceTextShow = tracet . genericShowt -- | A 'Generic' implementation of 'traceTextShowId'. -- -- /Since: 2/ -genericTraceTextShowId :: (Generic a, GTextShowT Zero (Rep a)) => a -> a +genericTraceTextShowId :: (Generic a, GTextShowT (Rep a ())) => a -> a genericTraceTextShowId a = tracet (genericShowt a) a -- | A 'Generic' implementation of 'traceShowM'. -- -- /Since: 2/ -genericTraceTextShowM :: (Generic a, GTextShowT Zero (Rep a), Applicative f) => a -> f () +genericTraceTextShowM :: (Generic a, GTextShowT (Rep a ()), Applicative f) => a -> f () genericTraceTextShowM = tracetM . genericShowt diff --git a/src/TextShow/FromStringTextShow.hs b/src/TextShow/FromStringTextShow.hs --- a/src/TextShow/FromStringTextShow.hs +++ b/src/TextShow/FromStringTextShow.hs @@ -45,7 +45,7 @@ deriveBitraversable) import Data.Coerce (coerce) import Data.Data (Data, Typeable) -import Data.Functor.Classes (Show1(..)) +import Data.Functor.Classes (Show1(..), showsPrec1) #if !defined(__LANGUAGE_DERIVE_GENERIC1__) import qualified Generics.Deriving.TH as Generics @@ -67,7 +67,7 @@ showbToShows, showsToShowb) #if defined(NEW_FUNCTOR_CLASSES) -import Data.Functor.Classes (Show2(..), showsPrec1, showsPrec2) +import Data.Functor.Classes (Show2(..), showsPrec2) #else import Text.Show (showListWith) #endif @@ -114,26 +114,6 @@ show = coerce (show :: a -> String) showList = coerce (showList :: [a] -> ShowS) -instance Show1 FromStringShow where -#if defined(NEW_FUNCTOR_CLASSES) - liftShowList _ sl = sl . coerceList - where - coerceList :: [FromStringShow a] -> [a] - coerceList = coerce - liftShowsPrec sp _ p = sp p . fromStringShow -#else - showsPrec1 p = showsPrec p . fromStringShow -#endif - -instance TextShow1 FromStringShow where - liftShowbPrec sp' _ p = - showsPrecToShowbPrec (showbPrecToShowsPrec sp') p . fromStringShow - - liftShowbList _ sl' = showsToShowb (showbToShows sl') . coerceList - where - coerceList :: [FromStringShow a] -> [a] - coerceList = coerce - ------------------------------------------------------------------------------- -- | An adapter newtype, suitable for @DerivingVia@. @@ -172,27 +152,6 @@ show (FromTextShow x) = showbToShows showb x "" showList l = showbToShows showbList (coerce l :: [a]) -instance Show1 FromTextShow where -#if defined(NEW_FUNCTOR_CLASSES) - liftShowList _ sl = showbToShows (showsToShowb sl) . coerceList - where - coerceList :: [FromTextShow a] -> [a] - coerceList = coerce - liftShowsPrec sp _ p - = showbPrecToShowsPrec (showsPrecToShowbPrec sp) p . fromTextShow -#else - showsPrec1 p - = showbPrecToShowsPrec (showsPrecToShowbPrec showsPrec) p . fromTextShow -#endif - -instance TextShow1 FromTextShow where - liftShowbPrec sp' _ p = sp' p . fromTextShow - - liftShowbList _ sl' = sl' . coerceList - where - coerceList :: [FromTextShow a] -> [a] - coerceList = coerce - ------------------------------------------------------------------------------- -- | An adapter newtype, suitable for @DerivingVia@. @@ -244,11 +203,14 @@ #if defined(NEW_FUNCTOR_CLASSES) -- | Not available if using @transformers-0.4@ -instance (Show1 f, Show a) => TextShow (FromStringShow1 f a) where - showbPrec = liftShowbPrec (showsPrecToShowbPrec showsPrec) - (showsToShowb showList) - showbList = liftShowbList (showsPrecToShowbPrec showsPrec) - (showsToShowb showList) +-- +-- This instance is somewhat strange, as its instance context mixes a +-- 'Show1' constraint with a 'TextShow' constraint. This is done for +-- consistency with the 'Show' instance for 'FromTextShow1', which mixes +-- constraints in a similar way to satisfy superclass constraints. See the +-- Haddocks on the 'Show' instance for 'FromTextShow1' for more details. +instance (Show1 f, TextShow a) => TextShow (FromStringShow1 f a) where + showbPrec = showbPrec1 -- | Not available if using @transformers-0.4@ instance Show1 f => TextShow1 (FromStringShow1 f) where @@ -318,11 +280,19 @@ #if defined(NEW_FUNCTOR_CLASSES) -- | Not available if using @transformers-0.4@ -instance (TextShow1 f, TextShow a) => Show (FromTextShow1 f a) where - showsPrec = liftShowsPrec (showbPrecToShowsPrec showbPrec) - (showbToShows showbList) - showList = liftShowList (showbPrecToShowsPrec showbPrec) - (showbToShows showbList) +-- +-- This instance is somewhat strange, as its instance context mixes a +-- 'TextShow1' constraint with a 'Show' constraint. The 'Show' constraint is +-- necessary to satisfy the quantified 'Show' superclass in 'Show1'. Really, +-- the 'Show' constraint ought to be a 'TextShow' constraint instead, but GHC +-- has no way of knowing that the 'TextShow' constraint can be converted to a +-- 'Show' constraint when checking superclasses. +-- +-- This is all to say: this instance is almost surely not what you want if you +-- are looking to derive a 'Show' instance only via 'TextShow'-related +-- classes. If you wish to do this, derive via 'FromTextShow' instead. +instance (TextShow1 f, Show a) => Show (FromTextShow1 f a) where + showsPrec = showsPrec1 #endif instance TextShow1 f => Show1 (FromTextShow1 f) where @@ -399,18 +369,25 @@ deriving instance Show2 f => Show2 (FromStringShow2 f) -- | Not available if using @transformers-0.4@ -instance (Show2 f, Show a, Show b) => TextShow (FromStringShow2 f a b) where - showbPrec = liftShowbPrec (showsPrecToShowbPrec showsPrec) - (showsToShowb showList) - showbList = liftShowbList (showsPrecToShowbPrec showsPrec) - (showsToShowb showList) +-- +-- This instance is somewhat strange, as its instance context mixes a +-- 'Show2' constraint with 'TextShow' constraints. This is done for consistency +-- with the 'Show' instance for 'FromTextShow2', which mixes constraints in a +-- similar way to satisfy superclass constraints. See the Haddocks on the +-- 'Show' instance for 'FromTextShow2' for more details. +instance (Show2 f, TextShow a, TextShow b) => TextShow (FromStringShow2 f a b) where + showbPrec = showbPrec2 -- | Not available if using @transformers-0.4@ -instance (Show2 f, Show a) => TextShow1 (FromStringShow2 f a) where - liftShowbPrec = liftShowbPrec2 (showsPrecToShowbPrec showsPrec) - (showsToShowb showList) - liftShowbList = liftShowbList2 (showsPrecToShowbPrec showsPrec) - (showsToShowb showList) +-- +-- This instance is somewhat strange, as its instance context mixes a +-- 'Show2' constraint with a 'TextShow' constraint. This is done for +-- consistency with the 'Show1' instance for 'FromTextShow2', which mixes +-- constraints in a similar way to satisfy superclass constraints. See the +-- Haddocks on the 'Show1' instance for 'FromTextShow2' for more details. +instance (Show2 f, TextShow a) => TextShow1 (FromStringShow2 f a) where + liftShowbPrec = liftShowbPrec2 showbPrec showbList + liftShowbList = liftShowbList2 showbPrec showbList -- | Not available if using @transformers-0.4@ instance Show2 f => TextShow2 (FromStringShow2 f) where @@ -492,18 +469,35 @@ #if defined(NEW_FUNCTOR_CLASSES) -- | Not available if using @transformers-0.4@ -instance (TextShow2 f, TextShow a, TextShow b) => Show (FromTextShow2 f a b) where - showsPrec = liftShowsPrec (showbPrecToShowsPrec showbPrec) - (showbToShows showbList) - showList = liftShowList (showbPrecToShowsPrec showbPrec) - (showbToShows showbList) +-- +-- This instance is somewhat strange, as its instance context mixes a +-- 'TextShow2' constraint with 'Show' constraints. The 'Show' constraints are +-- necessary to satisfy the quantified 'Show' superclass in 'Show2'. Really, +-- the 'Show' constraints ought to be 'TextShow' constraints instead, but GHC +-- has no way of knowing that the 'TextShow' constraints can be converted to +-- 'Show' constraints when checking superclasses. +-- +-- This is all to say: this instance is almost surely not what you want if you +-- are looking to derive a 'Show' instance only via 'TextShow'-related +-- classes. If you wish to do this, derive via 'FromTextShow' instead. +instance (TextShow2 f, Show a, Show b) => Show (FromTextShow2 f a b) where + showsPrec = showsPrec2 -- | Not available if using @transformers-0.4@ -instance (TextShow2 f, TextShow a) => Show1 (FromTextShow2 f a) where - liftShowsPrec = liftShowsPrec2 (showbPrecToShowsPrec showbPrec) - (showbToShows showbList) - liftShowList = liftShowList2 (showbPrecToShowsPrec showbPrec) - (showbToShows showbList) +-- +-- This instance is somewhat strange, as its instance context mixes a +-- 'TextShow2' constraint with a 'Show' constraint. The 'Show' constraint is +-- necessary to satisfy the quantified 'Show' superclass in 'Show2'. Really, +-- the 'Show' constraint ought to be a 'TextShow' constraint instead, but GHC +-- has no way of knowing that the 'TextShow' constraint can be converted to a +-- 'Show' constraint when checking superclasses. +-- +-- This is all to say: this instance is almost surely not what you want if you +-- are looking to derive a 'Show1' instance only via 'TextShow'-related +-- classes. If you wish to do this, derive via 'FromTextShow1' instead. +instance (TextShow2 f, Show a) => Show1 (FromTextShow2 f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + liftShowList = liftShowList2 showsPrec showList -- | Not available if using @transformers-0.4@ instance TextShow2 f => Show2 (FromTextShow2 f) where diff --git a/src/TextShow/Generic.hs b/src/TextShow/Generic.hs --- a/src/TextShow/Generic.hs +++ b/src/TextShow/Generic.hs @@ -24,9 +24,13 @@ {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveLift #-} #endif +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif + {-| Module: TextShow.Generic Copyright: (C) 2014-2017 Ryan Scott @@ -51,9 +55,6 @@ -- * Generic @show@ functions -- $generics - - -- ** Understanding a compiler error - -- $generic_err , genericShowt , genericShowtl , genericShowtPrec @@ -73,24 +74,24 @@ -- ** 'Builder' , GTextShowB(..) , GTextShowConB(..) - , ShowFunsB(..) + , GTextShowB1(..) + , GTextShowConB1(..) -- ** Strict 'TS.Text' , GTextShowT(..) , GTextShowConT(..) - , ShowFunsT(..) + , GTextShowT1(..) + , GTextShowConT1(..) -- ** Lazy 'TL.Text' , GTextShowTL(..) , GTextShowConTL(..) - , ShowFunsTL(..) + , GTextShowTL1(..) + , GTextShowConTL1(..) -- ** Other internals , IsNullary(..) , ConType(..) - , Zero - , One ) where import Data.Data (Data, Typeable) -import Data.Functor.Contravariant.Compat (Contravariant(..)) import qualified Data.Text as TS (Text, pack, singleton) import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) import qualified Data.Text.Lazy as TL (Text, pack, singleton) @@ -152,30 +153,6 @@ @ -} -{- $generic_err - -Suppose you intend to define a 'TextShow' instance via 'FromGeneric': - -@ -data Oops = Oops - deriving 'TextShow' via 'FromGeneric' Oops - -- forgot to add \"deriving Generic\" here! -@ - -If you forget to add a @deriving 'Generic'@ clause to your data type, at -compile-time, you might get an error message that begins roughly as follows: - -@ -No instance for ('GTextShowB' 'Zero' ('Rep' Oops)) -@ - -This error can be confusing, but don't let it intimidate you. The correct fix is -simply to add the missing \"@deriving 'Generic'@\" clause. - -Similarly, if the compiler complains about not having an instance for @('GTextShowB' -'One' ('Rep1' Oops1))@, add a \"@deriving 'Generic1'@\" clause. --} - -- | An adapter newtype, suitable for @DerivingVia@. -- The 'TextShow' instance for 'FromGeneric' leverages a 'Generic'-based -- default. That is, @@ -203,7 +180,7 @@ ) -- | /Since: 3.7.4/ -instance (Generic a, GTextShowB Zero (Rep a)) => TextShow (FromGeneric a) where +instance (Generic a, GTextShowB (Rep a ())) => TextShow (FromGeneric a) where showbPrec p = genericShowbPrec p . fromGeneric -- | An adapter newtype, suitable for @DerivingVia@. @@ -236,106 +213,123 @@ deriving instance ( Data (f a), Typeable f, Typeable a ) => Data (FromGeneric1 f (a :: *)) +-- | /Since: 3.10/ +instance (Generic1 f, GTextShowB (Rep1 f a)) => TextShow (FromGeneric1 f a) where + showbPrec p = gShowbPrec p . from1 . fromGeneric1 + -- | /Since: 3.7.4/ -instance (Generic1 f, GTextShowB One (Rep1 f)) => TextShow1 (FromGeneric1 f) where +instance ( Generic1 f, GTextShowB1 (Rep1 f) +#if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ < 902 + -- Unfortunately, the quantified superclass for GTextShowB1 doesn't + -- work on pre-9.2 versions of GHC, perhaps due to + -- https://gitlab.haskell.org/ghc/ghc/-/issues/14860#note_454218. + -- Fortunately, we can make GHC come to its senses by using an + -- equality constraint. + , g ~ Rep1 f, forall a. TextShow a => GTextShowB (g a) +#endif + ) => TextShow1 (FromGeneric1 f) where liftShowbPrec sp sl p = genericLiftShowbPrec sp sl p . fromGeneric1 -- | A 'Generic' implementation of 'showt'. -- -- /Since: 2/ -genericShowt :: (Generic a, GTextShowT Zero (Rep a)) => a -> TS.Text +genericShowt :: (Generic a, GTextShowT (Rep a ())) => a -> TS.Text genericShowt = genericShowtPrec 0 -- | A 'Generic' implementation of 'showtl'. -- -- /Since: 2/ -genericShowtl :: (Generic a, GTextShowTL Zero (Rep a)) => a -> TL.Text +genericShowtl :: (Generic a, GTextShowTL (Rep a ())) => a -> TL.Text genericShowtl = genericShowtlPrec 0 -- | A 'Generic' implementation of 'showPrect'. -- -- /Since: 2/ -genericShowtPrec :: (Generic a, GTextShowT Zero (Rep a)) => Int -> a -> TS.Text -genericShowtPrec p = gShowtPrec NoShowFunsT p . from +genericShowtPrec :: (Generic a, GTextShowT (Rep a ())) => Int -> a -> TS.Text +genericShowtPrec p = gShowtPrec p . fromRepUnit -- | A 'Generic' implementation of 'showtlPrec'. -- -- /Since: 2/ -genericShowtlPrec :: (Generic a, GTextShowTL Zero (Rep a)) => Int -> a -> TL.Text -genericShowtlPrec p = gShowtlPrec NoShowFunsTL p . from +genericShowtlPrec :: (Generic a, GTextShowTL (Rep a ())) => Int -> a -> TL.Text +genericShowtlPrec p = gShowtlPrec p . fromRepUnit -- | A 'Generic' implementation of 'showtList'. -- -- /Since: 2/ -genericShowtList :: (Generic a, GTextShowT Zero (Rep a)) => [a] -> TS.Text +genericShowtList :: (Generic a, GTextShowT (Rep a ())) => [a] -> TS.Text genericShowtList = showtListWith genericShowt -- | A 'Generic' implementation of 'showtlList'. -- -- /Since: 2/ -genericShowtlList :: (Generic a, GTextShowTL Zero (Rep a)) => [a] -> TL.Text +genericShowtlList :: (Generic a, GTextShowTL (Rep a ())) => [a] -> TL.Text genericShowtlList = showtlListWith genericShowtl -- | A 'Generic' implementation of 'showb'. -- -- /Since: 2/ -genericShowb :: (Generic a, GTextShowB Zero (Rep a)) => a -> Builder +genericShowb :: (Generic a, GTextShowB (Rep a ())) => a -> Builder genericShowb = genericShowbPrec 0 -- | A 'Generic' implementation of 'showbPrec'. -- -- /Since: 2/ -genericShowbPrec :: (Generic a, GTextShowB Zero (Rep a)) => Int -> a -> Builder -genericShowbPrec p = gShowbPrec NoShowFunsB p . from +genericShowbPrec :: (Generic a, GTextShowB (Rep a ())) => Int -> a -> Builder +genericShowbPrec p = gShowbPrec p . fromRepUnit -- | A 'Generic' implementation of 'showbList'. -- -- /Since: 2/ -genericShowbList :: (Generic a, GTextShowB Zero (Rep a)) => [a] -> Builder +genericShowbList :: (Generic a, GTextShowB (Rep a ())) => [a] -> Builder genericShowbList = showbListWith genericShowb -- | A 'Generic' implementation of 'printT'. -- -- /Since: 2/ -genericPrintT :: (Generic a, GTextShowT Zero (Rep a)) => a -> IO () +genericPrintT :: (Generic a, GTextShowT (Rep a ())) => a -> IO () genericPrintT = TS.putStrLn . genericShowt -- | A 'Generic' implementation of 'printTL'. -- -- /Since: 2/ -genericPrintTL :: (Generic a, GTextShowTL Zero (Rep a)) => a -> IO () +genericPrintTL :: (Generic a, GTextShowTL (Rep a ())) => a -> IO () genericPrintTL = TL.putStrLn . genericShowtl -- | A 'Generic' implementation of 'hPrintT'. -- -- /Since: 2/ -genericHPrintT :: (Generic a, GTextShowT Zero (Rep a)) => Handle -> a -> IO () +genericHPrintT :: (Generic a, GTextShowT (Rep a ())) => Handle -> a -> IO () genericHPrintT h = TS.hPutStrLn h . genericShowt -- | A 'Generic' implementation of 'hPrintTL'. -- -- /Since: 2/ -genericHPrintTL :: (Generic a, GTextShowTL Zero (Rep a)) => Handle -> a -> IO () +genericHPrintTL :: (Generic a, GTextShowTL (Rep a ())) => Handle -> a -> IO () genericHPrintTL h = TL.hPutStrLn h . genericShowtl -- | A 'Generic1' implementation of 'genericLiftShowbPrec'. -- -- /Since: 2/ -genericLiftShowbPrec :: (Generic1 f, GTextShowB One (Rep1 f)) +genericLiftShowbPrec :: (Generic1 f, GTextShowB1 (Rep1 f)) => (Int -> a -> Builder) -> ([a] -> Builder) -> Int -> f a -> Builder -genericLiftShowbPrec sp sl p = gShowbPrec (Show1FunsB sp sl) p . from1 +genericLiftShowbPrec sp sl p = gLiftShowbPrec sp sl p . from1 -- | A 'Generic'/'Generic1' implementation of 'showbPrec1'. -- -- /Since: 2/ genericShowbPrec1 :: ( Generic a, Generic1 f - , GTextShowB Zero (Rep a) - , GTextShowB One (Rep1 f) + , GTextShowB (Rep a ()) + , GTextShowB1 (Rep1 f) ) => Int -> f a -> Builder genericShowbPrec1 = genericLiftShowbPrec genericShowbPrec genericShowbList +-- | A type-specialized version of 'from' used to assist type inference. +fromRepUnit :: Generic a => a -> Rep a () +fromRepUnit = from + ------------------------------------------------------------------------------- -- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'), @@ -355,16 +349,6 @@ #endif ) --- | A type-level indicator that 'TextShow' is being derived generically. --- --- /Since: 3.2/ -data Zero - --- | A type-level indicator that 'TextShow1' is being derived generically. --- --- /Since: 3.2/ -data One - {- I'm not particularly proud of the code below. The issue is that we need to be able to generically work over Builders, strict Text, and lazy Text. We could just work @@ -381,217 +365,350 @@ See #33. -} +hashPrec :: Int -> Int #if __GLASGOW_HASKELL__ >= 711 -#define HASH_FUNS(text_type,one_hash,two_hash,hash_prec,from_char,from_string) \ +hashPrec = const 0 +#else +hashPrec = id +#endif + +#if __GLASGOW_HASKELL__ >= 711 +#define HASH_FUNS(text_type,one_hash,two_hash,from_char,from_string) \ one_hash, two_hash :: text_type; \ -hash_prec :: Int -> Int; \ one_hash = from_char '#'; \ -two_hash = from_string "##"; \ -hash_prec = const 0 +two_hash = from_string "##"; #else -#define HASH_FUNS(text_type,one_hash,two_hash,hash_prec,from_char,from_string) \ +#define HASH_FUNS(text_type,one_hash,two_hash,from_char,from_string) \ one_hash, two_hash :: text_type; \ -hash_prec :: Int -> Int; \ one_hash = mempty; \ -two_hash = mempty; \ -hash_prec = id +two_hash = mempty; #endif -#define GTEXT_SHOW(text_type,show_funs,no_show_funs,show1_funs,one_hash,two_hash,hash_prec,gtext_show,gshow_prec,gtext_show_con,gshow_prec_con,show_prec,lift_show_prec,show_space,show_paren,show_list_with,from_char,from_string) \ -{- | A 'show_funs' value either stores nothing (for 'TextShow') or it stores \ -the two function arguments that show occurrences of the type parameter (for \ -'TextShow1'). \ +-- For some mysterious reason, attaching INLINE pragmas to things in this +-- module causes GHC 8.10's simplifier to absolutely explode in terms of +-- compile times. This also affects 9.0, 8.8, and older versions of GHC to +-- varying degrees, usually adding a couple of minutes or more to the overall +-- compile times. +-- +-- We'd still like to include the INLINE pragmas on 9.2 or later, however, as +-- it delivers a modest but measurable performance boost in the benchmark suite. +-- As a compromise, we use CPP to only attach INLINE annotations on 9.2 or +-- later. +#if __GLASGOW_HASKELL__ >= 902 +#define INLINE_GE_902(f) {-# INLINE f #-}; +#else +#define INLINE_GE_902(f) +#endif + +#if __GLASGOW_HASKELL__ >= 806 +#define QUANTIFIED_SUPERCLASS(class_name,f) (forall a. TextShow a => class_name (f a)) => +#else +#define QUANTIFIED_SUPERCLASS(class_name,f) +#endif + +#define GTEXT_SHOW(text_type,show_funs,one_hash,two_hash,gtext_show,gtext_show1,gshow_prec,glift_show_prec,gtext_show_con,gtext_show_con1,gshow_prec_con,glift_show_prec_con,show_prec,lift_show_prec,show_space,show_paren,show_list,show_list_with,from_char,from_string,c1_show_prec,s1_show_prec,product_show_prec,u_char_show_prec,u_double_show_prec,u_float_show_prec,u_int_show_prec,u_word_show_prec) \ +{- | Class of generic representation types that can be converted to a \ +'text_type'. \ \ -/Since: 3.4/ \ +/Since: 3.10/ \ -}; \ -data show_funs arity a where { \ - no_show_funs :: show_funs Zero a \ - ; show1_funs :: (Int -> a -> text_type) -> ([a] -> text_type) -> show_funs One a \ - } deriving Typeable; \ +class gtext_show a where { \ + ; gshow_prec :: Int -> a -> text_type \ +}; \ +deriving instance Typeable gtext_show; \ \ -instance Contravariant (show_funs arity) where { \ - contramap _ no_show_funs = no_show_funs \ - ; contramap f (show1_funs sp sl) = show1_funs (\p -> sp p . f) (sl . map f) \ - }; \ +instance gtext_show (f p) => gtext_show (D1 d f p) where { \ + ; gshow_prec p (M1 x) = gshow_prec p x \ +}; \ \ -{- | Class of generic representation types that can be converted to \ -a 'text_type'. The @arity@ type variable indicates which type class is \ -used. @'gtext_show' 'Zero'@ indicates 'TextShow' behavior, and \ -@'gtext_show' 'One'@ indicates 'TextShow1' behavior. \ +instance gtext_show (V1 p) where { \ + ; gshow_prec _ x = case x of {} \ +}; \ \ -/Since: 3.4/ \ +instance (gtext_show (f p), gtext_show (g p)) \ + => gtext_show ((f :+: g) p) where { \ + ; gshow_prec p (L1 x) = gshow_prec p x \ + ; gshow_prec p (R1 x) = gshow_prec p x \ +}; \ + \ +instance (Constructor c, gtext_show_con (f p), IsNullary f) \ + => gtext_show (C1 c f p) where { \ + gshow_prec = c1_show_prec gshow_prec_con \ +}; \ + \ +{- | Class of generic representation types for which the 'ConType' has been \ +determined. \ + \ +/Since: 3.10/ \ -}; \ -class gtext_show arity f where { \ - {- | This is used as the default generic implementation of 'show_prec' (if the \ - @arity@ is 'Zero') or 'lift_show_prec' (if the @arity@ is 'One'). \ - -} \ - ; gshow_prec :: show_funs arity a -> Int -> f a -> text_type \ - }; \ +class gtext_show_con a where { \ + ; gshow_prec_con :: ConType -> Int -> a -> text_type \ +}; \ +deriving instance Typeable gtext_show_con; \ \ -deriving instance Typeable gtext_show; \ +instance gtext_show_con (U1 p) where { \ + ; gshow_prec_con _ _ U1 = mempty \ +}; \ \ -instance gtext_show arity f => gtext_show arity (D1 d f) where { \ - gshow_prec sfs p (M1 x) = gshow_prec sfs p x \ - }; \ +instance TextShow p => gtext_show_con (Par1 p) where { \ + ; gshow_prec_con _ p (Par1 x) = show_prec p x \ +}; \ \ -instance gtext_show arity V1 where { \ - gshow_prec _ _ x = case x of {} \ - }; \ +instance TextShow c => gtext_show_con (K1 i c p) where { \ + ; gshow_prec_con _ p (K1 x) = show_prec p x \ +}; \ \ -instance (gtext_show arity f, gtext_show arity g) => gtext_show arity (f :+: g) where { \ - gshow_prec sfs p (L1 x) = gshow_prec sfs p x \ - ; gshow_prec sfs p (R1 x) = gshow_prec sfs p x \ - }; \ +instance (TextShow1 f, TextShow p) => gtext_show_con (Rec1 f p) where { \ + ; gshow_prec_con _ p (Rec1 x) = lift_show_prec show_prec show_list p x \ +}; \ \ -instance (Constructor c, gtext_show_con arity f, IsNullary f) \ - => gtext_show arity (C1 c f) where { \ - gshow_prec sfs p c@(M1 x) = case fixity of { \ - Prefix -> show_paren ( p > appPrec \ - && not (isNullary x || conIsTuple c) \ - ) $ \ - (if conIsTuple c \ - then mempty \ - else let cn = conName c \ - in show_paren (isInfixDataCon cn) $ from_string cn) \ - <> (if isNullary x || conIsTuple c \ - then mempty \ - else from_char ' ') \ - <> showbBraces t (gshow_prec_con t sfs appPrec1 x) \ - ; Infix _ m -> show_paren (p > m) $ gshow_prec_con t sfs (m+1) x \ - } \ - where { \ - fixity :: Fixity \ - ; fixity = conFixity c \ +instance (Selector s, gtext_show_con (f p)) => gtext_show_con (S1 s f p) where { \ + ; gshow_prec_con t = s1_show_prec $ gshow_prec_con t \ +}; \ \ - ; t :: ConType \ - ; t = if conIsRecord c \ - then Rec \ - else case conIsTuple c of { \ - True -> Tup \ - ; False -> case fixity of { \ - Prefix -> Pref \ - ; Infix _ _ -> Inf $ conName c \ - }; \ - } \ +instance (gtext_show_con (f p), gtext_show_con (g p)) \ + => gtext_show_con ((f :*: g) p) where { \ + ; gshow_prec_con t = product_show_prec (gshow_prec_con t) (gshow_prec_con t) t \ +}; \ \ - ; showbBraces :: ConType -> text_type -> text_type \ - ; showbBraces Rec b = from_char '{' <> b <> from_char '}' \ - ; showbBraces Tup b = from_char '(' <> b <> from_char ')' \ - ; showbBraces Pref b = b \ - ; showbBraces (Inf _) b = b \ +instance (TextShow1 f, gtext_show_con (g p)) => gtext_show_con ((f :.: g) p) where { \ + ; gshow_prec_con t p (Comp1 x) = \ + let gspc = gshow_prec_con t \ + in lift_show_prec gspc (show_list_with (gspc 0)) p x \ +}; \ \ - ; conIsTuple :: C1 c f p -> Bool \ - ; conIsTuple = isTupleString . conName \ - }; \ - }; \ +instance gtext_show_con (UChar p) where { \ + ; gshow_prec_con _ = u_char_show_prec show_prec \ +}; \ \ -{- | Class of generic representation types for which the 'ConType' has been \ -determined. The @arity@ type variable indicates which type class is \ -used. @'gtext_show_con' 'Zero'@ indicates 'TextShow' behavior, and \ -@'gtext_show_con' 'One'@ indicates 'TextShow1' behavior. \ +instance gtext_show_con (UDouble p) where { \ + ; gshow_prec_con _ = u_double_show_prec show_prec \ +}; \ + \ +instance gtext_show_con (UFloat p) where { \ + ; gshow_prec_con _ = u_float_show_prec show_prec \ +}; \ + \ +instance gtext_show_con (UInt p) where { \ + ; gshow_prec_con _ = u_int_show_prec show_prec \ +}; \ + \ +instance gtext_show_con (UWord p) where { \ + ; gshow_prec_con _ = u_word_show_prec show_prec \ +}; \ + \ +{- | Class of generic representation types for unary type constructors that can \ +be converted to a 'text_type'. \ + \ +/Since: 3.10/ \ -}; \ -class gtext_show_con arity f where { \ - {- | Convert value of a specific 'ConType' to a 'text_type' with the given \ - precedence. \ - -} \ - ; gshow_prec_con :: ConType -> show_funs arity a -> Int -> f a -> text_type \ - }; \ +class QUANTIFIED_SUPERCLASS(gtext_show,f) \ + gtext_show1 f where { \ + ; glift_show_prec :: (Int -> a -> text_type) -> ([a] -> text_type) \ + -> Int -> f a -> text_type \ +}; \ +deriving instance Typeable gtext_show1; \ \ -deriving instance Typeable gtext_show_con; \ +instance gtext_show1 f => gtext_show1 (D1 d f) where { \ + ; glift_show_prec sp sl p (M1 x) = glift_show_prec sp sl p x \ +}; \ \ -instance gtext_show_con arity U1 where { \ - gshow_prec_con _ _ _ U1 = mempty \ - }; \ +instance gtext_show1 V1 where { \ + ; glift_show_prec _ _ _ x = case x of {} \ +}; \ \ -instance gtext_show_con One Par1 where { \ - gshow_prec_con _ (show1_funs sp _) p (Par1 x) = sp p x \ - }; \ +instance (gtext_show1 f, gtext_show1 g) => gtext_show1 (f :+: g) where { \ + ; glift_show_prec sp sl p (L1 x) = glift_show_prec sp sl p x \ + ; glift_show_prec sp sl p (R1 x) = glift_show_prec sp sl p x \ +}; \ \ -instance TextShow c => gtext_show_con arity (K1 i c) where { \ - gshow_prec_con _ _ p (K1 x) = show_prec p x \ - }; \ +instance (Constructor c, gtext_show_con1 f, IsNullary f) \ + => gtext_show1 (C1 c f) where { \ + ; glift_show_prec sp sl = c1_show_prec $ glift_show_prec_con sp sl \ +}; \ \ -instance TextShow1 f => gtext_show_con One (Rec1 f) where { \ - gshow_prec_con _ (show1_funs sp sl) p (Rec1 x) = lift_show_prec sp sl p x \ - }; \ +{- | Class of generic representation types for unary type constructors for which \ +the 'ConType' has been determined. \ \ -instance (Selector s, gtext_show_con arity f) => gtext_show_con arity (S1 s f) where { \ - gshow_prec_con t sfs p sel@(M1 x) \ - | selName sel == "" = gshow_prec_con t sfs p x \ - | otherwise = infixRec \ - <> " = " \ - <> gshow_prec_con t sfs 0 x \ - where { \ - infixRec :: text_type \ - ; infixRec | isSymVar selectorName \ - = from_char '(' <> from_string selectorName <> from_char ')' \ - | otherwise \ - = from_string selectorName \ +/Since: 3.10/ \ +-}; \ +class QUANTIFIED_SUPERCLASS(gtext_show_con,f) \ + gtext_show_con1 f where { \ + ; glift_show_prec_con :: (Int -> a -> text_type) -> ([a] -> text_type) \ + -> ConType -> Int -> f a -> text_type \ +}; \ +deriving instance Typeable gtext_show_con1; \ \ - ; selectorName :: String \ - ; selectorName = selName sel \ - } \ - }; \ +instance gtext_show_con1 U1 where { \ + ; glift_show_prec_con _ _ _ _ U1 = mempty \ +}; \ \ -instance (gtext_show_con arity f, gtext_show_con arity g) \ - => gtext_show_con arity (f :*: g) where { \ - gshow_prec_con t@Rec sfs _ (a :*: b) = \ - gshow_prec_con t sfs 0 a \ +instance gtext_show_con1 Par1 where { \ + ; glift_show_prec_con sp _ _ p (Par1 x) = sp p x \ +}; \ + \ +instance TextShow c => gtext_show_con1 (K1 i c) where { \ + ; glift_show_prec_con _ _ _ p (K1 x) = show_prec p x \ +}; \ + \ +instance TextShow1 f => gtext_show_con1 (Rec1 f) where { \ + ; glift_show_prec_con sp sl _ p (Rec1 x) = lift_show_prec sp sl p x \ +}; \ + \ +instance (Selector s, gtext_show_con1 f) => gtext_show_con1 (S1 s f) where { \ + ; glift_show_prec_con sp sl t = s1_show_prec $ glift_show_prec_con sp sl t \ +}; \ + \ +instance (gtext_show_con1 f, gtext_show_con1 g) \ + => gtext_show_con1 (f :*: g) where { \ + ; glift_show_prec_con sp sl t = \ + product_show_prec (glift_show_prec_con sp sl t) (glift_show_prec_con sp sl t) t \ +}; \ + \ +instance (TextShow1 f, gtext_show_con1 g) => gtext_show_con1 (f :.: g) where { \ + ; glift_show_prec_con sp sl t p (Comp1 x) = \ + let gspc = glift_show_prec_con sp sl t \ + in lift_show_prec gspc (show_list_with (gspc 0)) p x \ +}; \ + \ +instance gtext_show_con1 UChar where { \ + ; glift_show_prec_con _ _ _ = u_char_show_prec show_prec \ +}; \ + \ +instance gtext_show_con1 UDouble where { \ + ; glift_show_prec_con _ _ _ = u_double_show_prec show_prec \ +}; \ + \ +instance gtext_show_con1 UFloat where { \ + ; glift_show_prec_con _ _ _ = u_float_show_prec show_prec \ +}; \ + \ +instance gtext_show_con1 UInt where { \ + ; glift_show_prec_con _ _ _ = u_int_show_prec show_prec \ +}; \ + \ +instance gtext_show_con1 UWord where { \ + ; glift_show_prec_con _ _ _ = u_word_show_prec show_prec \ +}; \ + \ +c1_show_prec :: forall c f p. \ + (Constructor c, IsNullary f) \ + => (ConType -> Int -> f p -> text_type) \ + -> Int -> C1 c f p -> text_type; \ +c1_show_prec sp p c@(M1 x) = case fixity of { \ + ; Prefix -> show_paren ( p > appPrec \ + && not (isNullary x || conIsTuple c) \ + ) $ \ + (if conIsTuple c \ + then mempty \ + else let cn = conName c \ + in show_paren (isInfixDataCon cn) $ from_string cn) \ + <> (if isNullary x || conIsTuple c \ + then mempty \ + else from_char ' ') \ + <> showBraces t (sp t appPrec1 x) \ + ; Infix _ m -> show_paren (p > m) $ sp t (m+1) x \ +} where { \ + ; fixity :: Fixity \ + ; fixity = conFixity c \ + \ + ; t :: ConType \ + ; t = if conIsRecord c \ + then Rec \ + else case conIsTuple c of { \ + ; True -> Tup \ + ; False -> case fixity of { \ + ; Prefix -> Pref \ + ; Infix _ _ -> Inf $ conName c \ + }; \ + }; \ + \ + ; showBraces :: ConType -> text_type -> text_type \ + ; showBraces Rec b = from_char '{' <> b <> from_char '}' \ + ; showBraces Tup b = from_char '(' <> b <> from_char ')' \ + ; showBraces Pref b = b \ + ; showBraces (Inf _) b = b \ + \ + ; conIsTuple :: C1 c f p -> Bool \ + ; conIsTuple = isTupleString . conName \ + }; \ +INLINE_GE_902(c1_show_prec) \ + \ +s1_show_prec :: Selector s \ + => (Int -> f p -> text_type) \ + -> Int -> S1 s f p -> text_type; \ +s1_show_prec sp p sel@(M1 x) \ + | selName sel == "" = sp p x \ + | otherwise = infixRec \ + <> " = " \ + <> sp 0 x \ + where { \ + ; infixRec :: text_type \ + ; infixRec | isSymVar selectorName \ + = from_char '(' <> from_string selectorName <> from_char ')' \ + | otherwise \ + = from_string selectorName \ + \ + ; selectorName :: String \ + ; selectorName = selName sel \ + }; \ +INLINE_GE_902(s1_show_prec) \ + \ +product_show_prec :: (Int -> f p -> text_type) -> (Int -> g p -> text_type) \ + -> ConType -> Int -> (f :*: g) p -> text_type; \ +product_show_prec spf spg t p (a :*: b) = \ + case t of { \ + ; Rec -> \ + spf 0 a \ <> ", " \ - <> gshow_prec_con t sfs 0 b \ - ; gshow_prec_con t@(Inf o) sfs p (a :*: b) = \ - gshow_prec_con t sfs p a \ + <> spg 0 b \ + ; Inf o -> \ + spf p a \ <> show_space \ - <> infixOp \ + <> infixOp o \ <> show_space \ - <> gshow_prec_con t sfs p b \ - where { \ - infixOp :: text_type \ - ; infixOp = if isInfixDataCon o \ - then from_string o \ - else from_char '`' <> from_string o <> from_char '`' \ - } \ - ; gshow_prec_con t@Tup sfs _ (a :*: b) = \ - gshow_prec_con t sfs 0 a \ + <> spg p b \ + ; Tup -> \ + spf 0 a \ <> from_char ',' \ - <> gshow_prec_con t sfs 0 b \ - ; gshow_prec_con t@Pref sfs p (a :*: b) = \ - gshow_prec_con t sfs p a \ + <> spg 0 b \ + ; Pref -> \ + spf p a \ <> show_space \ - <> gshow_prec_con t sfs p b \ - }; \ - \ -instance (TextShow1 f, gtext_show_con One g) => gtext_show_con One (f :.: g) where { \ - gshow_prec_con t sfs p (Comp1 x) = \ - let gspc = gshow_prec_con t sfs \ - in lift_show_prec gspc (show_list_with (gspc 0)) p x \ - }; \ + <> spg p b \ + } where { \ + ; infixOp :: String -> text_type \ + ; infixOp o = if isInfixDataCon o \ + then from_string o \ + else from_char '`' <> from_string o <> from_char '`' \ + }; \ +INLINE_GE_902(product_show_prec) \ \ -instance gtext_show_con arity UChar where { \ - gshow_prec_con _ _ p (UChar c) = show_prec (hash_prec p) (C# c) <> one_hash \ - }; \ +u_char_show_prec :: (Int -> Char -> text_type) -> Int -> UChar p -> text_type; \ +u_char_show_prec sp p (UChar c) = sp (hashPrec p) (C# c) <> one_hash; \ +INLINE_GE_902(u_char_show_prec) \ \ -instance gtext_show_con arity UDouble where { \ - gshow_prec_con _ _ p (UDouble d) = show_prec (hash_prec p) (D# d) <> two_hash \ - }; \ +u_double_show_prec :: (Int -> Double -> text_type) -> Int -> UDouble p -> text_type; \ +u_double_show_prec sp p (UDouble d) = sp (hashPrec p) (D# d) <> two_hash; \ +INLINE_GE_902(u_double_show_prec) \ \ -instance gtext_show_con arity UFloat where { \ - gshow_prec_con _ _ p (UFloat f) = show_prec (hash_prec p) (F# f) <> one_hash \ - }; \ +u_float_show_prec :: (Int -> Float -> text_type) -> Int -> UFloat p -> text_type; \ +u_float_show_prec sp p (UFloat f) = sp (hashPrec p) (F# f) <> one_hash; \ +INLINE_GE_902(u_float_show_prec) \ \ -instance gtext_show_con arity UInt where { \ - gshow_prec_con _ _ p (UInt i) = show_prec (hash_prec p) (I# i) <> one_hash \ - }; \ +u_int_show_prec :: (Int -> Int -> text_type) -> Int -> UInt p -> text_type; \ +u_int_show_prec sp p (UInt i) = sp (hashPrec p) (I# i) <> one_hash; \ +INLINE_GE_902(u_int_show_prec) \ \ -instance gtext_show_con arity UWord where { \ - gshow_prec_con _ _ p (UWord w) = show_prec (hash_prec p) (W# w) <> two_hash \ - }; \ +u_word_show_prec :: (Int -> Word -> text_type) -> Int -> UWord p -> text_type; \ +u_word_show_prec sp p (UWord w) = sp (hashPrec p) (W# w) <> two_hash; \ +INLINE_GE_902(u_word_show_prec) \ \ -HASH_FUNS(text_type,one_hash,two_hash,hash_prec,from_char,from_string); +HASH_FUNS(text_type,one_hash,two_hash,from_char,from_string); -GTEXT_SHOW(Builder,ShowFunsB,NoShowFunsB,Show1FunsB,oneHashB,twoHashB,hashPrecB,GTextShowB,gShowbPrec,GTextShowConB,gShowbPrecCon,showbPrec,liftShowbPrec,showbSpace,showbParen,showbListWith,TB.singleton,TB.fromString) -GTEXT_SHOW(TS.Text,ShowFunsT,NoShowFunsT,Show1FunsT,oneHashT,twoHashT,hashPrecT,GTextShowT,gShowtPrec,GTextShowConT,gShowtPrecCon,showtPrec,liftShowtPrec,showtSpace,showtParen,showtListWith,TS.singleton,TS.pack) -GTEXT_SHOW(TL.Text,ShowFunsTL,NoShowFunsTL,Show1FunsTL,oneHashTL,twoHashTL,hashPrecTL,GTextShowTL,gShowtlPrec,GTextShowConTL,gShowtlPrecCon,showtlPrec,liftShowtlPrec,showtlSpace,showtlParen,showtlListWith,TL.singleton,TL.pack) +GTEXT_SHOW(Builder,ShowFunsB,oneHashB,twoHashB,GTextShowB,GTextShowB1,gShowbPrec,gLiftShowbPrec,GTextShowConB,GTextShowConB1,gShowbPrecCon,gLiftShowbPrecCon,showbPrec,liftShowbPrec,showbSpace,showbParen,showbList,showbListWith,TB.singleton,TB.fromString,c1ShowbPrec,s1ShowbPrec,productShowbPrec,uCharShowbPrec,uDoubleShowbPrec,uFloatShowbPrec,uIntShowbPrec,uWordShowbPrec) +GTEXT_SHOW(TS.Text,ShowFunsT,oneHashT,twoHashT,GTextShowT,GTextShowT1,gShowtPrec,gLiftShowtPrec,GTextShowConT,GTextShowConT1,gShowtPrecCon,gLiftShowtPrecCon,showtPrec,liftShowtPrec,showtSpace,showtParen,showtList,showtListWith,TS.singleton,TS.pack,c1ShowtPrec,s1ShowtPrec,productShowtPrec,uCharShowtPrec,uDoubleShowtPrec,uFloatShowtPrec,uIntShowtPrec,uWordShowtPrec) +GTEXT_SHOW(TL.Text,ShowFunsTL,oneHashTL,twoHashTL,GTextShowTL,GTextShowTL1,gShowtlPrec,gLiftShowtlPrec,GTextShowConTL,GTextShowConTL1,gShowtlPrecCon,gLiftShowtlPrecCon,showtlPrec,liftShowtlPrec,showtlSpace,showtlParen,showtlList,showtlListWith,TL.singleton,TL.pack,c1ShowtlPrec,s1ShowtlPrec,productShowtlPrec,uCharShowtlPrec,uDoubleShowtlPrec,uFloatShowtlPrec,uIntShowtlPrec,uWordShowtlPrec) -- | Class of generic representation types that represent a constructor with -- zero or more fields. diff --git a/src/TextShow/Instances.hs b/src/TextShow/Instances.hs --- a/src/TextShow/Instances.hs +++ b/src/TextShow/Instances.hs @@ -18,6 +18,7 @@ import TextShow.Control.Monad.ST () import TextShow.Data.Array () +import TextShow.Data.Array.Byte () import TextShow.Data.Bool () import TextShow.Data.ByteString () import TextShow.Data.Char () diff --git a/tests/Spec/Data/Array/ByteSpec.hs b/tests/Spec/Data/Array/ByteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Data/Array/ByteSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} + +{-| +Module: Spec.Data.Array.ByteSpec +Copyright: (C) 2022 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ tests for 'ByteArray' from the "Data.Array.Byte" module. +-} +module Spec.Data.Array.ByteSpec (main, spec) where + +import Prelude () +import Prelude.Compat + +import Test.Hspec (Spec, hspec, parallel) +import Test.QuickCheck.Instances () + +#if MIN_VERSION_base(4,17,0) +import Data.Array.Byte (ByteArray) +import Data.Proxy.Compat (Proxy(..)) + +import Spec.Utils (matchesTextShowSpec) + +import Test.Hspec (describe) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do +#if MIN_VERSION_base(4,17,0) + describe "ByteArray" $ + matchesTextShowSpec (Proxy :: Proxy ByteArray) +#else + pure () +#endif diff --git a/tests/Spec/Derived/MagicHashSpec.hs b/tests/Spec/Derived/MagicHashSpec.hs --- a/tests/Spec/Derived/MagicHashSpec.hs +++ b/tests/Spec/Derived/MagicHashSpec.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} +#if __GLASGOW_HASKELL__ == 800 +-- See Note [Increased simpl-tick-factor on old GHCs] in TextShow.Data.Complex +{-# OPTIONS_GHC -fsimpl-tick-factor=250 #-} +#endif {-| Module: Spec.Derived.MagicHashSpec diff --git a/tests/Spec/Derived/RecordsSpec.hs b/tests/Spec/Derived/RecordsSpec.hs --- a/tests/Spec/Derived/RecordsSpec.hs +++ b/tests/Spec/Derived/RecordsSpec.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ == 800 +-- See Note [Increased simpl-tick-factor on old GHCs] in TextShow.Data.Complex +{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-} +#endif + {-| Module: Spec.Derived.RecordsSpec Copyright: (C) 2014-2017 Ryan Scott diff --git a/tests/Spec/FromStringTextShowSpec.hs b/tests/Spec/FromStringTextShowSpec.hs --- a/tests/Spec/FromStringTextShowSpec.hs +++ b/tests/Spec/FromStringTextShowSpec.hs @@ -14,12 +14,12 @@ import Data.Proxy.Compat (Proxy(..)) import Instances.FromStringTextShow () -import Spec.Utils (matchesTextShowSpec, matchesTextShow1Spec) +import Spec.Utils (matchesTextShowSpec) import Test.Hspec (Spec, describe, hspec, parallel) import TextShow (FromStringShow(..), FromTextShow(..)) #if defined(NEW_FUNCTOR_CLASSES) -import Spec.Utils (matchesTextShow2Spec) +import Spec.Utils (matchesTextShow1Spec, matchesTextShow2Spec) import TextShow (FromStringShow1(..), FromStringShow2(..), FromTextShow1(..), FromTextShow2(..)) #endif @@ -33,43 +33,33 @@ let p :: Proxy (FromStringShow Int) p = Proxy matchesTextShowSpec p - matchesTextShow1Spec p describe "FromStringShow String" $ do let p :: Proxy (FromStringShow String) p = Proxy matchesTextShowSpec p - matchesTextShow1Spec p describe "FromTextShow Int" $ do let p :: Proxy (FromTextShow Int) p = Proxy matchesTextShowSpec p - matchesTextShow1Spec p describe "FromTextShow String" $ do let p :: Proxy (FromTextShow String) p = Proxy matchesTextShowSpec p - matchesTextShow1Spec p #if defined(NEW_FUNCTOR_CLASSES) describe "FromStringShow1 Maybe Int" $ do let p :: Proxy (FromStringShow1 Maybe Int) p = Proxy - matchesTextShowSpec p matchesTextShow1Spec p describe "FromTextShow1 Maybe Int" $ do let p :: Proxy (FromTextShow1 Maybe Int) p = Proxy - matchesTextShowSpec p matchesTextShow1Spec p describe "FromStringShow2 Either Char Int" $ do let p :: Proxy (FromStringShow2 Either Char Int) p = Proxy - matchesTextShowSpec p - matchesTextShow1Spec p matchesTextShow2Spec p describe "FromTextShow2 Either Char Int" $ do let p :: Proxy (FromTextShow2 Either Char Int) p = Proxy - matchesTextShowSpec p - matchesTextShow1Spec p matchesTextShow2Spec p #endif diff --git a/tests/Spec/Utils.hs b/tests/Spec/Utils.hs --- a/tests/Spec/Utils.hs +++ b/tests/Spec/Utils.hs @@ -49,7 +49,7 @@ -- | Verifies that a type's 'Show' instances coincide for both 'String's and 'Text', -- irrespective of precedence. prop_matchesTextShow :: (Show a, TextShow a) => Int -> a -> Expectation -prop_matchesTextShow p x = fromString (showsPrec p x "") `shouldBe` showbPrec p x +prop_matchesTextShow p x = showbPrec p x `shouldBe` fromString (showsPrec p x "") -- | Expect a type's 'Show1' instances to coincide for both 'String's and 'Text', -- irrespective of precedence. @@ -61,7 +61,7 @@ -- | Verifies that a type's 'Show1' instances coincide for both 'String's and 'Text', -- irrespective of precedence. prop_matchesTextShow1 :: (Show1 f, Show a, TextShow1 f, TextShow a) => Int -> f a -> Expectation -prop_matchesTextShow1 p x = fromString (showsPrec1 p x "") `shouldBe` showbPrec1 p x +prop_matchesTextShow1 p x = showbPrec1 p x `shouldBe` fromString (showsPrec1 p x "") #if defined(NEW_FUNCTOR_CLASSES) -- | Expect a type's 'Show2' instances to coincide for both 'String's and 'Text', @@ -76,33 +76,33 @@ -- irrespective of precedence. prop_matchesTextShow2 :: (Show2 f, Show a, Show b, TextShow2 f, TextShow a, TextShow b) => Int -> f a b -> Expectation -prop_matchesTextShow2 p x = fromString (showsPrec2 p x "") `shouldBe` showbPrec2 p x +prop_matchesTextShow2 p x = showbPrec2 p x `shouldBe` fromString (showsPrec2 p x "") #endif -- | Expect a type's 'TextShow' instance to coincide with the output produced -- by the equivalent 'Generic' functions. genericTextShowSpec :: forall a. (Arbitrary a, Show a, TextShow a, - Generic a, GTextShowB Zero (Rep a)) + Generic a, GTextShowB (Rep a ())) => Proxy a -> Spec genericTextShowSpec _ = prop "generic TextShow" (prop_genericTextShow :: Int -> a -> Expectation) -- | Verifies that a type's 'TextShow' instance coincides with the output produced -- by the equivalent 'Generic' functions. -prop_genericTextShow :: (TextShow a, Generic a, GTextShowB Zero (Rep a)) +prop_genericTextShow :: (TextShow a, Generic a, GTextShowB (Rep a ())) => Int -> a -> Expectation prop_genericTextShow p x = showbPrec p x `shouldBe` genericShowbPrec p x -- | Expect a type's 'TextShow1' instance to coincide with the output produced -- by the equivalent 'Generic1' functions. genericTextShow1Spec :: forall f a. (Arbitrary (f a), Show (f a), TextShow1 f, - Generic1 f, GTextShowB One (Rep1 f), TextShow a) + Generic1 f, GTextShowB1 (Rep1 f), TextShow a) => Proxy (f a) -> Spec genericTextShow1Spec _ = prop "generic TextShow1" (prop_genericTextShow1 :: Int -> f a -> Expectation) -- | Verifies that a type's 'TextShow1' instance coincides with the output produced -- by the equivalent 'Generic1' functions. prop_genericTextShow1 :: ( TextShow1 f, Generic1 f - , GTextShowB One (Rep1 f), TextShow a + , GTextShowB1 (Rep1 f), TextShow a ) => Int -> f a -> Expectation prop_genericTextShow1 p x = diff --git a/text-show.cabal b/text-show.cabal --- a/text-show.cabal +++ b/text-show.cabal @@ -1,5 +1,5 @@ name: text-show -version: 3.9.7 +version: 3.10 synopsis: Efficient conversion of values into Text description: @text-show@ offers a replacement for the @Show@ typeclass intended for use with @Text@ instead of @String@s. This package was created @@ -89,6 +89,7 @@ TextShow.Control.Exception TextShow.Control.Monad.ST TextShow.Data.Array + TextShow.Data.Array.Byte TextShow.Data.Bool TextShow.Data.ByteString TextShow.Data.Char @@ -174,14 +175,14 @@ , th-lift >= 0.7.6 && < 1 if flag(base-4-9) - build-depends: base >= 4.9 && < 4.17 + build-depends: base >= 4.9 && < 4.18 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: base >= 4.7 && < 4.9 if flag(template-haskell-2-11) - build-depends: template-haskell >= 2.11 && < 2.19 - , ghc-boot-th >= 8.0 && < 9.3 + build-depends: template-haskell >= 2.11 && < 2.20 + , ghc-boot-th >= 8.0 && < 9.5 else build-depends: template-haskell >= 2.9 && < 2.11 @@ -277,6 +278,7 @@ Spec.Control.ExceptionSpec Spec.Control.Monad.STSpec Spec.Data.ArraySpec + Spec.Data.Array.ByteSpec Spec.Data.BoolSpec Spec.Data.ByteStringSpec Spec.Data.CharSpec @@ -361,15 +363,15 @@ , ghc-prim , hspec >= 2 && < 3 , QuickCheck >= 2.12 && < 2.15 - , quickcheck-instances >= 0.3.26 && < 0.4 - , template-haskell >= 2.9 && < 2.19 + , quickcheck-instances >= 0.3.28 && < 0.4 + , template-haskell >= 2.9 && < 2.20 , text >= 0.11.1 && < 2.1 , text-show , transformers-compat >= 0.5 && < 1 build-tool-depends: hspec-discover:hspec-discover if flag(base-4-9) - build-depends: base >= 4.9 && < 4.17 + build-depends: base >= 4.9 && < 4.18 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: base >= 4.7 && < 4.9 @@ -394,7 +396,7 @@ benchmark bench type: exitcode-stdio-1.0 main-is: Bench.hs - build-depends: base >= 4.5 && < 4.17 + build-depends: base >= 4.5 && < 4.18 , criterion >= 1.1.4 && < 2 , deepseq >= 1.3 && < 2 , ghc-prim