diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,17 @@ +# 0.6 +* `deriveShow` can now construct instances for data families, using either the data family name or a data instance constructor as an argument. See the documentation in `Text.Show.Text.TH` for more details. +* Fixed a bug in which infix backticked data constructors (e.g., ```data Add = Int `Plus` Int```) would not be shown correctly. +* Fixed typo in `Text.Show.Text.GHC.RTS.Flags` +* Removed the phantom-type detecting mechanism with `template-haskell-2.9.0.0` or higher. This method of finding phantom types is intrinsically flawed and is not usable on older GHCs. I plan on introducing a more robust mechanism for detecting phantom types on more versions of Template Haskell in `text-show-0.7`. +* Added generics support with the `Text.Show.Text.Generic` and `Text.Show.Text.Debug.Trace.Generic` modules +* Deprecated `replicateB` in favor of `timesN` from the `semigroups` library +* Added `FromTextShow` to `Text.Show.Text`, which admits a `String` `Show` instance for any data type with a `Text` `Show` instance (the counterpart of `FromStringShow`) +* Added `Monoid` and `Semigroup` instances for `FromStringShow`, `Semigroup` instance for `LitString`, `IsChar` instance for `LitChar`, and `IsString` instance for `[LitChar]` +* Changed the `String` `Show` instances of `FromStringShow`, `LitChar`, and `LitString` to more closely match the `Text` `Show` instances. As a result, the `Read` instances for these data types were also changed so that `read . show = read . show = id`. +* Removed the `recent-text` flag. We'll allow users to build with older versions of `text`, but the latest version is recommended. Because of this, the `integer-simple` and `integer-gmp` flags are not needed. +* Removed the `integer-gmp2` flag, as it supported a configuration that didn't actually compile on GHC +* Removed the `transformers-four` flag, as it is not needed now that `transformers-compat` is a dependency + # 0.5 * Fix build for GHC 7.10, old GHC versions, and Windows * Removed the `Text.Show.Text.Data.Containers` and `Text.Show.Text.Data.Time` modules. The modules for the data types in `containers` and `time` were migrated to a separate library, `text-show-instances`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# `text-show` [![Hackage version](https://img.shields.io/hackage/v/text-show.svg)](http://hackage.haskell.org/package/text-show) [![Build Status](https://travis-ci.org/RyanGlScott/text-show.svg)](https://travis-ci.org/RyanGlScott/text-show) +# `text-show` [![Hackage version](https://img.shields.io/hackage/v/text-show.svg?style=flat)](http://hackage.haskell.org/package/text-show) [![Build Status](https://img.shields.io/travis/RyanGlScott/text-show.svg?style=flat)](https://travis-ci.org/RyanGlScott/text-show) `text-show` offers a replacement for the `Show` typeclass intended for use with `Text` instead of `String`s. This package was created in the spirit of [`bytestring-show`](http://hackage.haskell.org/package/bytestring-show). diff --git a/include/inline.h b/include/inline.h --- a/include/inline.h +++ b/include/inline.h @@ -1,13 +1,12 @@ #ifndef INLINE_H #define INLINE_H -#define OPEN_PRAGMA {-# -#define CLOSE_PRAGMA #-} +#include "utils.h" #if __GLASGOW_HASKELL__ >= 702 -#define INLINE_INST_FUN(F) OPEN_PRAGMA INLINE F CLOSE_PRAGMA +# define INLINE_INST_FUN(F) OPEN_PRAGMA INLINE F CLOSE_PRAGMA #else -#define INLINE_INST_FUN(F) +# define INLINE_INST_FUN(F) #endif #endif diff --git a/include/utils.h b/include/utils.h new file mode 100644 --- /dev/null +++ b/include/utils.h @@ -0,0 +1,7 @@ +#ifndef UTILS_H +#define UTILS_H + +#define OPEN_PRAGMA {-# +#define CLOSE_PRAGMA #-} + +#endif diff --git a/src/Text/Show/Text.hs b/src/Text/Show/Text.hs --- a/src/Text/Show/Text.hs +++ b/src/Text/Show/Text.hs @@ -38,8 +38,9 @@ , printLazy , hPrint , hPrintLazy - -- * @FromStringShow@ + -- * Conversion between @String@ and @Text@ 'Show' , FromStringShow(..) + , FromTextShow(..) ) where import Data.Text.Lazy.Builder diff --git a/src/Text/Show/Text/Classes.hs b/src/Text/Show/Text/Classes.hs --- a/src/Text/Show/Text/Classes.hs +++ b/src/Text/Show/Text/Classes.hs @@ -21,12 +21,13 @@ #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative((<*>), pure)) import Data.Foldable (Foldable) +import Data.Monoid (Monoid) import Data.Traversable (Traversable) #endif -import Control.Monad.Fix (MonadFix(mfix)) +import Control.Monad.Fix (MonadFix(..)) #if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzip, mzipWith, munzip)) +import Control.Monad.Zip (MonadZip(..)) #endif import Data.Bits (Bits) @@ -34,7 +35,9 @@ import Data.Bits (FiniteBits) #endif import Data.Data (Data, Typeable) +import Data.Functor ((<$>)) import Data.Ix (Ix) +import Data.Semigroup (Semigroup) import Data.String (IsString) import Data.Text as TS (Text) import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) @@ -61,8 +64,9 @@ import System.IO (Handle) import Text.Printf (PrintfArg, PrintfType) +import Text.Read (Read(..), readListPrecDefault) import qualified Text.Show as S (Show(showsPrec)) -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Utils ((<>), s, toString) #include "inline.h" @@ -84,7 +88,8 @@ -- -- If you do not want to create 'Show' instances manually, you can alternatively -- use the "Text.Show.Text.TH" module to automatically generate default 'Show' --- instances using Template Haskell. +-- instances using Template Haskell, or the "Text.Show.Text.Generic" module to +-- quickly define 'Show' instances using 'genericShowbPrec'. -- -- /Since: 0.1/ class Show a where @@ -286,15 +291,15 @@ , Integral , IsString , Ix + , Monoid , Num , Ord , PrintfArg , PrintfType - , Read , Real , RealFloat , RealFrac - , S.Show + , Semigroup , Storable , Traversable , Typeable @@ -339,6 +344,116 @@ INLINE_INST_FUN(munzip) #endif +instance Read a => Read (FromStringShow a) where + readPrec = FromStringShow <$> readPrec + INLINE_INST_FUN(readPrec) + + readListPrec = readListPrecDefault + INLINE_INST_FUN(readListPrec) + instance S.Show a => Show (FromStringShow a) where showbPrec p (FromStringShow x) = fromString $ S.showsPrec p x "" INLINE_INST_FUN(showbPrec) + +instance S.Show a => S.Show (FromStringShow a) where + showsPrec p (FromStringShow x) = showsPrec p x + INLINE_INST_FUN(showsPrec) + +-- | The @String@ 'S.Show' instance for 'FromTextShow' is based on its @Text@ +-- 'T.Show' instance. That is, +-- +-- @ +-- showsPrec p ('FromTextShow' x) str = 'toString' (showbPrec p x) ++ str +-- @ +-- +-- /Since: 0.6/ +newtype FromTextShow a = FromTextShow { fromTextShow :: a } + deriving ( Bits + , Bounded + , Data + , Enum + , Eq +#if MIN_VERSION_base(4,7,0) + , FiniteBits +#endif + , Floating + , Foldable + , Fractional + , Functor +#if MIN_VERSION_base(4,4,0) + , Generic +# if __GLASGOW_HASKELL__ >= 706 + , Generic1 +# endif +#endif + , Integral + , IsString + , Ix + , Monoid + , Num + , Ord + , PrintfArg + , PrintfType + , Real + , RealFloat + , RealFrac + , Semigroup + , Show + , Storable + , Traversable + , Typeable + ) + +instance Applicative FromTextShow where + pure = FromTextShow + INLINE_INST_FUN(pure) + + FromTextShow f <*> FromTextShow x = FromTextShow $ f x + INLINE_INST_FUN((<*>)) + +#if __GLASGOW_HASKELL__ >= 708 +instance IsList a => IsList (FromTextShow a) where + type Item (FromTextShow a) = Item a + fromList = FromTextShow . fromList + {-# INLINE fromList #-} + toList = toList . fromTextShow + {-# INLINE toList #-} +#endif + +instance Monad FromTextShow where + return = FromTextShow + INLINE_INST_FUN(return) + + FromTextShow a >>= f = f a + INLINE_INST_FUN((>>=)) + +instance MonadFix FromTextShow where + mfix f = FromTextShow $ let FromTextShow a = f a in a + INLINE_INST_FUN(mfix) + +#if MIN_VERSION_base(4,4,0) +instance MonadZip FromTextShow where + mzip (FromTextShow a) (FromTextShow b) = FromTextShow (a, b) + INLINE_INST_FUN(mzip) + + mzipWith f (FromTextShow a) (FromTextShow b) = FromTextShow $ f a b + INLINE_INST_FUN(mzipWith) + + munzip (FromTextShow (a, b)) = (FromTextShow a, FromTextShow b) + INLINE_INST_FUN(munzip) +#endif + +instance Read a => Read (FromTextShow a) where + readPrec = FromTextShow <$> readPrec + INLINE_INST_FUN(readPrec) + + readListPrec = readListPrecDefault + INLINE_INST_FUN(readListPrec) + +instance Show a => S.Show (FromTextShow a) where + showsPrec p (FromTextShow x) str = toString (showbPrec p x) ++ str + INLINE_INST_FUN(showsPrec) + +instance Show1 FromTextShow where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Control/Concurrent.hs b/src/Text/Show/Text/Control/Concurrent.hs --- a/src/Text/Show/Text/Control/Concurrent.hs +++ b/src/Text/Show/Text/Control/Concurrent.hs @@ -25,8 +25,7 @@ import Prelude hiding (Show) import Text.Show.Text.Classes (Show(showb, showbPrec), FromStringShow(..)) -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb, - defaultInlineShowbPrec) +import Text.Show.Text.TH.Internal (deriveShow) #include "inline.h" @@ -55,5 +54,5 @@ showbPrec = showbThreadIdPrec INLINE_INST_FUN(showbPrec) -$(deriveShowPragmas defaultInlineShowbPrec ''ThreadStatus) -$(deriveShowPragmas defaultInlineShowb ''BlockReason) +$(deriveShow ''ThreadStatus) +$(deriveShow ''BlockReason) diff --git a/src/Text/Show/Text/Control/Exception.hs b/src/Text/Show/Text/Control/Exception.hs --- a/src/Text/Show/Text/Control/Exception.hs +++ b/src/Text/Show/Text/Control/Exception.hs @@ -80,7 +80,6 @@ #if MIN_VERSION_base(4,6,0) showbArithException RatioZeroDenominator = "Ratio has zero denominator" #endif -{-# INLINE showbArithException #-} -- | Convert an 'ArrayException' to a 'Builder'. -- diff --git a/src/Text/Show/Text/Data/Char.hs b/src/Text/Show/Text/Data/Char.hs --- a/src/Text/Show/Text/Data/Char.hs +++ b/src/Text/Show/Text/Data/Char.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, - OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, + GeneralizedNewtypeDeriving, OverloadedStrings, TemplateHaskell #-} #if MIN_VERSION_base(4,4,0) {-# LANGUAGE DeriveGeneric #-} #endif @@ -33,11 +33,13 @@ import Data.Array (Array, (!), listArray) import Data.Char (GeneralCategory, isDigit, ord) import Data.Data (Data, Typeable) +import Data.Functor ((<$>)) import Data.Ix (Ix) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(mempty)) #endif -import Data.String (IsString) +import Data.Semigroup (Semigroup) +import Data.String (IsString(..)) import Data.Text.Lazy.Builder (Builder) import Foreign.Storable (Storable) @@ -48,14 +50,23 @@ #if MIN_VERSION_base(4,4,0) import GHC.Generics (Generic) #endif +import GHC.Show (showLitChar) +#if MIN_VERSION_base(4,4,0) +import GHC.Show (showLitString) +#endif import Prelude hiding (Show) -import Text.Printf (PrintfArg, PrintfType) +import qualified Text.ParserCombinators.ReadP as ReadP (get) +import Text.ParserCombinators.ReadP (many) +import qualified Text.ParserCombinators.ReadPrec as ReadPrec (get) +import Text.ParserCombinators.ReadPrec (ReadPrec, lift) +import Text.Printf (IsChar, PrintfArg, PrintfType) +import Text.Read (Read(..), readListPrecDefault) import qualified Text.Show as S (Show) import Text.Show.Text.Classes (Show(..)) import Text.Show.Text.Data.Integral (showbIntPrec) -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) +import Text.Show.Text.TH.Internal (deriveShow) import Text.Show.Text.Utils ((<>), s) #include "inline.h" @@ -95,7 +106,6 @@ showbLitChar '\v' = "\\v" showbLitChar '\SO' = "\\SO" showbLitChar c = s '\\' <> (asciiTabB ! ord c) -{-# INLINE showbLitChar #-} -- | Convert a 'String' to a 'Builder' (surrounded by double quotes). -- @@ -114,7 +124,6 @@ showbLitString (c:d:cs) | c > '\DEL' && isDigit d = s '\\' <> showbIntPrec 0 (ord c) <> "\\&" <> s d <> showbLitString cs showbLitString (c:cs) = showbLitChar c <> showbLitString cs -{-# INLINE showbLitString #-} -- | Convert a 'GeneralCategory' to a 'Builder'. -- @@ -130,7 +139,7 @@ showbList = showbString INLINE_INST_FUN(showbList) -$(deriveShowPragmas defaultInlineShowb ''GeneralCategory) +$(deriveShow ''GeneralCategory) -- | The @Text@ 'T.Show' instance for 'LitChar' is like that of a regular 'Char', -- except it is not escaped by single quotes. That is, @@ -148,19 +157,45 @@ #if MIN_VERSION_base(4,4,0) , Generic #endif + , IsChar , Ix , Ord , PrintfArg - , Read - , S.Show , Storable , Typeable ) +instance IsString [LitChar] where + fromString = map LitChar + +instance Read LitChar where + readPrec = LitChar <$> ReadPrec.get + INLINE_INST_FUN(readPrec) + + readListPrec = (fmap . map) LitChar (readListPrec :: ReadPrec [Char]) + INLINE_INST_FUN(readListPrec) + + readList = + (fmap . map . mapFst . map) LitChar (readList :: ReadS [Char]) + where + mapFst :: (a -> b) -> (a, c) -> (b, c) + mapFst f (x, y) = (f x, y) + INLINE_INST_FUN(readList) + instance Show LitChar where showb = showbLitChar . getLitChar INLINE_INST_FUN(showb) + + showbList = showbString . map getLitChar + INLINE_INST_FUN(showbList) +instance S.Show LitChar where + showsPrec _ = showLitChar . getLitChar + INLINE_INST_FUN(showsPrec) + + showList = showList . map getLitChar + INLINE_INST_FUN(showList) + -- | The @Text@ 'T.Show' instance for 'LitString' is like that of a regular -- 'String', except it is not escaped by double quotes. That is, -- @@ -180,8 +215,7 @@ , Ord , PrintfArg , PrintfType - , Read - , S.Show + , Semigroup , Typeable ) @@ -194,6 +228,36 @@ {-# INLINE toList #-} #endif +instance Read LitString where + readPrec = LitString <$> (lift $ many ReadP.get) + INLINE_INST_FUN(readPrec) + + readListPrec = readListPrecDefault + INLINE_INST_FUN(readListPrec) + instance Show LitString where showb = showbLitString . getLitString INLINE_INST_FUN(showb) + +instance S.Show LitString where + showsPrec _ = showLitString . getLitString +#if MIN_VERSION_base(4,4,0) + INLINE_INST_FUN(showsPrec) +#else + where + -- Taken directly from @GHC.Show@ + showLitString :: String -> ShowS + -- Same as 'showLitChar', but for strings + -- It converts the string to a string using Haskell escape conventions + -- for non-printable characters. Does not add double-quotes around the + -- whole thing; the caller should do that. + -- The main difference from showLitChar (apart from the fact that the + -- argument is a string not a list) is that we must escape double-quotes + showLitString [] str = str + showLitString ('"' : cs) str = showString "\\\"" (showLitString cs str) + showLitString (c : cs) str = showLitChar c (showLitString cs str) + -- Making 's' an explicit parameter makes it clear to GHC that + -- showLitString has arity 2, which avoids it allocating an extra lambda + -- The sticking point is the recursive call to (showLitString cs), which + -- it can't figure out would be ok with arity 2. +#endif diff --git a/src/Text/Show/Text/Data/Data.hs b/src/Text/Show/Text/Data/Data.hs --- a/src/Text/Show/Text/Data/Data.hs +++ b/src/Text/Show/Text/Data/Data.hs @@ -28,8 +28,8 @@ import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Data.List () import Text.Show.Text.Data.Ratio () -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec, - defaultInlineShowb) +import Text.Show.Text.TH.Internal (deriveShow, deriveShowPragmas, + defaultInlineShowbPrec, defaultInlineShowb) #include "inline.h" @@ -69,8 +69,8 @@ {-# INLINE showbConstrRepPrec #-} $(deriveShowPragmas defaultInlineShowbPrec ''DataType) -$(deriveShowPragmas defaultInlineShowbPrec ''DataRep) -$(deriveShowPragmas defaultInlineShowbPrec ''ConstrRep) +$(deriveShow ''DataRep) +$(deriveShow ''ConstrRep) $(deriveShowPragmas defaultInlineShowb ''Fixity) instance Show Constr where diff --git a/src/Text/Show/Text/Data/Fixed.hs b/src/Text/Show/Text/Data/Fixed.hs --- a/src/Text/Show/Text/Data/Fixed.hs +++ b/src/Text/Show/Text/Data/Fixed.hs @@ -24,12 +24,13 @@ #if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(..)) import Data.Int (Int64) +import Data.Semigroup (timesN) # if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (mempty) # endif import Text.Show.Text.Data.Integral () -import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) +import Text.Show.Text.Utils ((<>), lengthB, s) #else import Data.Fixed (Fixed, showFixed) import Data.Text.Lazy.Builder (fromString) @@ -60,26 +61,25 @@ # endif #else showbFixed chopTrailingZeroes = fromString . showFixed chopTrailingZeroes -#endif {-# INLINE showbFixed #-} +#endif #if MIN_VERSION_base(4,7,0) -- | Only works for positive 'Integer's. showbIntegerZeroes :: Bool -> Int64 -> Integer -> Builder showbIntegerZeroes True _ 0 = mempty -showbIntegerZeroes chopTrailingZeroes digits a = replicateB (digits - lengthB sh) (s '0') <> sh' +showbIntegerZeroes chopTrailingZeroes digits a + = timesN (fromIntegral . max 0 $ digits - lengthB sh) (s '0') <> sh' where sh, sh' :: Builder sh = showb a sh' = if chopTrailingZeroes then chopZeroesB a else sh -{-# INLINE showbIntegerZeroes #-} -- | Chops off the trailing zeroes of an 'Integer'. chopZeroesB :: Integer -> Builder chopZeroesB 0 = mempty chopZeroesB a | mod a 10 == 0 = chopZeroesB (div a 10) chopZeroesB a = showb a -{-# INLINE chopZeroesB #-} -- | Prepends a dot to a non-empty 'Builder'. withDotB :: Builder -> Builder diff --git a/src/Text/Show/Text/Data/Floating.hs b/src/Text/Show/Text/Data/Floating.hs --- a/src/Text/Show/Text/Data/Floating.hs +++ b/src/Text/Show/Text/Data/Floating.hs @@ -376,7 +376,6 @@ | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n | otherwise = base^n -{-# INLINE expt #-} -- | Cached powers of two. expts :: Array Int Integer diff --git a/src/Text/Show/Text/Data/Integral.hs b/src/Text/Show/Text/Data/Integral.hs --- a/src/Text/Show/Text/Data/Integral.hs +++ b/src/Text/Show/Text/Data/Integral.hs @@ -1,7 +1,4 @@ {-# LANGUAGE CPP, MagicHash, OverloadedStrings #-} -#if !defined(RECENT_TEXT) -{-# LANGUAGE BangPatterns, RankNTypes, ScopedTypeVariables, UnboxedTuples #-} -#endif {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module: Text.Show.Text.Data.Integral @@ -40,6 +37,7 @@ import Data.Monoid (mempty) #endif import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder.Int (decimal) import Data.Word ( Word8 , Word16 , Word32 @@ -61,23 +59,6 @@ import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Utils ((<>), s, toString) -#if defined(RECENT_TEXT) -import Data.Text.Lazy.Builder.Int (decimal) -#else -import Control.Monad.ST (ST) - -import qualified Data.ByteString.Unsafe as B -import Data.Text.Array (MArray, unsafeWrite) -import Data.Text.Internal.Builder (writeN) -import Data.Text.Internal.Builder.Int.Digits (digits) - -import GHC.Base (quotInt, remInt) -import GHC.Integer.GMP.Internals (Integer(..)) -import GHC.Num (quotRemInteger) - -import Text.Show.Text.Utils (i2d) -#endif - #include "inline.h" -- | Convert an 'Int' to a 'Builder' with the given precedence. @@ -164,7 +145,6 @@ b' :: Builder b' = s c <> b -{-# INLINE showbIntAtBase #-} -- | Show /non-negative/ 'Integral' numbers in base 2. -- @@ -221,218 +201,6 @@ showbWord64 :: Word64 -> Builder showbWord64 = decimal {-# INLINE showbWord64 #-} - -#if !defined(RECENT_TEXT) -decimal :: Integral a => a -> Builder -{-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-} -{-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-} -{-# RULES "decimal/Int16" decimal = boundedDecimal :: Int16 -> Builder #-} -{-# RULES "decimal/Int32" decimal = boundedDecimal :: Int32 -> Builder #-} -{-# RULES "decimal/Int64" decimal = boundedDecimal :: Int64 -> Builder #-} -{-# RULES "decimal/Word" decimal = positive :: Word -> Builder #-} -{-# RULES "decimal/Word8" decimal = positive :: Word8 -> Builder #-} -{-# RULES "decimal/Word16" decimal = positive :: Word16 -> Builder #-} -{-# RULES "decimal/Word32" decimal = positive :: Word32 -> Builder #-} -{-# RULES "decimal/Word64" decimal = positive :: Word64 -> Builder #-} -{-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-} -decimal i = decimal' (<= -128) i -{-# NOINLINE decimal #-} - -boundedDecimal :: (Integral a, Bounded a) => a -> Builder -{-# SPECIALIZE boundedDecimal :: Int -> Builder #-} -{-# SPECIALIZE boundedDecimal :: Int8 -> Builder #-} -{-# SPECIALIZE boundedDecimal :: Int16 -> Builder #-} -{-# SPECIALIZE boundedDecimal :: Int32 -> Builder #-} -{-# SPECIALIZE boundedDecimal :: Int64 -> Builder #-} -boundedDecimal i = decimal' (== minBound) i - -decimal' :: Integral a => (a -> Bool) -> a -> Builder -{-# INLINE decimal' #-} -decimal' p i - | i < 0 = if p i - then let (q, r) = i `quotRem` 10 - qq = -q - !n = countDigits qq - in writeN (n + 2) $ \marr off -> do - unsafeWrite marr off minus - posDecimal marr (off+1) n qq - unsafeWrite marr (off+n+1) (i2w (-r)) - else let j = -i - !n = countDigits j - in writeN (n + 1) $ \marr off -> - unsafeWrite marr off minus >> posDecimal marr (off+1) n j - | otherwise = positive i - -positive :: Integral a => a -> Builder -{-# SPECIALIZE positive :: Int -> Builder #-} -{-# SPECIALIZE positive :: Int8 -> Builder #-} -{-# SPECIALIZE positive :: Int16 -> Builder #-} -{-# SPECIALIZE positive :: Int32 -> Builder #-} -{-# SPECIALIZE positive :: Int64 -> Builder #-} -{-# SPECIALIZE positive :: Word -> Builder #-} -{-# SPECIALIZE positive :: Word8 -> Builder #-} -{-# SPECIALIZE positive :: Word16 -> Builder #-} -{-# SPECIALIZE positive :: Word32 -> Builder #-} -{-# SPECIALIZE positive :: Word64 -> Builder #-} -positive i - | i < 10 = writeN 1 $ \marr off -> unsafeWrite marr off (i2w i) - | otherwise = let !n = countDigits i - in writeN n $ \marr off -> posDecimal marr off n i - -posDecimal :: Integral a => - forall s. MArray s -> Int -> Int -> a -> ST s () -{-# INLINE posDecimal #-} -posDecimal marr off0 ds v0 = go (off0 + ds - 1) v0 - where go off v - | v >= 100 = do - let (q, r) = v `quotRem` 100 - write2 off r - go (off - 2) q - | v < 10 = unsafeWrite marr off (i2w v) - | otherwise = write2 off v - write2 off i0 = do - let i = fromIntegral i0; j = i + i - unsafeWrite marr off $ get (j + 1) - unsafeWrite marr (off - 1) $ get j - get = fromIntegral . B.unsafeIndex digits - -minus, zero :: Word16 -{-# INLINE minus #-} -{-# INLINE zero #-} -minus = 45 -zero = 48 - -i2w :: Integral a => a -> Word16 -{-# INLINE i2w #-} -i2w v = zero + fromIntegral v - -countDigits :: Integral a => a -> Int -{-# INLINE countDigits #-} -countDigits v0 - | fromIntegral v64 == v0 = go 1 v64 - | otherwise = goBig 1 (fromIntegral v0) - where v64 = fromIntegral v0 - goBig !k (v :: Integer) - | v > big = goBig (k + 19) (v `quot` big) - | otherwise = go k (fromIntegral v) - big = 10000000000000000000 - go !k (v :: Word64) - | v < 10 = k - | v < 100 = k + 1 - | v < 1000 = k + 2 - | v < 1000000000000 = - k + if v < 100000000 - then if v < 1000000 - then if v < 10000 - then 3 - else 4 + fin v 100000 - else 6 + fin v 10000000 - else if v < 10000000000 - then 8 + fin v 1000000000 - else 10 + fin v 100000000000 - | otherwise = go (k + 12) (v `quot` 1000000000000) - fin v n = if v >= n then 1 else 0 - -hexadecimal :: Integral a => a -> Builder -{-# SPECIALIZE hexadecimal :: Int -> Builder #-} -{-# SPECIALIZE hexadecimal :: Int8 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Int16 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Int32 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Int64 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Word -> Builder #-} -{-# SPECIALIZE hexadecimal :: Word8 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Word16 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Word32 -> Builder #-} -{-# SPECIALIZE hexadecimal :: Word64 -> Builder #-} -{-# RULES "hexadecimal/Integer" - hexadecimal = hexInteger :: Integer -> Builder #-} -hexadecimal i - | i < 0 = error hexErrMsg - | otherwise = go i - where - go n | n < 16 = hexDigit n - | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16) -{-# NOINLINE[0] hexadecimal #-} - -hexInteger :: Integer -> Builder -hexInteger i - | i < 0 = error hexErrMsg - | otherwise = integer 16 i - -hexErrMsg :: String -hexErrMsg = "Data.Text.Lazy.Builder.Int.hexadecimal: applied to negative number" - -hexDigit :: Integral a => a -> Builder -hexDigit n - | n <= 9 = s $! i2d (fromIntegral n) - | otherwise = s $! toEnum (fromIntegral n + 87) -{-# INLINE hexDigit #-} - -data T = T !Integer !Int - -integer :: Int -> Integer -> Builder -integer 10 (S# i#) = decimal (I# i#) -integer 16 (S# i#) = hexadecimal (I# i#) -integer base i - | i < 0 = s '-' <> go (-i) - | otherwise = go i - where - go n | n < maxInt = int (fromInteger n) - | otherwise = putH (splitf (maxInt * maxInt) n) - - splitf p n - | p > n = [n] - | otherwise = splith p (splitf (p*p) n) - - splith p (n:ns) = case n `quotRemInteger` p of - (# q,r #) | q > 0 -> q : r : splitb p ns - | otherwise -> r : splitb p ns - splith _ _ = error "splith: the impossible happened." - - splitb p (n:ns) = case n `quotRemInteger` p of - (# q,r #) -> q : r : splitb p ns - splitb _ _ = [] - - T maxInt10 maxDigits10 = - until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1) - where mi = fromIntegral (maxBound :: Int) - T maxInt16 maxDigits16 = - until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1) - where mi = fromIntegral (maxBound :: Int) - - fstT (T a _) = a - - maxInt | base == 10 = maxInt10 - | otherwise = maxInt16 - maxDigits | base == 10 = maxDigits10 - | otherwise = maxDigits16 - - putH (n:ns) = case n `quotRemInteger` maxInt of - (# x,y #) - | q > 0 -> int q <> pblock r <> putB ns - | otherwise -> int r <> putB ns - where q = fromInteger x - r = fromInteger y - putH _ = error "putH: the impossible happened" - - putB (n:ns) = case n `quotRemInteger` maxInt of - (# x,y #) -> pblock q <> pblock r <> putB ns - where q = fromInteger x - r = fromInteger y - putB _ = mempty - - int :: Int -> Builder - int x | base == 10 = decimal x - | otherwise = hexadecimal x - - pblock = loop maxDigits - where - loop !d !n - | d == 1 = hexDigit n - | otherwise = loop (d-1) q <> hexDigit r - where q = n `quotInt` base - r = n `remInt` base -#endif instance Show Int where showbPrec = showbIntPrec diff --git a/src/Text/Show/Text/Data/OldTypeable.hs b/src/Text/Show/Text/Data/OldTypeable.hs --- a/src/Text/Show/Text/Data/OldTypeable.hs +++ b/src/Text/Show/Text/Data/OldTypeable.hs @@ -23,7 +23,7 @@ import Text.Show.Text.Classes (Show(showb, showbPrec), showbParen, showbSpace) import Text.Show.Text.Data.Typeable.Utils (showbArgs, showbTuple) -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Utils ((<>), isTupleString, s) -- | Convert a 'TyCon' to a 'Builder'. -- This function is only available with @base-4.7@. @@ -54,8 +54,7 @@ -- | Does the 'TyCon' represent a tuple type constructor? isTupleTyCon :: TyCon -> Bool -isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True -isTupleTyCon _ = False +isTupleTyCon (TyCon _ _ _ str) = isTupleString str {-# INLINE isTupleTyCon #-} instance Show TyCon where diff --git a/src/Text/Show/Text/Data/Proxy.hs b/src/Text/Show/Text/Data/Proxy.hs --- a/src/Text/Show/Text/Data/Proxy.hs +++ b/src/Text/Show/Text/Data/Proxy.hs @@ -31,7 +31,7 @@ showbProxy = showb {-# INLINE showbProxy #-} --- TODO: See why 'deriveShow' can't detect Proxy's phantom type correctly +-- TODO: Derive with TH once it can detect phantom types properly instance Show (Proxy s) where showbPrec = $(mkShowbPrec ''Proxy) INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Tuple.hs b/src/Text/Show/Text/Data/Tuple.hs --- a/src/Text/Show/Text/Data/Tuple.hs +++ b/src/Text/Show/Text/Data/Tuple.hs @@ -35,7 +35,7 @@ import Prelude hiding (Show) import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) +import Text.Show.Text.TH.Internal (deriveShow) #include "inline.h" @@ -159,21 +159,21 @@ showb15Tuple = showb {-# INLINE showb15Tuple #-} -$(deriveShowPragmas defaultInlineShowb ''()) -$(deriveShowPragmas defaultInlineShowb ''(,)) -$(deriveShowPragmas defaultInlineShowb ''(,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,,,)) -$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,,,,)) +$(deriveShow ''()) +$(deriveShow ''(,)) +$(deriveShow ''(,,)) +$(deriveShow ''(,,,)) +$(deriveShow ''(,,,,)) +$(deriveShow ''(,,,,,)) +$(deriveShow ''(,,,,,,)) +$(deriveShow ''(,,,,,,,)) +$(deriveShow ''(,,,,,,,,)) +$(deriveShow ''(,,,,,,,,,)) +$(deriveShow ''(,,,,,,,,,,)) +$(deriveShow ''(,,,,,,,,,,,)) +$(deriveShow ''(,,,,,,,,,,,,)) +$(deriveShow ''(,,,,,,,,,,,,,)) +$(deriveShow ''(,,,,,,,,,,,,,,)) instance Show a => Show1 ((,) a) where showbPrec1 = showbPrec diff --git a/src/Text/Show/Text/Data/Type/Coercion.hs b/src/Text/Show/Text/Data/Type/Coercion.hs --- a/src/Text/Show/Text/Data/Type/Coercion.hs +++ b/src/Text/Show/Text/Data/Type/Coercion.hs @@ -31,7 +31,7 @@ showbCoercion = showb {-# INLINE showbCoercion #-} --- TODO: See why 'deriveShow' doesn't detect that b is a phantom type +-- TODO: Derive with TH once it can detect phantom types properly instance Show (Coercion a b) where showbPrec = $(mkShowbPrec ''Coercion) {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Type/Equality.hs b/src/Text/Show/Text/Data/Type/Equality.hs --- a/src/Text/Show/Text/Data/Type/Equality.hs +++ b/src/Text/Show/Text/Data/Type/Equality.hs @@ -31,7 +31,7 @@ showbPropEquality = showb {-# INLINE showbPropEquality #-} --- TODO: See why 'deriveShow' doesn't detect that b is a phantom type +-- TODO: Derive with TH once it can detect phantom types properly instance Show (a :~: b) where showbPrec = $(mkShowbPrec ''(:~:)) {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Typeable.hs b/src/Text/Show/Text/Data/Typeable.hs --- a/src/Text/Show/Text/Data/Typeable.hs +++ b/src/Text/Show/Text/Data/Typeable.hs @@ -27,7 +27,7 @@ import Text.Show.Text.Classes (Show(showb, showbPrec), showbParen, showbSpace) import Text.Show.Text.Data.List () import Text.Show.Text.Data.Typeable.Utils (showbArgs, showbTuple) -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Utils ((<>), isTupleString, s) #include "inline.h" @@ -51,7 +51,6 @@ where tycon = typeRepTyCon tyrep tys = typeRepArgs tyrep -{-# INLINE showbTypeRepPrec #-} #if !(MIN_VERSION_base(4,4,0)) -- | The list 'TyCon'. @@ -66,11 +65,7 @@ -- | Does the 'TyCon' represent a tuple type constructor? isTupleTyCon :: TyCon -> Bool -isTupleTyCon tycon = case tyconStr of - ('(':',':_) -> True - _ -> False - where - tyconStr = tyConString tycon +isTupleTyCon = isTupleString . tyConString {-# INLINE isTupleTyCon #-} -- | Convert a 'TyCon' to a 'Builder'. diff --git a/src/Text/Show/Text/Data/Typeable/Utils.hs b/src/Text/Show/Text/Data/Typeable/Utils.hs --- a/src/Text/Show/Text/Data/Typeable/Utils.hs +++ b/src/Text/Show/Text/Data/Typeable/Utils.hs @@ -27,7 +27,6 @@ showbArgs _ [] = mempty showbArgs _ [a] = showbPrec 10 a showbArgs sep (a:as) = showbPrec 10 a <> sep <> showbArgs sep as -{-# INLINE showbArgs #-} -- | Helper function for showing a list of 'Show' instances in a tuple. showbTuple :: Show a => [a] -> Builder diff --git a/src/Text/Show/Text/Debug/Trace.hs b/src/Text/Show/Text/Debug/Trace.hs --- a/src/Text/Show/Text/Debug/Trace.hs +++ b/src/Text/Show/Text/Debug/Trace.hs @@ -12,6 +12,11 @@ These can be useful for investigating bugs or performance problems. They should /not/ be used in production code. +If you do not wish to require 'Show' instances for your @trace@ functions, +the "Text.Show.Text.Debug.Trace.TH" and "Text.Show.Text.Debug.Trace.Generic" modules +exist to convert the input to a debug message using Template Haskell or generics, +respectively. + /Since: 0.5/ -} module Text.Show.Text.Debug.Trace ( diff --git a/src/Text/Show/Text/Debug/Trace/Generic.hs b/src/Text/Show/Text/Debug/Trace/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Debug/Trace/Generic.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-| +Module: Text.Show.Text.Debug.Trace.Generic +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Functions that trace the values of 'Generic' instances (even if they are not +instances of @Show@). + +/Since: 0.6/ +-} +module Text.Show.Text.Debug.Trace.Generic ( + genericTraceShow + , genericTraceShowId + , genericTraceShowM + ) where + +import GHC.Generics (Generic, Rep) + +import Text.Show.Text.Debug.Trace (traceLazy, traceMLazy) +import Text.Show.Text.Generic (GShow, genericShowLazy) + +-- | Outputs the shown trace message of its first argument (a 'Generic' instance) +-- before returning the second argument. +-- +-- /Since: 0.6/ +genericTraceShow :: (Generic a, GShow (Rep a)) => a -> b -> b +genericTraceShow = traceLazy . genericShowLazy + +-- | Outputs the shown trace message of its argument (a 'Generic' instance) before +-- returning that argument. +-- +-- /Since: 0.6/ +genericTraceShowId :: (Generic a, GShow (Rep a)) => a -> a +genericTraceShowId a = traceLazy (genericShowLazy a) a + +-- | Outputs the shown trace message of its argument (a 'Generic' instance) in an +-- arbitrary monad. +-- +-- /Since: 0.6/ +genericTraceShowM :: (Generic a, GShow (Rep a), Monad m) => a -> m () +genericTraceShowM = traceMLazy . genericShowLazy diff --git a/src/Text/Show/Text/Debug/Trace/TH.hs b/src/Text/Show/Text/Debug/Trace/TH.hs --- a/src/Text/Show/Text/Debug/Trace/TH.hs +++ b/src/Text/Show/Text/Debug/Trace/TH.hs @@ -7,8 +7,8 @@ Stability: Experimental Portability: GHC -Functions that splice traces into source code which take arbitrary @data@ types or -@newtypes@ as arguments (even if they are not instances of @Show@). You need to +Functions that splice traces into source code which take arbitrary data types or +families as arguments (even if they are not instances of @Show@). You need to enable the @TemplateHaskell@ language extension in order to use this module. /Since: 0.5/ diff --git a/src/Text/Show/Text/Foreign/Ptr.hs b/src/Text/Show/Text/Foreign/Ptr.hs --- a/src/Text/Show/Text/Foreign/Ptr.hs +++ b/src/Text/Show/Text/Foreign/Ptr.hs @@ -21,21 +21,22 @@ , showbForeignPtr ) where -import Data.Text.Lazy.Builder (Builder) +import Data.Semigroup (timesN) +import Data.Text.Lazy.Builder (Builder) -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr (FunPtr, IntPtr, WordPtr, castFunPtrToPtr) +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (FunPtr, IntPtr, WordPtr, castFunPtrToPtr) -import GHC.ForeignPtr (unsafeForeignPtrToPtr) -import GHC.Num (wordToInteger) -import GHC.Ptr (Ptr(..)) -import GHC.Prim (addr2Int#, int2Word#, unsafeCoerce#) +import GHC.ForeignPtr (unsafeForeignPtrToPtr) +import GHC.Num (wordToInteger) +import GHC.Ptr (Ptr(..)) +import GHC.Prim (addr2Int#, int2Word#, unsafeCoerce#) -import Prelude hiding (Show) +import Prelude hiding (Show) -import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) -import Text.Show.Text.Data.Integral (showbHex, showbIntPrec, showbWord) -import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +import Text.Show.Text.Data.Integral (showbHex, showbIntPrec, showbWord) +import Text.Show.Text.Utils ((<>), lengthB, s) #include "MachDeps.h" #include "inline.h" @@ -48,9 +49,10 @@ showbPtr (Ptr a) = padOut . showbHex $ wordToInteger (int2Word# (addr2Int# a)) where padOut :: Builder -> Builder - padOut ls = s '0' <> s 'x' - <> replicateB (2*SIZEOF_HSPTR - lengthB ls) (s '0') - <> ls + padOut ls = + s '0' <> s 'x' + <> timesN (fromIntegral . max 0 $ 2*SIZEOF_HSPTR - lengthB ls) (s '0') + <> ls -- | Convert a 'FunPtr' to a 'Builder'. Note that this does not require the -- parameterized type to be an instance of 'Show' itself. diff --git a/src/Text/Show/Text/GHC/Fingerprint.hs b/src/Text/Show/Text/GHC/Fingerprint.hs --- a/src/Text/Show/Text/GHC/Fingerprint.hs +++ b/src/Text/Show/Text/GHC/Fingerprint.hs @@ -14,6 +14,7 @@ -} module Text.Show.Text.GHC.Fingerprint (showbFingerprint) where +import Data.Semigroup (timesN) import Data.Text.Lazy.Builder (Builder) import Data.Word (Word64) @@ -23,7 +24,7 @@ import Text.Show.Text.Classes (Show(showb)) import Text.Show.Text.Data.Integral (showbHex) -import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) +import Text.Show.Text.Utils ((<>), lengthB, s) -- | Convert a 'Fingerprint' to a 'Builder'. -- This function is only available with @base-4.4.0.0@ or later. @@ -34,8 +35,7 @@ where hex16 :: Word64 -> Builder hex16 i = let hex = showbHex i - in replicateB (16 - lengthB hex) (s '0') <> hex -{-# INLINE showbFingerprint #-} + in timesN (fromIntegral . max 0 $ 16 - lengthB hex) (s '0') <> hex instance Show Fingerprint where showb = showbFingerprint diff --git a/src/Text/Show/Text/GHC/Generics.hs b/src/Text/Show/Text/GHC/Generics.hs --- a/src/Text/Show/Text/GHC/Generics.hs +++ b/src/Text/Show/Text/GHC/Generics.hs @@ -128,6 +128,7 @@ showbArityPrec = showbPrec {-# INLINE showbArityPrec #-} +-- TODO: Derive with TH once it can detect phantom types properly instance Show (U1 p) where showbPrec = $(mkShowbPrec ''U1) {-# INLINE showb #-} @@ -142,30 +143,38 @@ showbPrec1 = showbPrec {-# INLINE showbPrec1 #-} +-- TODO: Derive with TH once it can detect higher-kinded types properly instance Show (f p) => Show (Rec1 f p) where showbPrec = $(mkShowbPrec ''Rec1) {-# INLINE showbPrec #-} +-- TODO: Derive with TH once it can detect phantom types properly instance Show c => Show (K1 i c p) where showbPrec = $(mkShowbPrec ''K1) {-# INLINE showbPrec #-} +-- TODO: Derive with TH once it can detect phantom types properly instance Show c => Show1 (K1 i c) where showbPrec1 = showbPrec {-# INLINE showbPrec1 #-} +-- TODO: Derive with TH once it can detect phantom types +-- and higher-kinded types properly instance Show (f p) => Show (M1 i c f p) where showbPrec = $(mkShowbPrec ''M1) {-# INLINE showbPrec #-} +-- TODO: Derive with TH once it can detect higher-kinded types properly instance (Show (f p), Show (g p)) => Show ((f :+: g) p) where showbPrec = $(mkShowbPrec ''(:+:)) {-# INLINE showbPrec #-} +-- TODO: Derive with TH once it can detect higher-kinded types properly instance (Show (f p), Show (g p)) => Show ((f :*: g) p) where showbPrec = $(mkShowbPrec ''(:*:)) {-# INLINE showbPrec #-} +-- TODO: Derive with TH once it can detect higher-kinded types properly instance Show (f (g p)) => Show ((f :.: g) p) where showbPrec = $(mkShowbPrec ''(:.:)) {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/GHC/RTS/Flags.hs b/src/Text/Show/Text/GHC/RTS/Flags.hs --- a/src/Text/Show/Text/GHC/RTS/Flags.hs +++ b/src/Text/Show/Text/GHC/RTS/Flags.hs @@ -40,7 +40,7 @@ import Text.Show.Text.Data.List () import Text.Show.Text.Data.Maybe (showbMaybePrec) import Text.Show.Text.Utils ((<>), s) -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +import Text.Show.Text.TH.Internal (deriveShow) -- | Convert an 'RTSFlags' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.8.0.0@ or later. @@ -76,8 +76,8 @@ <> showb (minOldGenSize gcfs) <> ", heapSizeSuggestion = " <> showb (heapSizeSuggestion gcfs) - <> ", heapSizeSuggesionAuto = " - <> showbBool (heapSizeSuggesionAuto gcfs) + <> ", heapSizeSuggestionAuto = " + <> showbBool (heapSizeSuggestionAuto gcfs) <> ", oldGenFactor = " <> showbDoublePrec 0 (oldGenFactor gcfs) <> ", pcFreeHeap = " @@ -107,7 +107,6 @@ <> ", allocLimitGrace = " <> showbWord (allocLimitGrace gcfs) <> s '}' -{-# INLINE showbGCFlagsPrec #-} -- | Convert a 'ConcFlags' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.8.0.0@ or later. @@ -145,7 +144,6 @@ <> ", msecsPerTick = " <> showbIntPrec 0 (msecsPerTick ccfs) <> s '}' -{-# INLINE showbCCFlagsPrec #-} -- | Convert a 'ProfFlags' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.8.0.0@ or later. @@ -182,7 +180,6 @@ <> ", bioSelector = " <> showbMaybePrec 0 (bioSelector pfs) <> s '}' -{-# INLINE showbProfFlagsPrec #-} -- | Convert a 'TraceFlags' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.8.0.0@ or later. @@ -205,7 +202,6 @@ <> ", user = " <> showbBool (user tfs) <> s '}' -{-# INLINE showbTraceFlagsPrec #-} -- | Convert a 'TickyFlags' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.8.0.0@ or later. @@ -215,17 +211,17 @@ showbTickyFlagsPrec = showbPrec {-# INLINE showbTickyFlagsPrec #-} -$(deriveShowPragmas defaultInlineShowbPrec ''RTSFlags) +$(deriveShow ''RTSFlags) instance Show GCFlags where showbPrec = showbGCFlagsPrec {-# INLINE showbPrec #-} -$(deriveShowPragmas defaultInlineShowbPrec ''ConcFlags) +$(deriveShow ''ConcFlags) -$(deriveShowPragmas defaultInlineShowbPrec ''MiscFlags) +$(deriveShow ''MiscFlags) -$(deriveShowPragmas defaultInlineShowbPrec ''DebugFlags) +$(deriveShow ''DebugFlags) instance Show CCFlags where showbPrec = showbCCFlagsPrec @@ -239,4 +235,4 @@ showbPrec = showbTraceFlagsPrec {-# INLINE showbPrec #-} -$(deriveShowPragmas defaultInlineShowbPrec ''TickyFlags) +$(deriveShow ''TickyFlags) diff --git a/src/Text/Show/Text/GHC/StaticPtr.hs b/src/Text/Show/Text/GHC/StaticPtr.hs --- a/src/Text/Show/Text/GHC/StaticPtr.hs +++ b/src/Text/Show/Text/GHC/StaticPtr.hs @@ -24,7 +24,7 @@ import Text.Show.Text.Data.Integral () import Text.Show.Text.Data.List () import Text.Show.Text.Data.Tuple () -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +import Text.Show.Text.TH.Internal (deriveShow) -- | Conver a 'StaticPtrInfo' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.8.0.0@ or later. @@ -34,4 +34,4 @@ showbStaticPtrInfoPrec = showbPrec {-# INLINE showbStaticPtrInfoPrec #-} -$(deriveShowPragmas defaultInlineShowbPrec ''StaticPtrInfo) +$(deriveShow ''StaticPtrInfo) diff --git a/src/Text/Show/Text/GHC/Stats.hs b/src/Text/Show/Text/GHC/Stats.hs --- a/src/Text/Show/Text/GHC/Stats.hs +++ b/src/Text/Show/Text/GHC/Stats.hs @@ -22,7 +22,7 @@ import Text.Show.Text.Classes (showbPrec) import Text.Show.Text.Data.Integral () import Text.Show.Text.Data.Floating () -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +import Text.Show.Text.TH.Internal (deriveShow) -- | Convert a 'GCStats' value to a 'Builder' with the given precedence. -- This function is only available with @base-4.5.0.0@ or later. @@ -32,4 +32,4 @@ showbGCStatsPrec = showbPrec {-# INLINE showbGCStatsPrec #-} -$(deriveShowPragmas defaultInlineShowbPrec ''GCStats) +$(deriveShow ''GCStats) diff --git a/src/Text/Show/Text/Generic.hs b/src/Text/Show/Text/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Generic.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE CPP, DeriveGeneric, FlexibleContexts, FlexibleInstances, + OverloadedStrings, ScopedTypeVariables, TypeOperators #-} +{-| +Module: Text.Show.Text.Generic +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Generic versions of 'Show' class functions, as an alternative to "Text.Show.Text.TH", +which uses Template Haskell. This module is only available if the compiler supports +generics (on GHC, 7.2 or above). + +This implementation is based off of the @Generics.Deriving.Show@ module from the +@generic-deriving@ library. + +/Since: 0.6/ +-} +module Text.Show.Text.Generic ( + -- * Generic @show@ functions + -- $generics + + -- ** Understanding a compiler error + -- $generic_err + genericShow + , genericShowLazy + , genericShowPrec + , genericShowPrecLazy + , genericShowList + , genericShowListLazy + , genericShowb + , genericShowbPrec + , genericShowbList + , genericPrint + , genericPrintLazy + , genericHPrint + , genericHPrintLazy + -- * The 'GShow' class + , GShow(..) + , ConType(..) + ) where + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mempty) +#endif +import qualified Data.Text as TS (Text) +import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) +import qualified Data.Text.Lazy as TL (Text) +import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) + +import GHC.Generics +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import System.IO (Handle) + +import qualified Text.Show as S (Show) +import Text.Show.Text.Classes (Show(showbPrec), showbListDefault, + showbParen, showbSpace) +import Text.Show.Text.Instances () +import Text.Show.Text.Utils ((<>), isInfixTypeCon, isTupleString, + s, toString) + +#include "inline.h" + +{- $generics + +'Show' instances can be easily defined for data types that are 'Generic' instances. +The easiest way to do this is to use the @DeriveGeneric@ extension. + +@ +{-# LANGUAGE DeriveGeneric #-} +import Text.Show.Text +import Text.Show.Generic (genericShowbPrec) + +data D a = Nullary + | Unary Int + | Product String Char a + | Record { testOne :: Double + , testTwo :: Bool + , testThree :: D a + } + +instance Show a => Show (D a) where + showbPrec = 'genericShowbPrec' +@ + +@D@ now has a 'Show' instance analogous to what would be generated by a +@deriving Show@ clause. + +-} + +{- $generic_err + +Suppose you intend to tuse 'genericShowbPrec' to define a 'Show' instance. + +@ +data Oops = Oops + -- forgot to add \"deriving Generic\" here! + +instance Show Oops where + showbPrec = 'genericShowbPrec' +@ + +If you forget to add a @deriving 'Generic'@ clause to your data type, at +compile-time, you will get an error message that begins roughly as follows: + +@ +No instance for ('GShow' (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. +-} + +-- | Converts a 'Generic' instance to a strict 'TS.Text'. +-- +-- /Since: 0.6/ +genericShow :: (Generic a, GShow (Rep a)) => a -> TS.Text +genericShow = toStrict . genericShowLazy + +-- | Converts a 'Generic' instance to a lazy 'TL.Text'. +-- +-- /Since: 0.6/ +genericShowLazy :: (Generic a, GShow (Rep a)) => a -> TL.Text +genericShowLazy = toLazyText . genericShowb + +-- | Converts a 'Generic' instance to a strict 'TS.Text' with the given precedence. +-- +-- /Since: 0.6/ +genericShowPrec :: (Generic a, GShow (Rep a)) => Int -> a -> TS.Text +genericShowPrec p = toStrict . genericShowPrecLazy p + +-- | Converts a 'Generic' instance to a lazy 'TL.Text' with the given precedence. +-- +-- /Since: 0.6/ +genericShowPrecLazy :: (Generic a, GShow (Rep a)) => Int -> a -> TL.Text +genericShowPrecLazy p = toLazyText . genericShowbPrec p + +-- | Converts a list of 'Generic' instances to a strict 'TS.Text'. +-- +-- /Since: 0.6/ +genericShowList :: (Generic a, GShow (Rep a)) => [a] -> TS.Text +genericShowList = toStrict . genericShowListLazy + +-- | Converts a list of 'Generic' instances to a lazy 'TL.Text'. +-- +-- /Since: 0.6/ +genericShowListLazy :: (Generic a, GShow (Rep a)) => [a] -> TL.Text +genericShowListLazy = toLazyText . genericShowbList + +-- | Converts a 'Generic' instance to a 'Builder' with the given precedence. +-- +-- /Since: 0.6/ +genericShowb :: (Generic a, GShow (Rep a)) => a -> Builder +genericShowb = genericShowbPrec 0 + +-- | Converts a 'Generic' instance to a 'Builder' with the given precedence. +-- +-- /Since: 0.6/ +genericShowbPrec :: (Generic a, GShow (Rep a)) => Int -> a -> Builder +genericShowbPrec p = gShowbPrec Pref p . from + +-- | Converts a list of 'Generic' instances to a 'Builder'. +-- +-- /Since: 0.6/ +genericShowbList :: (Generic a, GShow (Rep a)) => [a] -> Builder +genericShowbList = showbListDefault genericShowb + +-- | Writes a 'Generic' instance's strict 'TS.Text' representation to the standard +-- output, followed by a newline. +-- +-- /Since: 0.6/ +genericPrint :: (Generic a, GShow (Rep a)) => a -> IO () +genericPrint = TS.putStrLn . genericShow + +-- | Writes a 'Generic' instance's lazy 'TL.Text' representation to the standard +-- output, followed by a newline. +-- +-- /Since: 0.6/ +genericPrintLazy :: (Generic a, GShow (Rep a)) => a -> IO () +genericPrintLazy = TL.putStrLn . genericShowLazy + +-- | Writes a 'Generic' instance's strict 'TS.Text' representation to the given file +-- handle, followed by a newline. +-- +-- /Since: 0.6/ +genericHPrint :: (Generic a, GShow (Rep a)) => Handle -> a -> IO () +genericHPrint h = TS.hPutStrLn h . genericShow + +-- | Writes a 'Generic' instance's lazy 'TL.Text' representation to the given file +-- handle, followed by a newline. +-- +-- /Since: 0.6/ +genericHPrintLazy :: (Generic a, GShow (Rep a)) => Handle -> a -> IO () +genericHPrintLazy h = TL.hPutStrLn h . genericShowLazy + +-- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'), +-- or infix ('Inf'). +-- +-- /Since: 0.6/ +data ConType = Rec | Tup | Pref | Inf Builder + deriving (Eq, Generic, Ord, S.Show) + +instance Show ConType where + showbPrec = genericShowbPrec + INLINE_INST_FUN(showbPrec) + +-- | Class of generic representation types ('Rep') that can be converted to +-- a 'Builder'. +-- +-- /Since: 0.6/ +class GShow f where + -- This function is used as the default generic implementation of 'showbPrec'. + gShowbPrec :: ConType -> Int -> f a -> Builder + -- Whether a representation type has any constructors. + isNullary :: f a -> Bool + isNullary = error "generic show (isNullary): unnecessary case" + +instance GShow U1 where + gShowbPrec _ _ U1 = mempty + isNullary _ = True + +instance Show c => GShow (K1 i c) where + gShowbPrec _ n (K1 a) = showbPrec n a + isNullary _ = False + +instance (Constructor c, GShow a) => GShow (M1 C c a) where + gShowbPrec _ n c@(M1 x) = case fixity of + Prefix -> showbParen (n > appPrec && not (isNullary x || conIsTuple c)) $ + (if (conIsTuple c) then mempty else fromString (conName c)) + <> (if (isNullary x || conIsTuple c) then mempty else s ' ') + <> (showbBraces t (gShowbPrec t appPrec1 x)) + Infix _ m -> showbParen (n > m) . showbBraces t $ gShowbPrec 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 . fromString $ conName c + + showbBraces :: ConType -> Builder -> Builder + showbBraces Rec b = s '{' <> b <> s '}' + showbBraces Tup b = s '(' <> b <> s ')' + showbBraces Pref b = b + showbBraces (Inf _) b = b + + conIsTuple :: M1 C c a b -> Bool + conIsTuple = isTupleString . conName + +instance (Selector s, GShow a) => GShow (M1 S s a) where + gShowbPrec t n sel@(M1 x) + | selName sel == "" = gShowbPrec t n x + | otherwise = fromString (selName sel) <> " = " <> gShowbPrec t 0 x + isNullary (M1 x) = isNullary x + +instance GShow a => GShow (M1 D d a) where + gShowbPrec t n (M1 x) = gShowbPrec t n x + +instance (GShow a, GShow b) => GShow (a :+: b) where + gShowbPrec t n (L1 x) = gShowbPrec t n x + gShowbPrec t n (R1 x) = gShowbPrec t n x + +instance (GShow a, GShow b) => GShow (a :*: b) where + gShowbPrec t@Rec _ (a :*: b) = + gShowbPrec t 0 a + <> ", " + <> gShowbPrec t 0 b + gShowbPrec t@(Inf o) n (a :*: b) = + gShowbPrec t n a + <> showbSpace + <> mBacktick + <> o + <> mBacktick + <> showbSpace + <> gShowbPrec t n b + where + mBacktick :: Builder + mBacktick = if isInfixTypeCon (toString o) + then mempty + else s '`' + gShowbPrec t@Tup _ (a :*: b) = + gShowbPrec t 0 a + <> s ',' + <> gShowbPrec t 0 b + gShowbPrec t@Pref n (a :*: b) = + gShowbPrec t n a + <> showbSpace + <> gShowbPrec t n b + + -- If we have a product then it is not a nullary constructor + isNullary _ = False diff --git a/src/Text/Show/Text/Numeric/Natural.hs b/src/Text/Show/Text/Numeric/Natural.hs --- a/src/Text/Show/Text/Numeric/Natural.hs +++ b/src/Text/Show/Text/Numeric/Natural.hs @@ -1,12 +1,5 @@ {-# LANGUAGE CPP #-} - -#if defined(MIN_VERSION_integer_gmp) -# define HAVE_GMP_BIGNAT MIN_VERSION_integer_gmp(1,0,0) -#else -# define HAVE_GMP_BIGNAT 0 -#endif - -#if HAVE_GMP_BIGNAT +#if MIN_VERSION_base(4,8,0) {-# LANGUAGE MagicHash #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -26,15 +19,12 @@ import Data.Text.Lazy.Builder (Builder) -#if HAVE_GMP_BIGNAT +#if MIN_VERSION_base(4,8,0) import GHC.Integer.GMP.Internals (Integer(..)) +import GHC.Natural (Natural(..)) import GHC.Types (Word(..)) import Text.Show.Text.Data.Integral (showbWord) -#endif - -#if MIN_VERSION_base(4,8,0) -import GHC.Natural (Natural(..)) #else import Numeric.Natural (Natural) #endif @@ -51,15 +41,10 @@ -- /Since: 0.5/ showbNaturalPrec :: Int -> Natural -> Builder #if MIN_VERSION_base(4,8,0) -# if HAVE_GMP_BIGNAT showbNaturalPrec _ (NatS# w#) = showbWord $ W# w# showbNaturalPrec p (NatJ# bn) = showbIntegerPrec p $ Jp# bn -# else -showbNaturalPrec p (Natural i) = showbIntegerPrec p i -{-# INLINE showbNaturalPrec #-} -# endif #else -showbNaturalPrec p = showbIntegerPrec p . toInteger +showbNaturalPrec p = showbIntegerPrec p . toInteger {-# INLINE showbNaturalPrec #-} #endif diff --git a/src/Text/Show/Text/System/IO.hs b/src/Text/Show/Text/System/IO.hs --- a/src/Text/Show/Text/System/IO.hs +++ b/src/Text/Show/Text/System/IO.hs @@ -50,8 +50,8 @@ import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Data.Integral (showbIntegerPrec) import Text.Show.Text.Data.Maybe () -import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb, - defaultInlineShowbPrec) +import Text.Show.Text.TH.Internal (deriveShow, deriveShowPragmas, + defaultInlineShowb, defaultInlineShowbPrec) import Text.Show.Text.Utils ((<>), s) -- | Convert a 'Handle' to a 'Builder'. @@ -143,7 +143,7 @@ INLINE_INST_FUN(showb) $(deriveShowPragmas defaultInlineShowb ''IOMode) -$(deriveShowPragmas defaultInlineShowbPrec ''BufferMode) +$(deriveShow ''BufferMode) instance Show HandlePosn where showb = showbHandlePosn diff --git a/src/Text/Show/Text/TH/Internal.hs b/src/Text/Show/Text/TH/Internal.hs --- a/src/Text/Show/Text/TH/Internal.hs +++ b/src/Text/Show/Text/TH/Internal.hs @@ -10,6 +10,9 @@ Functions to mechanically derive 'T.Show' instances or splice @show@-related expressions into Haskell source code. You need to enable the @TemplateHaskell@ language extension in order to use this module. + +This implementation is based off of the @Data.Aeson.TH@ module from the +@aeson@ library. -} module Text.Show.Text.TH.Internal ( -- * @deriveShow@ @@ -39,9 +42,15 @@ , defaultInlineShowbList ) where -import Control.Applicative ((<$>)) - -import Data.List (foldl', intersperse, isPrefixOf) +import Data.Functor ((<$>)) +import Data.List (foldl', intersperse) +#if MIN_VERSION_template_haskell(2,7,0) +import Data.List (find) +import Data.Maybe (fromJust) +#endif +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mempty) +#endif import qualified Data.Text as TS () import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) import Data.Text.Lazy (toStrict) @@ -62,57 +71,83 @@ #if __GLASGOW_HASKELL__ >= 702 import Text.Show.Text.Classes (showbList) #endif -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Utils ((<>), isInfixTypeCon, isTupleString, s) {- $deriveShow 'deriveShow' automatically generates a 'T.Show' instance declaration for a @data@ -type or @newtype@. As an example: +type, a @newtype@, a data family instance, or a whole data family. This emulates what +would (hypothetically) happen if you could attach a @deriving 'T.Show'@ clause to the +end of a data declaration. +Here are some examples of how to derive simple data types: + @ {-# LANGUAGE TemplateHaskell #-} import Text.Show.Text.TH (deriveShow) -data D a = Nullary - | Unary Int - | Product String Char a - | Record { testOne :: Double - , testTwo :: Bool - , testThree :: D a - } -$('deriveShow' 'defaultOptions' ''D) +data Letter = A | B | C +$('deriveShow' ''Letter) -- instance Show Letter where ... + +newtype Box a = Box a +$('deriveShow' ''Box) -- instance Show a => Show (Box a) where ... @ -@D@ now has a 'T.Show' instance analogous to what would be generated by a -@deriving Show@ clause. +If you are using @template-haskell-2.7.0.0@ or later, 'deriveShow' can also be used +to derive 'T.Show' instances for data families. Some examples: -Note that at the moment, there are a number of limitations to this approach: +@ +{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} +import Text.Show.Text.TH (deriveShow) -* 'deriveShow' does not support data families, so it is impossible to use - 'deriveShow' with @data instance@s or @newtype instance@s. - +class AssocClass a where + data AssocData a +instance AssocClass Int where + data AssocData Int = AssocDataInt Int Int +instance AssocClass Char where + newtype AssocData Char = AssocDataChar Char +$('deriveShow' 'AssocDataChar) -- Only one single quote! +-- Generates a Show instance for AssocDataChar, but not AssocDataInt + +data family DataFam a +data instance DataFam Int = DataFamInt Int Int +newtype instance DataFam Char = DataFamChar Char +$('deriveShow' ''DataFam) -- Two double quotes! +-- Generates Show instances for all data instances of DataFam +-- (DataFamInt and DataFamChar) +@ + +Note that at the moment, there are some limitations to this approach: +* 'deriveShow' makes the assumption that all type variables in a data type require a + 'T.Show' constraint when creating the type context. For example, if you have @data + Phantom a = Phantom@, then @('deriveShow' ''Phantom)@ will generate @instance + 'T.Show' a => 'T.Show' (Phantom a) where@, even though @'T.Show' a@ is not required. + If you want a proper 'T.Show' instance for @Phantom@, you will need to use + 'mkShowbPrec' (see the documentation of the 'mk' functions for more information). + * 'deriveShow' lacks the ability to properly detect data types with higher-kinded type parameters (e.g., @data HK f a = HK (f a)@). If you wish to derive 'T.Show' instances for these data types, you will need to use 'mkShowbPrec' (see the documentation of the 'mk' functions for more information). * Some data constructors have arguments whose 'T.Show' instance depends on a - typeclass besides 'T.Show'. For example, consider @newtype MyRatio a = MyRatio - (Ratio a)@. @'Ratio' a@ is a 'T.Show' instance only if @a@ is an instance of both - 'Integral' and 'T.Show'. Unfortunately, 'deriveShow' cannot infer that 'a' must - be an instance of 'Integral', so it cannot create a 'T.Show' instance for @MyRatio@. However, you can use 'mkShowbPrec' to get around this (see the documentation of the - 'mk' functions for more information). + typeclass besides 'T.Show'. For example, consider @newtype MyFixed a = MyFixed + (Fixed a)@. @'Fixed' a@ is a 'T.Show' instance only if @a@ is an instance of both + @HasResolution@ and 'T.Show'. Unfortunately, 'deriveShow' cannot infer that 'a' must + be an instance of 'HasResolution', so it cannot create a 'T.Show' instance for + @MyFixed@. However, you can use 'mkShowbPrec' to get around this (see the + documentation of the 'mk' functions for more information). -} --- | Generates a 'T.Show' instance declaration for the given @data@ type or @newtype@. +-- | Generates a 'T.Show' instance declaration for the given data type or family. -- -- /Since: 0.3/ deriveShow :: Name -- ^ Name of the data type to make an instance of 'T.Show' -> Q [Dec] deriveShow = deriveShowPragmas defaultPragmaOptions --- | Generates a 'T.Show' instance declaration for the given @data@ type or @newtype@. +-- | Generates a 'T.Show' instance declaration for the given data type or family. -- You shouldn't need to use this function unless you know what you are doing. -- -- Unlike 'deriveShow', this function allows configuration of whether to inline @@ -120,9 +155,12 @@ -- certain types. For example: -- -- @ +-- {-# LANGUAGE TemplateHaskell #-} +-- import Text.Show.Text.TH +-- -- data ADT a = ADT a -- $(deriveShowPragmas 'defaultInlineShowbPrec' { --- specializeTypes = [t| Int |] +-- specializeTypes = [ [t| ADT Int |] ] -- } -- ''ADT) -- @ @@ -136,93 +174,140 @@ -- showbPrec = ... -- @ -- +-- Beware: 'deriveShow' can generate extremely long code splices, so it may be unwise +-- to inline in some cases. Use with caution. +-- -- /Since: 0.5/ deriveShowPragmas :: PragmaOptions -- ^ Specifies what pragmas to generate with this instance -> Name -- ^ Name of the data type to make an instance of 'T.Show' -> Q [Dec] -#if __GLASGOW_HASKELL__ >= 702 -deriveShowPragmas opts dataName = +deriveShowPragmas opts name = do + info <- reify name + case info of + TyConI{} -> deriveShowTyCon opts name +#if MIN_VERSION_template_haskell(2,7,0) + DataConI{} -> deriveShowDataFamInst opts name + FamilyI (FamilyD DataFam _ _ _) _ -> deriveShowDataFam opts name + FamilyI (FamilyD TypeFam _ _ _) _ -> error $ ns ++ "Cannot use a type family name." + -- TODO: Figure out how this whole multiline string business works + _ -> error $ ns ++ "The name must be of a plain type constructor, data family, or data family instance constructor." #else -deriveShowPragmas _ dataName = + _ -> error $ ns ++ "The name must be of a plain type constructor." #endif - withType dataName $ \tvbs cons -> (:[]) <$> fromCons tvbs cons where - fromCons :: [TyVarBndr] -> [Con] -> Q Dec - fromCons tvbs cons = - instanceD (applyCon ''T.Show typeNames dataName) - (appT classType instanceType) - ([ funD 'showbPrec [ clause [] - (normalB $ consToShow cons) - [] - ] - ] ++ inlineShowbPrecDec - ++ inlineShowbDec - ++ inlineShowbListDec - ++ specializeDecs - ) - + ns :: String + ns = "Text.Show.Text.TH.deriveShow: " + +-- | Generates a 'T.Show' instance declaration for a plain type constructor. +deriveShowTyCon :: PragmaOptions + -> Name + -> Q [Dec] +deriveShowTyCon opts tyConName = withTyCon tyConName fromCons + where + fromCons :: [TyVarBndr] -> [Con] -> Q [Dec] + fromCons tvbs cons = (:[]) <$> + instanceD (applyCon ''T.Show typeNames) + (appT (conT ''T.Show) instanceType) + (showbPrecDecs opts cons) where - typeNames :: [Name] - typeNames = map tvbName tvbs - - instanceType :: Q Type - instanceType = foldl' appT (conT dataName) $ map varT typeNames - - classType :: Q Type - classType = conT ''T.Show - - inlineShowbPrecDec, inlineShowbDec, inlineShowbListDec :: [Q Dec] -#if __GLASGOW_HASKELL__ >= 702 - inlineShowbPrecDec = inline inlineShowbPrec 'showbPrec - inlineShowbDec = inline inlineShowb 'showb - inlineShowbListDec = inline inlineShowbList 'showbList -#else - inlineShowbPrecDec = [] - inlineShowbDec = [] - inlineShowbListDec = [] -#endif - -#if __GLASGOW_HASKELL__ >= 702 - inline :: (PragmaOptions -> Bool) -> Name -> [Q Dec] - inline isInlining funName - | isInlining opts = [ pragInlD funName -# if MIN_VERSION_template_haskell(2,8,0) - Inline FunLike AllPhases + typeNames :: [Name] + typeNames = map tvbName tvbs + + instanceType :: Q Type + instanceType = foldl' appT (conT tyConName) $ map varT typeNames + +#if MIN_VERSION_template_haskell(2,7,0) +-- | Generates a 'T.Show' instance declaration for a data family name. +deriveShowDataFam :: PragmaOptions + -> Name + -> Q [Dec] +deriveShowDataFam opts dataFamName = withDataFam dataFamName $ \tvbs decs -> + flip mapM decs $ deriveShowDataFamFromDec opts dataFamName tvbs + +-- | Generates a 'T.Show' instance declaration for a data family instance constructor. +deriveShowDataFamInst :: PragmaOptions + -> Name + -> Q [Dec] +deriveShowDataFamInst opts dataFamInstName = (:[]) <$> + withDataFamInstCon dataFamInstName (deriveShowDataFamFromDec opts) + +-- | Generates a single 'T.Show' instance declaration for a data family instance. This +-- code is used by 'deriveShowDataFam' and 'deriveShowDataFamInst' alike. +deriveShowDataFamFromDec :: PragmaOptions + -> Name + -> [TyVarBndr] + -> Dec + -> Q Dec +deriveShowDataFamFromDec opts parentName tvbs dec = + instanceD (applyCon ''T.Show lhsTypeNames) + (appT (conT ''T.Show) instanceType) + (showbPrecDecs opts $ decCons [dec]) + where + typeNames :: [Name] + typeNames = map tvbName tvbs + + -- It seems that Template Haskell's representation of the type variable binders + -- in a data family instance declaration has changed considerably with each new + -- version. Yikes. + -- + -- In @template-haskell-2.8.0.0@, only the TyVarBndrs up to the rightmost non-type + -- variable are provided, so we have to do some careful Name manipulation to get + -- the LHS of the instance context just right. + -- + -- Other versions of @template-haskell@ seem a bit more sensible. + lhsTypeNames :: [Name] +# if !(MIN_VERSION_template_haskell(2,9,0)) || MIN_VERSION_template_haskell(2,10,0) + lhsTypeNames = filterTyVars typeNames instTypes # else - (inlineSpecNoPhase True False) + lhsTypeNames = filterTyVars (take (length instTypes) typeNames) instTypes + ++ drop (length instTypes) typeNames # endif - ] - | otherwise = [] -#endif - - specializeDecs :: [Q Dec] -#if MIN_VERSION_template_haskell(2,8,0) - specializeDecs = (fmap . fmap) (PragmaD - . SpecialiseInstP - . AppT (ConT ''T.Show) - ) - (specializeTypes opts) -#else - -- There doesn't appear to be an equivalent of SpecialiseInstP in early - -- versions Template Haskell. - specializeDecs = [] + + filterTyVars :: [Name] -> [Type] -> [Name] + filterTyVars ns (SigT t _:ts) = filterTyVars ns (t:ts) + filterTyVars (_:ns) (VarT n :ts) = n : filterTyVars ns ts + filterTyVars (_:ns) (_ :ts) = filterTyVars ns ts + filterTyVars [] _ = [] + filterTyVars _ [] = [] + + rhsTypes :: [Type] + rhsTypes = instTypes ++ drop (length instTypes) (map VarT typeNames) + + instTypes :: [Type] + instTypes = let tys = case dec of + DataInstD _ _ tys' _ _ -> tys' + NewtypeInstD _ _ tys' _ _ -> tys' + _ -> error "Text.Show.Text.TH.deriveShow: The impossible happened." +# if MIN_VERSION_template_haskell(2,10,0) + in tys +# else + -- If PolyKinds is enabled, the first entries in this list will be + -- kind signatures on early versions of GHC, so drop them + in if length tys > length tvbs + then drop (length tvbs) tys + else tys +# endif + + instanceType :: Q Type + instanceType = foldl' appT (conT parentName) $ map return rhsTypes #endif {- $mk -There may be scenarios in which you want to show an arbitrary @data@ type or @newtype@ +There may be scenarios in which you want to show an arbitrary data type or family without having to make the type an instance of 'T.Show'. For these cases, "Text.Show.Text.TH" provide several functions (all prefixed with @mk@) that splice the appropriate lambda expression into your source code. -As an example, suppose you have @data ADT = ADTCon@, which is not an instance of 'T.Show'. +As an example, suppose you have @data ADT = ADT@, which is not an instance of 'T.Show'. With @mkShow@, you can still convert it to 'Text': @ {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +import Text.Show.Text.TH (mkShow) whichADT :: Bool -whichADT = $(mkShow ''ADT) ADTCon == \"ADT\" +whichADT = $(mkShow ''ADT) ADT == \"ADT\" @ 'mk' functions are also useful for creating 'T.Show' instances for data types with @@ -232,7 +317,10 @@ instance for @HigherKinded@ without too much trouble using 'mkShowbPrec': @ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +import Prelude hiding (Show) +import Text.Show.Text (Show(showbPrec)) +import Text.Show.Text.TH (mkShowbPrec) instance Show (f a) => Show (HigherKinded f a) where showbPrec = $(mkShowbPrec ''HigherKinded) @@ -240,94 +328,111 @@ -} --- | Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given data type or family -- to a strict 'TS.Text'. -- -- /Since: 0.3.1/ mkShow :: Name -> Q Exp mkShow name = [| toStrict . $(mkShowLazy name) |] --- | Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given data type or family -- to a lazy 'TL.Text'. -- -- /Since: 0.3.1/ mkShowLazy :: Name -> Q Exp mkShowLazy name = [| toLazyText . $(mkShowb name) |] --- | Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given data type or family -- to a strict 'TS.Text' with the given precedence. -- -- /Since: 0.3.1/ mkShowPrec :: Name -> Q Exp mkShowPrec name = [| \p -> toStrict . $(mkShowPrecLazy name) p |] --- | Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given data type or family -- to a lazy 'TL.Text' with the given precedence. -- -- /Since: 0.3.1/ mkShowPrecLazy :: Name -> Q Exp mkShowPrecLazy name = [| \p -> toLazyText . $(mkShowbPrec name) p |] --- | Generates a lambda expression which converts the given list of @data@ types or --- @newtype@s to a strict 'TS.Text' in which the values are surrounded by square +-- | Generates a lambda expression which converts the given list of data types or +-- families to a strict 'TS.Text' in which the values are surrounded by square -- brackets and each value is separated by a comma. -- -- /Since: 0.5/ mkShowList :: Name -> Q Exp mkShowList name = [| toStrict . $(mkShowListLazy name) |] --- | Generates a lambda expression which converts the given list of @data@ types or --- @newtype@s to a lazy 'TL.Text' in which the values are surrounded by square +-- | Generates a lambda expression which converts the given list of data types or +-- families to a lazy 'TL.Text' in which the values are surrounded by square -- brackets and each value is separated by a comma. -- -- /Since: 0.5/ mkShowListLazy :: Name -> Q Exp mkShowListLazy name = [| toLazyText . $(mkShowbList name) |] --- | Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given data type or family -- to a 'Builder'. -- -- /Since: 0.3.1/ mkShowb :: Name -> Q Exp mkShowb name = mkShowbPrec name `appE` [| 0 :: Int |] --- | Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given data type or family -- to a 'Builder' with the given precedence. -- -- /Since: 0.3.1/ mkShowbPrec :: Name -> Q Exp -mkShowbPrec name = withType name $ const consToShow +mkShowbPrec name = do + info <- reify name + case info of + TyConI{} -> withTyCon name $ \_ decs -> consToShow decs +#if MIN_VERSION_template_haskell(2,7,0) + DataConI{} -> withDataFamInstCon name $ \_ _ dec -> + consToShow $ decCons [dec] + FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam name $ \_ decs -> + consToShow $ decCons decs + FamilyI (FamilyD TypeFam _ _ _) _ -> error $ ns ++ "Cannot use a type family name." + -- TODO: Figure out how this whole multiline string business works + _ -> error $ ns ++ "The name must be of a plain type constructor, data family, or data family instance constructor." +#else + _ -> error $ ns ++ "The name must be of a plain type constructor." +#endif + where + ns :: String + ns = "Text.Show.Text.TH.mk: " --- | Generates a lambda expression which converts the given list of @data@ types or --- @newtype@s to a 'Builder' in which the values are surrounded by square brackets +-- | Generates a lambda expression which converts the given list of data types or +-- families to a 'Builder' in which the values are surrounded by square brackets -- and each value is separated by a comma. -- -- /Since: 0.5/ mkShowbList :: Name -> Q Exp mkShowbList name = [| showbListDefault $(mkShowb name) |] --- | Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given data type or family -- argument's strict 'TS.Text' output to the standard output, followed by a newline. -- -- /Since: 0.3.1/ mkPrint :: Name -> Q Exp mkPrint name = [| TS.putStrLn . $(mkShow name) |] --- | Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given data type or family -- argument's lazy 'TL.Text' output to the standard output, followed by a newline. -- -- /Since: 0.3.1/ mkPrintLazy :: Name -> Q Exp mkPrintLazy name = [| TL.putStrLn . $(mkShowLazy name) |] --- | Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given data type or family -- argument's strict 'TS.Text' output to the given file handle, followed by a newline. -- -- /Since: 0.3.1/ mkHPrint :: Name -> Q Exp mkHPrint name = [| \h -> TS.hPutStrLn h . $(mkShow name) |] --- | Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given data type or family -- argument's lazy 'TL.Text' output to the given file handle, followed by a newline. -- -- /Since: 0.3.1/ @@ -429,7 +534,7 @@ , [| fromString ", " |] ] ) - (zip args ts) + (zip args ts) braceCommaArgs = [| s '{' |] : take (length showArgs - 1) showArgs mappendArgs = foldr (flip infixApp [| (<>) |]) [| s '}' |] @@ -444,15 +549,22 @@ ar <- newName "argR" info <- reify conName - let conPrec = case info of + let conPrec = case info of DataConI _ _ _ (Fixity prec _) -> prec other -> error $ "Text.Show.Text.TH.encodeArgs: Unsupported type: " ++ S.show other + opNameE = stringE $ nameBase conName + mBacktickE = [| if isInfixTypeCon $(opNameE) + then mempty + else s '`' + |] match (infixP (varP al) conName (varP ar)) (normalB $ appE [| showbParen ($(varE p) > conPrec) |] [| showbPrec (conPrec + 1) $(varE al) <> showbSpace - <> fromString $(stringE (nameBase conName)) + <> $(mBacktickE) + <> fromString $(opNameE) + <> $(mBacktickE) <> showbSpace <> showbPrec (conPrec + 1) $(varE ar) |] @@ -464,10 +576,9 @@ -- Utility functions ------------------------------------------------------------------------------- --- TODO: There's got to be a better way of doing this. --- | Checks if a 'Name' represents a tuple type constructor (other than '()')/ +-- | Checks if a 'Name' represents a tuple type constructor (other than '()') isNonUnitTuple :: Name -> Bool -isNonUnitTuple = isPrefixOf "(," . nameBase +isNonUnitTuple = isTupleString . nameBase -- | A type-restricted version of 'const'. This is useful when generating the lambda -- expression in 'mkShowbPrec' for a data type with only nullary constructors (since @@ -482,53 +593,91 @@ intConst = const {-# INLINE intConst #-} --- | Boilerplate for top level splices. --- --- The given 'Name' must be from a type constructor. Furthermore, the --- type constructor must be either a data type or a newtype. Any other --- value will result in an exception. -withType :: Name - -> ([TyVarBndr] -> [Con] -> Q a) - -- ^ Function that generates the actual code. Will be applied - -- to the type variable binders and constructors extracted - -- from the given 'Name'. - -> Q a - -- ^ Resulting value in the 'Q'uasi monad. -withType name f = do +-- | Extracts a plain type constructor's information. +withTyCon :: Name -- ^ Name of the plain type constructor + -> ([TyVarBndr] -> [Con] -> Q a) + -- ^ Function that generates the actual code. Will be applied + -- to the type variable binders and constructors extracted + -- from the given 'Name'. + -> Q a + -- ^ Resulting value in the 'Q'uasi monad. +withTyCon name f = do info <- reify name case info of - TyConI dec -> - case dec of - DataD _ _ tvbs cons _ -> f tvbs cons - NewtypeD _ _ tvbs con _ -> f tvbs [con] - other -> error $ "Text.Show.Text.TH.withType: Unsupported type " - ++ S.show other ++ ". Must be a data type or newtype." - ClassI{} -> error "Text.Show.Text.TH.withType: Cannot use a typeclass name." + TyConI dec -> + case dec of + DataD _ _ tvbs cons _ -> f tvbs cons + NewtypeD _ _ tvbs con _ -> f tvbs [con] + other -> error $ ns ++ "Unsupported type " ++ S.show other ++ ". Must be a data type or newtype." + _ -> error $ ns ++ "The name must be of a plain type constructor." + where + ns :: String + ns = "Text.Show.Text.TH.withTyCon: " + #if MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD DataFam _ _ _) _ -> - error "Text.Show.Text.TH.withType: Data families are not supported as of now." - FamilyI (FamilyD TypeFam _ _ _) _ -> - error "Text.Show.Text.TH.withType: Cannot use a type family name." +-- | Extracts a data family name's information. +withDataFam :: Name + -> ([TyVarBndr] -> [Dec] -> Q a) + -> Q a +withDataFam name f = do + info <- reify name + case info of + FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs + FamilyI (FamilyD TypeFam _ _ _) _ -> + error $ ns ++ "Cannot use a type family name." + other -> error $ ns ++ "Unsupported type " ++ S.show other ++ ". Must be a data family name." + where + ns :: String + ns = "Text.Show.Text.TH.withDataFam: " + +-- | Extracts a data family instance constructor's information. +withDataFamInstCon :: Name + -> (Name -> [TyVarBndr] -> Dec -> Q a) + -> Q a +withDataFamInstCon dficName f = do + dficInfo <- reify dficName + case dficInfo of + DataConI _ _ parentName _ -> do + parentInfo <- reify parentName + case parentInfo of + FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \tvbs decs -> + let sameDefDec = fromJust . flip find decs $ \dec -> + case dec of + DataInstD _ _ _ cons _ -> any ((dficName ==) . constructorName) cons + NewtypeInstD _ _ _ con _ -> dficName == constructorName con + _ -> error $ ns ++ "Must be a data or newtype instance." + in f parentName tvbs sameDefDec + _ -> error $ ns ++ "Data constructor " ++ S.show dficName ++ " is not from a data family instance." + other -> error $ ns ++ "Unsupported type " ++ S.show other ++ ". Must be a data family instance constructor." + where + ns :: String + ns = "Text.Show.Text.TH.withDataFamInstCon: " #endif - _ -> error "Text.Show.Text.TH.withType: I need the name of a plain type constructor." +-- | Extracts the information about the constructors from several @data@ or @newtype@ +-- declarations. +decCons :: [Dec] -> [Con] +decCons decs = flip concatMap decs $ \dec -> case dec of + DataInstD _ _ _ cons _ -> cons + NewtypeInstD _ _ _ con _ -> [con] + _ -> error $ "Text.Show.Text.TH.decCons: Must be a data or newtype instance." + +-- | Extracts the name of a constructor. +constructorName :: Con -> Name +constructorName (NormalC name _ ) = name +constructorName (RecC name _ ) = name +constructorName (InfixC _ name _ ) = name +constructorName (ForallC _ _ con) = constructorName con + -- | Extracts the name from a type variable binder. tvbName :: TyVarBndr -> Name -tvbName (PlainTV name) = name +tvbName (PlainTV name ) = name tvbName (KindedTV name _) = name -- | Applies a typeclass to several type parameters to produce the type predicate of --- an instance declaration. If a recent version of Template Haskell is used, this --- function will filter type parameters that have phantom roles (since they have no --- effect on the instance declaration. -applyCon :: Name -> [Name] -> Name -> Q [Pred] -#if MIN_VERSION_template_haskell(2,9,0) -applyCon con typeNames targetData - = map apply . nonPhantomNames typeNames <$> reifyRoles targetData -#else -applyCon con typeNames _ - = return $ map apply typeNames -#endif +-- an instance declaration. +applyCon :: Name -> [Name] -> Q [Pred] +applyCon con typeNames = return $ map apply typeNames where apply :: Name -> Pred apply t = @@ -538,12 +687,60 @@ ClassP con [VarT t] #endif -#if MIN_VERSION_template_haskell(2,9,0) - -- Filters a list of tycon names based on their type roles. - -- If a tycon has a phantom type role, remove it from the list. - nonPhantomNames :: [Name] -> [Role] -> [Name] - nonPhantomNames (_:ns) (PhantomR:rs) = nonPhantomNames ns rs - nonPhantomNames (n:ns) (_:rs) = n:(nonPhantomNames ns rs) - nonPhantomNames [] _ = [] - nonPhantomNames _ [] = [] +-- | Generates a declaration defining the 'showbPrec' function, followed by any custom +-- pragma declarations specified by the 'PragmaOptions' argument. +-- +-- The Template Haskell API for generating pragmas (as well as GHC's treatment of +-- pragmas themselves) have changed considerably over the years, so there's a lot of +-- CPP magic required to get this to work uniformly across different versions of GHC. +showbPrecDecs :: PragmaOptions -> [Con] -> [Q Dec] +#if __GLASGOW_HASKELL__ >= 702 +showbPrecDecs opts cons = +#else +showbPrecDecs _ cons = +#endif + [ funD 'showbPrec [ clause [] + (normalB $ consToShow cons) + [] + ] + ] ++ inlineShowbPrecDec + ++ inlineShowbDec + ++ inlineShowbListDec + ++ specializeDecs + where + inlineShowbPrecDec, inlineShowbDec, inlineShowbListDec :: [Q Dec] +#if __GLASGOW_HASKELL__ >= 702 + inlineShowbPrecDec = inline inlineShowbPrec 'showbPrec + inlineShowbDec = inline inlineShowb 'showb + inlineShowbListDec = inline inlineShowbList 'showbList +#else + inlineShowbPrecDec = [] + inlineShowbDec = [] + inlineShowbListDec = [] +#endif + +#if __GLASGOW_HASKELL__ >= 702 + inline :: (PragmaOptions -> Bool) -> Name -> [Q Dec] + inline isInlining funName + | isInlining opts = [ pragInlD funName +# if MIN_VERSION_template_haskell(2,8,0) + Inline FunLike AllPhases +# else + (inlineSpecNoPhase True False) +# endif + ] + | otherwise = [] +#endif + + specializeDecs :: [Q Dec] +#if MIN_VERSION_template_haskell(2,8,0) + specializeDecs = (map . fmap) (PragmaD + . SpecialiseInstP + . AppT (ConT ''T.Show) + ) + (specializeTypes opts) +#else + -- There doesn't appear to be an equivalent of SpecialiseInstP in early + -- versions Template Haskell. + specializeDecs = [] #endif diff --git a/src/Text/Show/Text/Text/Read.hs b/src/Text/Show/Text/Text/Read.hs --- a/src/Text/Show/Text/Text/Read.hs +++ b/src/Text/Show/Text/Text/Read.hs @@ -55,7 +55,6 @@ showbLexemePrec p (Rat r) = showbUnary "Rat" p r #endif showbLexemePrec _ EOF = "EOF" -{-# INLINE showbLexemePrec #-} #if MIN_VERSION_base(4,7,0) -- | Convert a 'Number' to a 'Builder' with the given precedence. diff --git a/src/Text/Show/Text/Utils.hs b/src/Text/Show/Text/Utils.hs --- a/src/Text/Show/Text/Utils.hs +++ b/src/Text/Show/Text/Utils.hs @@ -36,6 +36,19 @@ (<>) = mappend {-# INLINE (<>) #-} +-- | Checks if a 'String' names a valid Haskell infix type constructor (i.e., does +-- it begin with a colon?). +isInfixTypeCon :: String -> Bool +isInfixTypeCon (':':_) = True +isInfixTypeCon _ = False +{-# INLINE isInfixTypeCon #-} + +-- | Checks if a 'String' represents a tuple (other than '()') +isTupleString :: String -> Bool +isTupleString ('(':',':_) = True +isTupleString _ = False +{-# INLINE isTupleString #-} + -- | A shorter name for 'singleton' for convenience's sake (since it tends to be used -- pretty often in @text-show@). s :: Char -> Builder @@ -52,6 +65,7 @@ -- | @'replicateB' n b@ yields a 'Builder' containing @b@ repeated @n@ times. -- -- /Since: 0.3/ +{-# DEPRECATED replicateB "Use @timesN@ from the @semigroups@ library instead." #-} replicateB :: Int64 -> Builder -> Builder replicateB n = fromLazyText . replicate n . toLazyText {-# INLINE replicateB #-} @@ -77,7 +91,6 @@ unlinesB :: [Builder] -> Builder unlinesB (b:bs) = b <> s '\n' <> unlinesB bs unlinesB [] = mempty -{-# INLINE unlinesB #-} -- | Merges several 'Builder's, separating them by spaces. -- @@ -86,4 +99,3 @@ unwordsB (b:bs@(_:_)) = b <> s ' ' <> unwordsB bs unwordsB [b] = b unwordsB [] = mempty -{-# INLINE unwordsB #-} diff --git a/tests/Derived.hs b/tests/Derived.hs --- a/tests/Derived.hs +++ b/tests/Derived.hs @@ -1,11 +1,19 @@ -{-# LANGUAGE CPP, ExistentialQuantification, FlexibleContexts, - GADTs, GeneralizedNewtypeDeriving, StandaloneDeriving, - TypeOperators, UndecidableInstances #-} +{-# LANGUAGE CPP, DeriveGeneric, ExistentialQuantification, FlexibleContexts, + FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, + StandaloneDeriving, TypeOperators, UndecidableInstances #-} +#if MIN_VERSION_template_haskell(2,7,0) +{-# LANGUAGE TypeFamilies #-} +#endif #if __GLASGOW_HASKELL__ >= 706 -- GHC 7.4 also supports PolyKinds, but Template Haskell doesn't seem to play -- nicely with it for some reason. {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +-- Starting with GHC 7.10, NullaryTypeClasses was deprecated in favor of +-- MultiParamTypeClasses, which is already enabled +{-# LANGUAGE NullaryTypeClasses #-} +#endif {-| Module: Derived Copyright: (C) 2014-2015 Ryan Scott @@ -15,15 +23,13 @@ Portability: GHC Defines data types with derived 'Show' instances (using "Text.Show.Text.TH") -for testing purposes, including 'Arbitrary' instances. +for testing purposes. -} module Derived ( Nullary(..) , PhantomNullary(..) , MonomorphicUnary(..) , PolymorphicUnary(..) - , MonomorphicNewtype(..) - , PolymorphicNewtype(..) , MonomorphicProduct(..) , PolymorphicProduct(..) , MonomorphicRecord(..) @@ -41,8 +47,24 @@ , Restriction(..) , RestrictedContext(..) , Fix(..) + , AllShow(..) + , NotAllShow(..) + , OneDataInstance(..) + , AssocClass1(..) + , AssocData1(..) + , AssocClass2(..) + , AssocData2(..) + -- , AssocClass3(..) + -- , AssocData3(..) +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 + , NullaryClass(..) + , NullaryData(..) +#endif + , GADTFam(..) ) where +import GHC.Generics (Generic) + import Prelude hiding (Show) import Test.Tasty.QuickCheck (Arbitrary) @@ -50,40 +72,39 @@ import qualified Text.Show as S (Show) import qualified Text.Show.Text as T (Show) -data Nullary = Nullary deriving S.Show - -data PhantomNullary a = PhantomNullary deriving S.Show - -data MonomorphicUnary = MonomorphicUnary Int deriving S.Show +data Nullary = Nullary deriving (S.Show, Generic) -data PolymorphicUnary a b = PolymorphicUnary a deriving S.Show +data PhantomNullary a = PhantomNullary deriving (S.Show, Generic) -newtype MonomorphicNewtype = MonomorphicNewtype Int deriving (Arbitrary, S.Show) +newtype MonomorphicUnary = MonomorphicUnary Int deriving (S.Show, Generic) -newtype PolymorphicNewtype a b = PolymorphicNewtype a deriving (Arbitrary, S.Show) +newtype PolymorphicUnary a b = PolymorphicUnary a deriving (S.Show, Generic) -data MonomorphicProduct = MonomorphicProduct Char Double Int deriving S.Show +data MonomorphicProduct = MonomorphicProduct Char Double Int deriving (S.Show, Generic) -data PolymorphicProduct a b c d = PolymorphicProduct a b c deriving S.Show +data PolymorphicProduct a b c d = PolymorphicProduct a b c deriving (S.Show, Generic) data MonomorphicRecord = MonomorphicRecord { monomorphicRecord1 :: Char , monomorphicRecord2 :: Double , monomorphicRecord3 :: Int -} deriving S.Show +} deriving (S.Show, Generic) data PolymorphicRecord a b c d = PolymorphicRecord { polymorphicRecord1 :: a , polymorphicRecord2 :: b , polymorphicRecord3 :: c -} deriving S.Show +} deriving (S.Show, Generic) infix 7 :/: -data MonomorphicInfix = Int :/: Double deriving S.Show +data MonomorphicInfix = Int :/: Double deriving (S.Show, Generic) -infix 8 :\: -data PolymorphicInfix a b c = a :\: b deriving S.Show +infix 8 `PolyInf` +data PolymorphicInfix a b c = a `PolyInf` b deriving (S.Show, Generic) +-- TODO: Figure out how to create Generic instances for MonomorphicForall, PolymorphicForall, +-- AllAtOnce, and GADT + data MonomorphicForall = forall a. (Arbitrary a, S.Show a, T.Show a) => MonomorphicForall a deriving instance S.Show MonomorphicForall @@ -114,30 +135,140 @@ infixl 5 :<: data LeftAssocTree a = LeftAssocLeaf a | LeftAssocTree a :<: LeftAssocTree a - deriving S.Show + deriving (S.Show, Generic) infixl 5 :>: data RightAssocTree a = RightAssocLeaf a | RightAssocTree a :>: RightAssocTree a - deriving S.Show + deriving (S.Show, Generic) infix 4 :?: -data a :?: b = a :?: b deriving S.Show +data a :?: b = a :?: b deriving (S.Show, Generic) -data HigherKindedTypeParams f a = HigherKindedTypeParams (f a) deriving S.Show +newtype HigherKindedTypeParams f a = HigherKindedTypeParams (f a) deriving (S.Show, Generic) -data Restriction a = Restriction a +newtype Restriction a = Restriction a deriving Generic deriving instance (Read a, S.Show a) => S.Show (Restriction a) -data RestrictedContext a = RestrictedContext (Restriction a) deriving S.Show +newtype RestrictedContext a = RestrictedContext (Restriction a) deriving (S.Show, Generic) -newtype Fix f = Fix (f (Fix f)) +newtype Fix f = Fix (f (Fix f)) deriving Generic deriving instance S.Show (f (Fix f)) => S.Show (Fix f) --- TODO: Test data family instances, once they're supported --- --- data family DataFamily a b c :: * --- data instance DataFamily [a] [b] c = DataInstance1 a --- | DataInstance2 [b] --- deriving Show --- newtype instance DataFamily Int Int c = NewtypeInstance Int deriving Show +#if MIN_VERSION_template_haskell(2,7,0) +infix 2 `ASInfix` +data family AllShow a b c d :: * +data instance AllShow () () c d = ASNullary + deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) +newtype instance AllShow Int b c d = ASUnary Int + deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) +data instance AllShow Bool Bool c d = ASProduct Bool Bool + deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) +data instance AllShow Char Double c d = ASRecord { + asRecord1 :: Char + , asRecord2 :: Double + , asRecord3 :: c + } deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) +data instance AllShow Float Ordering c d = Float `ASInfix` Ordering + deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) + +data family NotAllShow a b c d :: * +data instance NotAllShow () () () d = NASNoShow +data instance NotAllShow Int b Int d = NASShow1 Int Int + | NASShow2 b + deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) + +infix 1 `ODIInfix` +data family OneDataInstance a b c d :: * +data instance OneDataInstance a b c d = ODINullary + | ODIUnary a + | ODIProduct a b + | ODIRecord { + odiRecord1 :: a + , odiRecord2 :: b + , odiRecord3 :: c + } + | a `ODIInfix` b + deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) + +class AssocClass1 a where + data AssocData1 a :: * +instance AssocClass1 () where + newtype AssocData1 () = AssocCon1 Int deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) + +class AssocClass2 a b c where + data AssocData2 a b c :: * +instance AssocClass2 () Int Int where + newtype AssocData2 () Int Int = AssocCon2 Int deriving ( S.Show +# if __GLASGOW_HASKELL__ >= 706 + {- Woraround for a bizarre bug in older GHCs -} + , Generic +# endif + ) + +-- class AssocClass3 a b c where +-- data AssocData3 a b c :: * +-- instance AssocClass3 () b c where +-- newtype AssocData3 () b c = AssocCon2 Int deriving ( S.Show +-- # if __GLASGOW_HASKELL__ >= 706 +-- {- Woraround for a bizarre bug in older GHCs -} +-- , Generic +-- # endif +-- ) + +# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +class NullaryClass where + data NullaryData +instance NullaryClass where + newtype NullaryData = NullaryCon Int deriving (S.Show, Generic) +# endif + +data family GADTFam a b c :: * +data instance GADTFam a b c where + GADTFamCon1 :: GADTFam Char b c + GADTFamCon2 :: Double -> GADTFam Double Double c + GADTFamCon3 :: Int -> GADTFam Int String c + GADTFamCon4 :: a -> GADTFam a b c + GADTFamCon5 :: b -> GADTFam b b c +deriving instance (S.Show a, S.Show b) => S.Show (GADTFam a b c) +#endif diff --git a/tests/Instances/BaseAndFriends.hs b/tests/Instances/BaseAndFriends.hs --- a/tests/Instances/BaseAndFriends.hs +++ b/tests/Instances/BaseAndFriends.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, StandaloneDeriving #-} -#if MIN_VERSION_base(4,4,0) -{-# LANGUAGE FlexibleContexts, TypeOperators #-} -#endif +{-# LANGUAGE CPP, FlexibleContexts, GeneralizedNewtypeDeriving, + StandaloneDeriving, TypeOperators #-} #if MIN_VERSION_base(4,7,0) {-# LANGUAGE TypeFamilies #-} # if !(MIN_VERSION_base(4,8,0)) @@ -40,6 +38,11 @@ mkConstr, mkDataType) import Data.Dynamic (Dynamic, toDyn) import Data.Functor ((<$>)) +#if defined(VERSION_transformers) +# if !(MIN_VERSION_transformers(0,4,0)) +import Data.Functor.Classes () +# endif +#endif import Data.Functor.Identity (Identity(..)) import Data.Monoid (All(..), Any(..), Dual(..), First(..), Last(..), Product(..), Sum(..)) @@ -47,7 +50,7 @@ import Data.Monoid (Alt(..)) #endif #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) -import qualified Data.OldTypeable.Internal as OldT (TyCon(..)) +import qualified Data.OldTypeable.Internal as OldT (TyCon(..), TypeRep(..)) #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) @@ -59,15 +62,12 @@ import Data.Type.Coercion (Coercion(..)) import Data.Type.Equality ((:~:)(..)) #endif -#if MIN_VERSION_base(4,4,0) -import qualified Data.Typeable.Internal as NewT (TyCon(..)) -import GHC.Fingerprint.Type (Fingerprint(..)) +import qualified Data.Typeable.Internal as NewT (TyCon(..), TypeRep(..)) #if !(MIN_VERSION_base(4,7,0)) import Data.Word (Word64) import Numeric (showHex) #endif -#endif import Data.Version (Version(..)) import Foreign.C.Types @@ -79,35 +79,39 @@ #if defined(mingw32_HOST_OS) import GHC.Conc.Windows (ConsoleEvent(..)) #endif -#if MIN_VERSION_base(4,4,0) +import GHC.Fingerprint.Type (Fingerprint(..)) import GHC.IO.Encoding.Failure (CodingFailureMode(..)) import GHC.IO.Encoding.Types (CodingProgress(..)) +import GHC.IO.Exception (IOException(..), IOErrorType(..)) import qualified GHC.Generics as G (Fixity(..)) import GHC.Generics (U1(..), Par1(..), Rec1(..), K1(..), M1(..), (:+:)(..), (:*:)(..), (:.:)(..), Associativity(..), Arity(..)) -#endif #if MIN_VERSION_base(4,8,0) import GHC.RTS.Flags import GHC.StaticPtr (StaticPtrInfo(..)) #endif -#if MIN_VERSION_base(4,5,0) import GHC.Stats (GCStats(..)) -#endif #if MIN_VERSION_base(4,7,0) import GHC.TypeLits (SomeNat, SomeSymbol, someNatVal, someSymbolVal) #endif +import Instances.Utils ((<@>)) + import Numeric.Natural (Natural) import System.Exit (ExitCode(..)) -import System.IO (BufferMode(..), IOMode(..), Newline(..), - NewlineMode(..), SeekMode(..)) +import System.IO (BufferMode(..), IOMode(..), Newline(..), NewlineMode(..), + SeekMode(..), Handle, stdin, stdout, stderr) import System.Posix.Types import Test.Tasty.QuickCheck (Arbitrary(arbitrary), Gen, arbitraryBoundedEnum, oneof, suchThat) +import Text.Show.Text (FromStringShow(..), FromTextShow(..)) +import Text.Show.Text.Data.Char (LitChar(..), LitString(..)) +import Text.Show.Text.Generic (ConType(..)) + #include "HsBaseConfig.h" instance Arbitrary Natural where @@ -141,22 +145,22 @@ instance Arbitrary Version where arbitrary = Version <$> arbitrary <*> arbitrary --- TODO: Be more creative with this instance instance Arbitrary SomeException where arbitrary = SomeException <$> (arbitrary :: Gen AssertionFailed) --- instance Arbitrary IOException +instance Arbitrary IOException where + arbitrary = IOError <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary +deriving instance Bounded IOErrorType +deriving instance Enum IOErrorType +instance Arbitrary IOErrorType where + arbitrary = arbitraryBoundedEnum + +deriving instance Bounded ArithException +deriving instance Enum ArithException instance Arbitrary ArithException where - arbitrary = oneof $ map pure [ Overflow - , Underflow - , LossOfPrecision - , DivideByZero - , Denormal -#if MIN_VERSION_base(4,6,0) - , RatioZeroDenominator -#endif - ] + arbitrary = arbitraryBoundedEnum instance Arbitrary ArrayException where arbitrary = oneof [ IndexOutOfBounds <$> arbitrary @@ -167,17 +171,14 @@ arbitrary = AssertionFailed <$> arbitrary #if MIN_VERSION_base(4,7,0) --- TODO: Be more creative with this instance instance Arbitrary SomeAsyncException where arbitrary = SomeAsyncException <$> (arbitrary :: Gen AsyncException) #endif +deriving instance Bounded AsyncException +deriving instance Enum AsyncException instance Arbitrary AsyncException where - arbitrary = oneof $ map pure [ StackOverflow - , HeapOverflow - , ThreadKilled - , UserInterrupt - ] + arbitrary = arbitraryBoundedEnum instance Arbitrary NonTermination where arbitrary = pure NonTermination @@ -216,36 +217,34 @@ -- ErrorCall is a newtype starting with base-4.7.0.0, but we'll -- manually derive Arbitrary to support older versions of GHC. --- --- deriving instance Arbitrary ErrorCall instance Arbitrary ErrorCall where arbitrary = ErrorCall <$> arbitrary +deriving instance Bounded MaskingState +deriving instance Enum MaskingState instance Arbitrary MaskingState where - arbitrary = oneof $ map pure [ Unmasked - , MaskedInterruptible - , MaskedUninterruptible - ] + arbitrary = arbitraryBoundedEnum --- instance Arbitrary Lexeme +-- TODO: instance Arbitrary Lexeme -- #if MIN_VERSION_base(4,7,0) --- instance Arbitrary Number +-- TODO: instance Arbitrary Number -- #endif instance Arbitrary (Proxy s) where arbitrary = pure Proxy #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) --- TODO: Come up with an instance of TypeRep that doesn't take forever --- instance Arbitrary OldT.TypeRep where +instance Arbitrary OldT.TypeRep where + arbitrary = OldT.TypeRep <$> arbitrary <*> arbitrary <@> [] +-- arbitrary = OldT.TypeRep <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary OldT.TyCon where arbitrary = OldT.TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary #endif -#if MIN_VERSION_base(4,4,0) --- TODO: Come up with an instance of TypeRep that doesn't take forever --- instance Arbitrary NewT.TypeRep where +instance Arbitrary NewT.TypeRep where + arbitrary = NewT.TypeRep <$> arbitrary <*> arbitrary <@> [] +-- arbitrary = NewT.TypeRep <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary NewT.TyCon where arbitrary = NewT.TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -262,9 +261,7 @@ hex16 i = let hex = showHex i "" in replicate (16 - length hex) '0' ++ hex #endif -#endif --- TODO: Be more creative with this instance instance Arbitrary Dynamic where arbitrary = toDyn <$> (arbitrary :: Gen Int) @@ -289,8 +286,10 @@ instance Arbitrary DataType where arbitrary = mkDataType <$> arbitrary <*> arbitrary +deriving instance Bounded D.Fixity +deriving instance Enum D.Fixity instance Arbitrary D.Fixity where - arbitrary = oneof $ map pure [D.Prefix, D.Infix] + arbitrary = arbitraryBoundedEnum #if MIN_VERSION_base(4,7,0) instance Coercible a b => Arbitrary (Coercion a b) where @@ -300,16 +299,12 @@ arbitrary = pure Refl #endif +deriving instance Bounded BlockReason +deriving instance Enum BlockReason instance Arbitrary BlockReason where - arbitrary = oneof $ map pure [ BlockedOnMVar - , BlockedOnBlackHole - , BlockedOnException - , BlockedOnSTM - , BlockedOnForeignCall - , BlockedOnOther - ] + arbitrary = arbitraryBoundedEnum --- instance Arbitrary ThreadId +-- TODO: instance Arbitrary ThreadId instance Arbitrary ThreadStatus where arbitrary = oneof [ pure ThreadRunning @@ -319,23 +314,21 @@ ] #if defined(mingw32_HOST_OS) +deriving instance Bounded ConsoleEvent instance Arbitrary ConsoleEvent where - arbitrary = oneof $ map pure [ ControlC - , Break - , Close - , Logoff - , Shutdown - ] + arbitrary = arbitraryBoundedEnum #endif instance Arbitrary (ST s a) where arbitrary = pure $ fixST undefined --- instance Arbitrary Handle --- instance Arbitrary HandlePosn +instance Arbitrary Handle where + arbitrary = oneof $ map pure [stdin, stdout, stderr] +-- TODO: instance Arbitrary HandlePosn +deriving instance Bounded IOMode instance Arbitrary IOMode where - arbitrary = oneof $ map pure [ReadMode, WriteMode, AppendMode, ReadWriteMode] + arbitrary = arbitraryBoundedEnum instance Arbitrary BufferMode where arbitrary = oneof [ pure NoBuffering @@ -343,35 +336,30 @@ , BlockBuffering <$> arbitrary ] +deriving instance Bounded SeekMode instance Arbitrary SeekMode where - arbitrary = oneof $ map pure [AbsoluteSeek, RelativeSeek, SeekFromEnd] + arbitrary = arbitraryBoundedEnum +deriving instance Bounded Newline +deriving instance Enum Newline instance Arbitrary Newline where - arbitrary = oneof $ map pure [LF, CRLF] + arbitrary = arbitraryBoundedEnum instance Arbitrary NewlineMode where arbitrary = NewlineMode <$> arbitrary <*> arbitrary -#if MIN_VERSION_base(4,3,0) --- instance Arbitrary TextEncoding -#else -deriving instance Show Newline -deriving instance Show NewlineMode -#endif +-- TODO: instance Arbitrary TextEncoding -#if MIN_VERSION_base(4,4,0) +deriving instance Bounded CodingProgress +deriving instance Enum CodingProgress instance Arbitrary CodingProgress where - arbitrary = oneof $ map pure [InputUnderflow, OutputUnderflow, InvalidSequence] + arbitrary = arbitraryBoundedEnum +deriving instance Bounded CodingFailureMode +deriving instance Enum CodingFailureMode instance Arbitrary CodingFailureMode where - arbitrary = oneof $ map pure [ ErrorOnCodingFailure - , IgnoreCodingFailure - , TransliterateCodingFailure - , RoundtripFailure - ] -#endif + arbitrary = arbitraryBoundedEnum -#if MIN_VERSION_base(4,5,0) instance Arbitrary GCStats where arbitrary = GCStats <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -379,14 +367,10 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -#endif --- #if MIN_VERSION_base(4,4,0) --- instance Arbitrary Event --- instance Arbitrary FdKey --- #endif +-- TODO: instance Arbitrary Event +-- TODO: instance Arbitrary FdKey -#if MIN_VERSION_base(4,4,0) instance Arbitrary (U1 p) where arbitrary = pure U1 @@ -414,8 +398,10 @@ instance Arbitrary G.Fixity where arbitrary = oneof [pure G.Prefix, G.Infix <$> arbitrary <*> arbitrary] +deriving instance Bounded Associativity +deriving instance Enum Associativity instance Arbitrary Associativity where - arbitrary = oneof $ map pure [LeftAssociative, RightAssociative, NotAssociative] + arbitrary = arbitraryBoundedEnum instance Arbitrary Arity where arbitrary = oneof [pure NoArity, Arity <$> arbitrary] @@ -431,8 +417,6 @@ -- Due to a GHC bug (https://ghc.haskell.org/trac/ghc/ticket/9830), this Show -- instance produces output with the wrong precedence on older versions of GHC. -- I'll manually define the Show instance to get the correct behavior. --- --- deriving instance (Show (f p), Show (g p)) => Show ((f :*: g) p) instance (Show (f p), Show (g p)) => Show ((f :*: g) p) where showsPrec p (l :*: r) = showParen (p > prec) $ showsPrec (prec + 1) l @@ -442,11 +426,10 @@ deriving instance Show (f (g p)) => Show ((f :.: g) p) #endif -#endif #if MIN_VERSION_base(4,8,0) --- instance Arbitrary RTSFlags --- instance Arbitrary GCFlags +-- TODO: instance Arbitrary RTSFlags +-- TODO: instance Arbitrary GCFlags instance Arbitrary ConcFlags where arbitrary = ConcFlags <$> arbitrary <*> arbitrary @@ -461,9 +444,9 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --- instance Arbitrary CCFlags where --- instance Arbitrary ProfFlags where --- instance Arbitrary TraceFlags where +-- TODO: instance Arbitrary CCFlags where +-- TODO: instance Arbitrary ProfFlags where +-- TODO: instance Arbitrary TraceFlags where instance Arbitrary TickyFlags where arbitrary = TickyFlags <$> arbitrary <*> arbitrary @@ -473,8 +456,8 @@ #endif -- #if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,7,0)) --- instance Arbitrary (IsZero n) --- instance Arbitrary (IsEven n) +-- TODO: instance Arbitrary (IsZero n) +-- TODO: instance Arbitrary (IsEven n) -- #endif #if MIN_VERSION_base(4,7,0) @@ -489,6 +472,9 @@ arbitrary = someSymbolVal <$> arbitrary #endif +instance Arbitrary ConType where + arbitrary = oneof [pure Rec, pure Tup, pure Pref, Inf <$> arbitrary] + deriving instance Arbitrary CChar deriving instance Arbitrary CSChar deriving instance Arbitrary CUChar @@ -583,3 +569,9 @@ #endif deriving instance Arbitrary a => Arbitrary (Identity a) + +deriving instance Arbitrary a => Arbitrary (FromStringShow a) +deriving instance Arbitrary a => Arbitrary (FromTextShow a) + +deriving instance Arbitrary LitChar +deriving instance Arbitrary LitString diff --git a/tests/Instances/Derived.hs b/tests/Instances/Derived.hs --- a/tests/Instances/Derived.hs +++ b/tests/Instances/Derived.hs @@ -1,6 +1,13 @@ -{-# LANGUAGE CPP, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, - StandaloneDeriving, TemplateHaskell, - TypeOperators, UndecidableInstances #-} +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, GADTs, + GeneralizedNewtypeDeriving, StandaloneDeriving, + TemplateHaskell, TypeOperators, UndecidableInstances #-} +#include "overlap.h" +__LANGUAGE_OVERLAPPING_INSTANCES__ +#if __GLASGOW_HASKELL__ >= 706 +-- GHC 7.4 also supports PolyKinds, but Template Haskell doesn't seem to play +-- -- nicely with it for some reason. +{-# LANGUAGE PolyKinds #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module: Instances.Derived @@ -25,7 +32,7 @@ import Prelude hiding (Show) -import Test.Tasty.QuickCheck (Arbitrary(arbitrary), Gen, oneof) +import Test.Tasty.QuickCheck (Arbitrary(..), Gen, oneof) import Text.Show.Text (Show(showbPrec)) import Text.Show.Text.TH (deriveShow, mkShowbPrec) @@ -39,16 +46,10 @@ arbitrary = pure PhantomNullary $(deriveShow ''MonomorphicUnary) -instance Arbitrary MonomorphicUnary where - arbitrary = MonomorphicUnary <$> arbitrary +deriving instance Arbitrary MonomorphicUnary $(deriveShow ''PolymorphicUnary) -instance Arbitrary a => Arbitrary (PolymorphicUnary a b) where - arbitrary = PolymorphicUnary <$> arbitrary - -$(deriveShow ''MonomorphicNewtype) - -$(deriveShow ''PolymorphicNewtype) +deriving instance Arbitrary a => Arbitrary (PolymorphicUnary a b) $(deriveShow ''MonomorphicProduct) instance Arbitrary MonomorphicProduct where @@ -72,7 +73,7 @@ $(deriveShow ''PolymorphicInfix) instance (Arbitrary a, Arbitrary b) => Arbitrary (PolymorphicInfix a b c) where - arbitrary = (:\:) <$> arbitrary <*> arbitrary + arbitrary = PolyInf <$> arbitrary <*> arbitrary $(deriveShow ''MonomorphicForall) instance Arbitrary MonomorphicForall where @@ -93,17 +94,29 @@ ] $(deriveShow ''GADT) +instance __OVERLAPPING__ Arbitrary (GADT Char b c) where + arbitrary = pure GADTCon1 +instance __OVERLAPPING__ Arbitrary (GADT Double Double c) where + arbitrary = GADTCon2 <$> arbitrary +instance __OVERLAPPING__ Arbitrary (GADT Int String c) where + arbitrary = GADTCon3 <$> arbitrary +instance __OVERLAPPABLE__ Arbitrary a => Arbitrary (GADT a b c) where + arbitrary = GADTCon4 <$> arbitrary +instance __OVERLAPPING__ Arbitrary b => Arbitrary (GADT b b c) where + arbitrary = GADTCon5 <$> arbitrary $(deriveShow ''LeftAssocTree) instance Arbitrary a => Arbitrary (LeftAssocTree a) where arbitrary = oneof [ LeftAssocLeaf <$> arbitrary - , (:<:) <$> arbitrary <*> arbitrary + , (:<:) <$> (LeftAssocLeaf <$> arbitrary) + <*> (LeftAssocLeaf <$> arbitrary) ] $(deriveShow ''RightAssocTree) instance Arbitrary a => Arbitrary (RightAssocTree a) where arbitrary = oneof [ RightAssocLeaf <$> arbitrary - , (:>:) <$> arbitrary <*> arbitrary + , (:>:) <$> (RightAssocLeaf <$> arbitrary) + <*> (RightAssocLeaf <$> arbitrary) ] $(deriveShow ''(:?:)) @@ -112,21 +125,65 @@ instance Show (f a) => Show (HigherKindedTypeParams f a) where showbPrec = $(mkShowbPrec ''HigherKindedTypeParams) -instance Arbitrary (f a) => Arbitrary (HigherKindedTypeParams f a) where - arbitrary = HigherKindedTypeParams <$> arbitrary +deriving instance Arbitrary (f a) => Arbitrary (HigherKindedTypeParams f a) instance (Read a, Show a) => Show (Restriction a) where showbPrec = $(mkShowbPrec ''Restriction) -instance Arbitrary a => Arbitrary (Restriction a) where - arbitrary = Restriction <$> arbitrary +deriving instance Arbitrary a => Arbitrary (Restriction a) instance (Read a, Show a) => Show (RestrictedContext a) where showbPrec = $(mkShowbPrec ''RestrictedContext) -instance Arbitrary a => Arbitrary (RestrictedContext a) where - arbitrary = RestrictedContext <$> arbitrary +deriving instance Arbitrary a => Arbitrary (RestrictedContext a) instance Show (f (Fix f)) => Show (Fix f) where showbPrec = $(mkShowbPrec ''Fix) deriving instance Arbitrary (f (Fix f)) => Arbitrary (Fix f) --- TODO: Test data family instances, once they're supported +#if MIN_VERSION_template_haskell(2,7,0) +$(deriveShow ''AllShow) +instance Arbitrary (AllShow () () c d) where + arbitrary = pure ASNullary +deriving instance Arbitrary (AllShow Int b c d) +instance Arbitrary (AllShow Bool Bool c d) where + arbitrary = ASProduct <$> arbitrary <*> arbitrary +instance Arbitrary c => Arbitrary (AllShow Char Double c d) where + arbitrary = ASRecord <$> arbitrary <*> arbitrary <*> arbitrary +instance Arbitrary (AllShow Float Ordering c d) where + arbitrary = ASInfix <$> arbitrary <*> arbitrary + +$(deriveShow 'NASShow1) +instance Arbitrary b => Arbitrary (NotAllShow Int b Int d) where + arbitrary = oneof [NASShow1 <$> arbitrary <*> arbitrary, NASShow2 <$> arbitrary] + +$(deriveShow ''OneDataInstance) +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (OneDataInstance a b c d) where + arbitrary = oneof [ pure ODINullary + , ODIUnary <$> arbitrary + , ODIProduct <$> arbitrary <*> arbitrary + , ODIRecord <$> arbitrary <*> arbitrary <*> arbitrary + , ODIInfix <$> arbitrary <*> arbitrary + ] + +$(deriveShow ''AssocData1) +deriving instance Arbitrary (AssocData1 ()) + +$(deriveShow 'AssocCon2) +deriving instance Arbitrary (AssocData2 () Int Int) + +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +$(deriveShow 'NullaryCon) +deriving instance Arbitrary NullaryData +#endif + +$(deriveShow 'GADTFamCon1) +instance __OVERLAPPING__ Arbitrary (GADTFam Char b c) where + arbitrary = pure GADTFamCon1 +instance __OVERLAPPING__ Arbitrary (GADTFam Double Double c) where + arbitrary = GADTFamCon2 <$> arbitrary +instance __OVERLAPPING__ Arbitrary (GADTFam Int String c) where + arbitrary = GADTFamCon3 <$> arbitrary +instance __OVERLAPPABLE__ Arbitrary a => Arbitrary (GADTFam a b c) where + arbitrary = GADTFamCon4 <$> arbitrary +instance __OVERLAPPING__ Arbitrary b => Arbitrary (GADTFam b b c) where + arbitrary = GADTFamCon5 <$> arbitrary +#endif diff --git a/tests/Instances/Utils.hs b/tests/Instances/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Utils.hs @@ -0,0 +1,16 @@ +{-| +Module: Properties.Instances +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +A collection of utility functions. +-} +module Instances.Utils ((<@>)) where + +infixl 4 <@> +-- | A useful way to escape a 'Functor' context. +(<@>) :: Functor f => f (a -> b) -> a -> f b +f <@> x = fmap ($ x) f diff --git a/tests/Properties/BaseAndFriends.hs b/tests/Properties/BaseAndFriends.hs --- a/tests/Properties/BaseAndFriends.hs +++ b/tests/Properties/BaseAndFriends.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,4,0) -{-# LANGUAGE FlexibleContexts, TypeOperators #-} -#endif +{-# LANGUAGE CPP, FlexibleContexts, TypeOperators #-} #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} #endif @@ -22,7 +19,7 @@ import Control.Exception import Control.Monad.ST -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && MIN_VERSION_text(1,0,0) import Data.Array (Array) #endif import Data.Array (elems) @@ -45,7 +42,7 @@ import Data.Monoid (Alt(..)) #endif #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) -import qualified Data.OldTypeable as OldT (TyCon) +import qualified Data.OldTypeable as OldT (TyCon, TypeRep) #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) @@ -58,10 +55,7 @@ import Data.Type.Coercion (Coercion) import Data.Type.Equality ((:~:)) #endif -#if MIN_VERSION_base(4,4,0) -import qualified Data.Typeable as NewT (TyCon) -import GHC.Fingerprint.Type (Fingerprint) -#endif +import qualified Data.Typeable as NewT (TyCon, TypeRep) import Data.Word (Word8, Word16, Word32, Word64) #if !(MIN_VERSION_base(4,8,0)) import Data.Word (Word) @@ -75,20 +69,17 @@ #if defined(mingw32_HOST_OS) import GHC.Conc.Windows (ConsoleEvent) #endif +import GHC.Fingerprint.Type (Fingerprint) import qualified GHC.Generics as G (Fixity) import GHC.Generics (U1, Par1, Rec1, K1, M1, (:+:), (:*:), (:.:), Associativity, Arity) -#if MIN_VERSION_base(4,4,0) import GHC.IO.Encoding.Failure (CodingFailureMode) import GHC.IO.Encoding.Types (CodingProgress) -#endif #if MIN_VERSION_base(4,8,0) import GHC.RTS.Flags import GHC.StaticPtr (StaticPtrInfo) #endif -#if MIN_VERSION_base(4,5,0) import GHC.Stats (GCStats) -#endif import GHC.Show (asciiTab, showList__) #if MIN_VERSION_base(4,7,0) import GHC.TypeLits (SomeNat, SomeSymbol) @@ -104,10 +95,10 @@ import Prelude hiding (Show) -import Properties.Utils (prop_matchesShow) +import Properties.Utils (prop_matchesShow, prop_genericShow) import System.Exit (ExitCode) -import System.IO (BufferMode, IOMode, Newline, NewlineMode, SeekMode) +import System.IO (BufferMode, IOMode, Newline, NewlineMode, SeekMode, Handle) import System.Posix.Types import Test.QuickCheck.Instances () @@ -117,8 +108,7 @@ import Text.Show.Functions () import Text.Show.Text hiding (Show) -import Text.Show.Text.Functions () -import Text.Show.Text.Data.Char (asciiTabB) +import Text.Show.Text.Data.Char (LitChar, LitString, asciiTabB) import Text.Show.Text.Data.Fixed (showbFixed) import Text.Show.Text.Data.Floating (showbEFloat, showbFFloat, showbGFloat) #if MIN_VERSION_base(4,7,0) @@ -127,6 +117,8 @@ import Text.Show.Text.Data.Integral (showbIntAtBase) import Text.Show.Text.Data.List (showbListDefault) import Text.Show.Text.Data.Version (showbVersionConcrete) +import Text.Show.Text.Functions () +import Text.Show.Text.Generic (ConType) #include "HsBaseConfig.h" @@ -135,7 +127,7 @@ prop_showFixed b f = fromString (showFixed b f) == showbFixed b f -- | Verifies 'showIntAtBase' and 'showbIntAtBase' generate the same output. -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && MIN_VERSION_text(1,0,0) prop_showIntAtBase :: Gen Bool prop_showIntAtBase = do base <- arbitrary `suchThat` (liftA2 (&&) (> 1) (<= 16)) @@ -160,360 +152,365 @@ baseAndFriendsTests :: [TestTree] baseAndFriendsTests = - [ testGroup "Text.Show.Text.Control.Applicative" - [ testProperty "ZipList Int instance" (prop_matchesShow :: Int -> ZipList Int -> Bool) + [ testGroup "Text.Show.Text" + [ testProperty "FromStringShow Int instance" (prop_matchesShow :: Int -> FromStringShow Int -> Bool) + , testProperty "FromTextShow Int instance" (prop_matchesShow :: Int -> FromTextShow Int -> Bool) ] + , testGroup "Text.Show.Text.Control.Applicative" + [ testProperty "ZipList Int instance" (prop_matchesShow :: Int -> ZipList Int -> Bool) + ] , testGroup "Text.Show.Text.Control.Concurrent" - [ testProperty "BlockReason instance" (prop_matchesShow :: Int -> BlockReason -> Bool) --- , testProperty "ThreadId instance" (prop_matchesShow :: Int -> ThreadId -> Bool) - , testProperty "ThreadStatus instance" (prop_matchesShow :: Int -> ThreadStatus -> Bool) + [ testProperty "BlockReason instance" (prop_matchesShow :: Int -> BlockReason -> Bool) +-- , testProperty "ThreadId instance" (prop_matchesShow :: Int -> ThreadId -> Bool) + , testProperty "ThreadStatus instance" (prop_matchesShow :: Int -> ThreadStatus -> Bool) ] , testGroup "Text.Show.Text.Control.Exception" - [ testProperty "SomeException instance" (prop_matchesShow :: Int -> SomeException -> Bool) --- , testProperty "IOException instance" (prop_matchesShow :: Int -> IOException -> Bool) - , testProperty "ArithException instance" (prop_matchesShow :: Int -> ArithException -> Bool) - , testProperty "ArrayException instance" (prop_matchesShow :: Int -> ArrayException -> Bool) - , testProperty "AssertionFailed instance" (prop_matchesShow :: Int -> AssertionFailed -> Bool) + [ testProperty "SomeException instance" (prop_matchesShow :: Int -> SomeException -> Bool) + , testProperty "IOException instance" (prop_matchesShow :: Int -> IOException -> Bool) + , testProperty "ArithException instance" (prop_matchesShow :: Int -> ArithException -> Bool) + , testProperty "ArrayException instance" (prop_matchesShow :: Int -> ArrayException -> Bool) + , testProperty "AssertionFailed instance" (prop_matchesShow :: Int -> AssertionFailed -> Bool) #if MIN_VERSION_base(4,7,0) - , testProperty "SomeAsyncException instance" (prop_matchesShow :: Int -> SomeAsyncException -> Bool) + , testProperty "SomeAsyncException instance" (prop_matchesShow :: Int -> SomeAsyncException -> Bool) #endif - , testProperty "AsyncException instance" (prop_matchesShow :: Int -> AsyncException -> Bool) - , testProperty "NonTermination instance" (prop_matchesShow :: Int -> NonTermination -> Bool) - , testProperty "NestedAtomically instance" (prop_matchesShow :: Int -> NestedAtomically -> Bool) - , testProperty "BlockedIndefinitelyOnMVar instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnMVar -> Bool) - , testProperty "BlockedIndefinitelyOnSTM instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnSTM -> Bool) + , testProperty "AsyncException instance" (prop_matchesShow :: Int -> AsyncException -> Bool) + , testProperty "NonTermination instance" (prop_matchesShow :: Int -> NonTermination -> Bool) + , testProperty "NestedAtomically instance" (prop_matchesShow :: Int -> NestedAtomically -> Bool) + , testProperty "BlockedIndefinitelyOnMVar instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnMVar -> Bool) + , testProperty "BlockedIndefinitelyOnSTM instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnSTM -> Bool) #if MIN_VERSION_base(4,8,0) - , testProperty "AllocationLimitExceeded instance" (prop_matchesShow :: Int -> AllocationLimitExceeded -> Bool) + , testProperty "AllocationLimitExceeded instance" (prop_matchesShow :: Int -> AllocationLimitExceeded -> Bool) #endif - , testProperty "Deadlock instance" (prop_matchesShow :: Int -> Deadlock -> Bool) - , testProperty "NoMethodError instance" (prop_matchesShow :: Int -> NoMethodError -> Bool) - , testProperty "PatternMatchFail instance" (prop_matchesShow :: Int -> PatternMatchFail -> Bool) - , testProperty "RecConError instance" (prop_matchesShow :: Int -> RecConError -> Bool) - , testProperty "RecSelError instance" (prop_matchesShow :: Int -> RecSelError -> Bool) - , testProperty "RecUpdError instance" (prop_matchesShow :: Int -> RecUpdError -> Bool) - , testProperty "ErrorCall instance" (prop_matchesShow :: Int -> ErrorCall -> Bool) - , testProperty "MaskingState instance" (prop_matchesShow :: Int -> MaskingState -> Bool) + , testProperty "Deadlock instance" (prop_matchesShow :: Int -> Deadlock -> Bool) + , testProperty "NoMethodError instance" (prop_matchesShow :: Int -> NoMethodError -> Bool) + , testProperty "PatternMatchFail instance" (prop_matchesShow :: Int -> PatternMatchFail -> Bool) + , testProperty "RecConError instance" (prop_matchesShow :: Int -> RecConError -> Bool) + , testProperty "RecSelError instance" (prop_matchesShow :: Int -> RecSelError -> Bool) + , testProperty "RecUpdError instance" (prop_matchesShow :: Int -> RecUpdError -> Bool) + , testProperty "ErrorCall instance" (prop_matchesShow :: Int -> ErrorCall -> Bool) + , testProperty "MaskingState instance" (prop_matchesShow :: Int -> MaskingState -> Bool) ] , testGroup "Text.Show.Text.Control.Monad.ST" - [ testProperty "ST instance" (prop_matchesShow :: Int -> ST Int Int -> Bool) + [ testProperty "ST instance" (prop_matchesShow :: Int -> ST Int Int -> Bool) ] -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && MIN_VERSION_text(1,0,0) -- TODO: Figure out why this test diverges on Windows , testGroup "Text.Show.Text.Data.Array" - [ testProperty "Array Int Int instance" (prop_matchesShow :: Int -> Array Int Int -> Bool) + [ testProperty "Array Int Int instance" (prop_matchesShow :: Int -> Array Int Int -> Bool) ] #endif , testGroup "Text.Show.Text.Data.Bool" - [ testProperty "Bool instance" (prop_matchesShow :: Int -> Bool -> Bool) + [ testProperty "Bool instance" (prop_matchesShow :: Int -> Bool -> Bool) ] , testGroup "Text.Show.Text.Data.ByteString" - [ testProperty "strict ByteString instance" (prop_matchesShow :: Int -> BS.ByteString -> Bool) - , testProperty "lazy ByteString instance" (prop_matchesShow :: Int -> BL.ByteString -> Bool) + [ testProperty "strict ByteString instance" (prop_matchesShow :: Int -> BS.ByteString -> Bool) + , testProperty "lazy ByteString instance" (prop_matchesShow :: Int -> BL.ByteString -> Bool) #if MIN_VERSION_bytestring(0,10,4) - , testProperty "ShortByteString instance" (prop_matchesShow :: Int -> ShortByteString -> Bool) + , testProperty "ShortByteString instance" (prop_matchesShow :: Int -> ShortByteString -> Bool) #endif ] , testGroup "Text.Show.Text.Data.Char" - [ testProperty "Char instance" (prop_matchesShow :: Int -> Char -> Bool) - , testProperty "GeneralCategory instance" (prop_matchesShow :: Int -> GeneralCategory -> Bool) - , testCase "asciiTab = asciiTabB" $ map fromString asciiTab @=? elems (asciiTabB) + [ testProperty "Char instance" (prop_matchesShow :: Int -> Char -> Bool) + , testProperty "GeneralCategory instance" (prop_matchesShow :: Int -> GeneralCategory -> Bool) + , testProperty "LitChar instance" (prop_matchesShow :: Int -> LitChar -> Bool) + , testCase "asciiTab = asciiTabB" $ map fromString asciiTab @=? elems (asciiTabB) ] , testGroup "Text.Show.Text.Data.Complex" - [ testProperty "Complex Double instance" (prop_matchesShow :: Int -> Complex Double -> Bool) + [ testProperty "Complex Double instance" (prop_matchesShow :: Int -> Complex Double -> Bool) ] , testGroup "Text.Show.Text.Data.Data" - [ testProperty "Constr instance" (prop_matchesShow :: Int -> Constr -> Bool) - , testProperty "ConstrRep instance" (prop_matchesShow :: Int -> ConstrRep -> Bool) - , testProperty "DataRep instance" (prop_matchesShow :: Int -> DataRep -> Bool) - , testProperty "DataType instance" (prop_matchesShow :: Int -> DataType -> Bool) - , testProperty "Fixity instance" (prop_matchesShow :: Int -> D.Fixity -> Bool) + [ testProperty "Constr instance" (prop_matchesShow :: Int -> Constr -> Bool) + , testProperty "ConstrRep instance" (prop_matchesShow :: Int -> ConstrRep -> Bool) + , testProperty "DataRep instance" (prop_matchesShow :: Int -> DataRep -> Bool) + , testProperty "DataType instance" (prop_matchesShow :: Int -> DataType -> Bool) + , testProperty "Fixity instance" (prop_matchesShow :: Int -> D.Fixity -> Bool) ] , testGroup "Text.Show.Text.Data.Dynamic" - [ testProperty "Dynamic instance" (prop_matchesShow :: Int -> Dynamic -> Bool) + [ testProperty "Dynamic instance" (prop_matchesShow :: Int -> Dynamic -> Bool) ] , testGroup "Text.Show.Text.Data.Either" - [ testProperty "Either Int Int instance" (prop_matchesShow :: Int -> Either Int Int -> Bool) + [ testProperty "Either Int Int instance" (prop_matchesShow :: Int -> Either Int Int -> Bool) ] , testGroup "Text.Show.Text.Data.Fixed" - [ testProperty "Fixed E0 instance" (prop_matchesShow :: Int -> Fixed E0 -> Bool) - , testProperty "Fixed E1 instance" (prop_matchesShow :: Int -> Fixed E1 -> Bool) - , testProperty "Fixed E2 instance" (prop_matchesShow :: Int -> Fixed E2 -> Bool) - , testProperty "Fixed E3 instance" (prop_matchesShow :: Int -> Fixed E3 -> Bool) - , testProperty "Fixed E6 instance" (prop_matchesShow :: Int -> Fixed E6 -> Bool) - , testProperty "Fixed E9 instance" (prop_matchesShow :: Int -> Fixed E9 -> Bool) - , testProperty "Fixed E12 instance" (prop_matchesShow :: Int -> Fixed E12 -> Bool) - , testProperty "showFixed output" prop_showFixed + [ testProperty "Fixed E0 instance" (prop_matchesShow :: Int -> Fixed E0 -> Bool) + , testProperty "Fixed E1 instance" (prop_matchesShow :: Int -> Fixed E1 -> Bool) + , testProperty "Fixed E2 instance" (prop_matchesShow :: Int -> Fixed E2 -> Bool) + , testProperty "Fixed E3 instance" (prop_matchesShow :: Int -> Fixed E3 -> Bool) + , testProperty "Fixed E6 instance" (prop_matchesShow :: Int -> Fixed E6 -> Bool) + , testProperty "Fixed E9 instance" (prop_matchesShow :: Int -> Fixed E9 -> Bool) + , testProperty "Fixed E12 instance" (prop_matchesShow :: Int -> Fixed E12 -> Bool) + , testProperty "showFixed output" prop_showFixed ] , testGroup "Text.Show.Text.Data.Floating" - [ testProperty "Float instance" (prop_matchesShow :: Int -> Float -> Bool) - , testProperty "Double instance" (prop_matchesShow :: Int -> Double -> Bool) - , testProperty "showbEFloat output" $ prop_showXFloat showEFloat showbEFloat - , testProperty "showbFFloat output" $ prop_showXFloat showFFloat showbFFloat - , testProperty "showbGFloat output" $ prop_showXFloat showGFloat showbGFloat + [ testProperty "Float instance" (prop_matchesShow :: Int -> Float -> Bool) + , testProperty "Double instance" (prop_matchesShow :: Int -> Double -> Bool) + , testProperty "showbEFloat output" $ prop_showXFloat showEFloat showbEFloat + , testProperty "showbFFloat output" $ prop_showXFloat showFFloat showbFFloat + , testProperty "showbGFloat output" $ prop_showXFloat showGFloat showbGFloat #if MIN_VERSION_base(4,7,0) - , testProperty "showbFFloatAlt output" $ prop_showXFloat showFFloatAlt showbFFloatAlt - , testProperty "showbGFloatAlt output" $ prop_showXFloat showGFloatAlt showbGFloatAlt + , testProperty "showbFFloatAlt output" $ prop_showXFloat showFFloatAlt showbFFloatAlt + , testProperty "showbGFloatAlt output" $ prop_showXFloat showGFloatAlt showbGFloatAlt #endif ] , testGroup "Text.Show.Text.Data.Functions" - [ testProperty "Int -> Int instance" (prop_matchesShow :: Int -> (Int -> Int) -> Bool) + [ testProperty "Int -> Int instance" (prop_matchesShow :: Int -> (Int -> Int) -> Bool) ] , testGroup "Text.Show.Text.Data.Functor.Identity" - [ testProperty "Identity Int instance" (prop_matchesShow :: Int -> Identity Int -> Bool) + [ testProperty "Identity Int instance" (prop_matchesShow :: Int -> Identity Int -> Bool) ] , testGroup "Text.Show.Text.Data.Integral" - [ testProperty "Int instance" (prop_matchesShow :: Int -> Int -> Bool) - , testProperty "Int8 instance" (prop_matchesShow :: Int -> Int8 -> Bool) - , testProperty "Int16 instance" (prop_matchesShow :: Int -> Int16 -> Bool) - , testProperty "Int32 instance" (prop_matchesShow :: Int -> Int32 -> Bool) - , testProperty "Int64 instance" (prop_matchesShow :: Int -> Int64 -> Bool) - , testProperty "Integer instance" (prop_matchesShow :: Int -> Integer -> Bool) - , testProperty "Word instance" (prop_matchesShow :: Int -> Word -> Bool) - , testProperty "Word8 instance" (prop_matchesShow :: Int -> Word8 -> Bool) - , testProperty "Word16 instance" (prop_matchesShow :: Int -> Word16 -> Bool) - , testProperty "Word32 instance" (prop_matchesShow :: Int -> Word32 -> Bool) - , testProperty "Word64 instance" (prop_matchesShow :: Int -> Word64 -> Bool) -#if !defined(mingw32_HOST_OS) + [ testProperty "Int instance" (prop_matchesShow :: Int -> Int -> Bool) + , testProperty "Int8 instance" (prop_matchesShow :: Int -> Int8 -> Bool) + , testProperty "Int16 instance" (prop_matchesShow :: Int -> Int16 -> Bool) + , testProperty "Int32 instance" (prop_matchesShow :: Int -> Int32 -> Bool) + , testProperty "Int64 instance" (prop_matchesShow :: Int -> Int64 -> Bool) + , testProperty "Integer instance" (prop_matchesShow :: Int -> Integer -> Bool) + , testProperty "Word instance" (prop_matchesShow :: Int -> Word -> Bool) + , testProperty "Word8 instance" (prop_matchesShow :: Int -> Word8 -> Bool) + , testProperty "Word16 instance" (prop_matchesShow :: Int -> Word16 -> Bool) + , testProperty "Word32 instance" (prop_matchesShow :: Int -> Word32 -> Bool) + , testProperty "Word64 instance" (prop_matchesShow :: Int -> Word64 -> Bool) +#if !defined(mingw32_HOST_OS) && MIN_VERSION_text(1,0,0) -- TODO: Figure out why this diverges on Windows - , testProperty "showbIntAtBase output" prop_showIntAtBase + , testProperty "showbIntAtBase output" prop_showIntAtBase #endif ] , testGroup "Text.Show.Text.Data.List" - [ testProperty "String instance" (prop_matchesShow :: Int -> String -> Bool) - , testProperty "[String] instance" (prop_matchesShow :: Int -> [String] -> Bool) - , testProperty "[Int] instance" (prop_matchesShow :: Int -> [Int] -> Bool) - , testProperty "showbListDefault output" prop_showListDefault + [ testProperty "String instance" (prop_matchesShow :: Int -> String -> Bool) + , testProperty "[String] instance" (prop_matchesShow :: Int -> [String] -> Bool) + , testProperty "[Int] instance" (prop_matchesShow :: Int -> [Int] -> Bool) + , testProperty "[LitChar] instance" (prop_matchesShow :: Int -> [LitChar] -> Bool) + , testProperty "LitString instance" (prop_matchesShow :: Int -> LitString -> Bool) + , testProperty "[LitString] instance" (prop_matchesShow :: Int -> [LitString] -> Bool) + , testProperty "showbListDefault output" prop_showListDefault ] , testGroup "Text.Show.Text.Data.Maybe" - [ testProperty "Maybe Int instance" (prop_matchesShow :: Int -> Maybe Int -> Bool) + [ testProperty "Maybe Int instance" (prop_matchesShow :: Int -> Maybe Int -> Bool) ] , testGroup "Text.Show.Text.Data.Monoid" - [ testProperty "All instance" (prop_matchesShow :: Int -> All -> Bool) - , testProperty "Any instance" (prop_matchesShow :: Int -> Any -> Bool) - , testProperty "Dual Int instance" (prop_matchesShow :: Int -> Dual Int -> Bool) - , testProperty "First (Maybe Int) instance" (prop_matchesShow :: Int -> First (Maybe Int) -> Bool) - , testProperty "Last (Maybe Int) instance" (prop_matchesShow :: Int -> Last (Maybe Int) -> Bool) - , testProperty "Product Int instance" (prop_matchesShow :: Int -> Product Int -> Bool) - , testProperty "Sum Int instance" (prop_matchesShow :: Int -> Sum Int -> Bool) + [ testProperty "All instance" (prop_matchesShow :: Int -> All -> Bool) + , testProperty "Any instance" (prop_matchesShow :: Int -> Any -> Bool) + , testProperty "Dual Int instance" (prop_matchesShow :: Int -> Dual Int -> Bool) + , testProperty "First (Maybe Int) instance" (prop_matchesShow :: Int -> First (Maybe Int) -> Bool) + , testProperty "Last (Maybe Int) instance" (prop_matchesShow :: Int -> Last (Maybe Int) -> Bool) + , testProperty "Product Int instance" (prop_matchesShow :: Int -> Product Int -> Bool) + , testProperty "Sum Int instance" (prop_matchesShow :: Int -> Sum Int -> Bool) #if MIN_VERSION_base(4,8,0) - , testProperty "Alt Maybe Int instance" (prop_matchesShow :: Int -> Alt Maybe Int -> Bool) + , testProperty "Alt Maybe Int instance" (prop_matchesShow :: Int -> Alt Maybe Int -> Bool) #endif ] #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) , testGroup "Text.Show.Text.Data.OldTypeable" - [ -- testProperty "TypeRep instance" (prop_matchesShow :: Int -> OldT.TypeRep -> Bool) - testProperty "TyCon instance" (prop_matchesShow :: Int -> OldT.TyCon -> Bool) + [ testProperty "TypeRep instance" (prop_matchesShow :: Int -> OldT.TypeRep -> Bool) + , testProperty "TyCon instance" (prop_matchesShow :: Int -> OldT.TyCon -> Bool) ] #endif , testGroup "Text.Show.Text.Data.Ord" - [ testProperty "Ordering instance" (prop_matchesShow :: Int -> Ordering -> Bool) + [ testProperty "Ordering instance" (prop_matchesShow :: Int -> Ordering -> Bool) #if MIN_VERSION_base(4,6,0) - , testProperty "Down Int instance" (prop_matchesShow :: Int -> Down Int -> Bool) + , testProperty "Down Int instance" (prop_matchesShow :: Int -> Down Int -> Bool) #endif ] , testGroup "Text.Show.Text.Data.Proxy" - [ testProperty "Proxy Int instance" (prop_matchesShow :: Int -> Proxy Int -> Bool) + [ testProperty "Proxy Int instance" (prop_matchesShow :: Int -> Proxy Int -> Bool) ] , testGroup "Text.Show.Text.Data.Ratio" - [ testProperty "Ratio Int instance" (prop_matchesShow :: Int -> Ratio Int -> Bool) + [ testProperty "Ratio Int instance" (prop_matchesShow :: Int -> Ratio Int -> Bool) ] , testGroup "Text.Show.Text.Data.Text" - [ testProperty "Builder instance" (prop_matchesShow :: Int -> Builder -> Bool) - , testProperty "strict Text instance" (prop_matchesShow :: Int -> TS.Text -> Bool) - , testProperty "lazy Text instance" (prop_matchesShow :: Int -> TL.Text -> Bool) + [ testProperty "Builder instance" (prop_matchesShow :: Int -> Builder -> Bool) + , testProperty "strict Text instance" (prop_matchesShow :: Int -> TS.Text -> Bool) + , testProperty "lazy Text instance" (prop_matchesShow :: Int -> TL.Text -> Bool) ] , testGroup "Text.Show.Text.Data.Tuple" - [ testProperty "() instance" (prop_matchesShow :: Int -> () -> Bool) - , testProperty "(Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int) -> Bool) - , testProperty "(Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int) -> Bool) - , testProperty "(Int, Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int, Int) -> Bool) - , testProperty "(Int, Int, Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int, Int, Int) -> Bool) + [ testProperty "() instance" (prop_matchesShow :: Int -> () -> Bool) + , testProperty "(Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int) -> Bool) + , testProperty "(Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int) -> Bool) + , testProperty "(Int, Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int, Int) -> Bool) + , testProperty "(Int, Int, Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int, Int, Int) -> Bool) + , testProperty "() generic show" (prop_genericShow :: Int -> () -> Bool) + , testProperty "(Int, Int) generic show" (prop_genericShow :: Int -> (Int, Int) -> Bool) + , testProperty "(Int, Int, Int) generic show" (prop_genericShow :: Int -> (Int, Int, Int) -> Bool) + , testProperty "(Int, Int, Int, Int) generic show" (prop_genericShow :: Int -> (Int, Int, Int, Int) -> Bool) + , testProperty "(Int, Int, Int, Int, Int) generic show" (prop_genericShow :: Int -> (Int, Int, Int, Int, Int) -> Bool) ] #if MIN_VERSION_base(4,7,0) , testGroup "Text.Show.Text.Data.Type.Coercion" - [ testProperty "Coercion instance" (prop_matchesShow :: Int -> Coercion All Bool -> Bool) + [ testProperty "Coercion instance" (prop_matchesShow :: Int -> Coercion All Bool -> Bool) ] , testGroup "Text.Show.Text.Data.Type.Equality" - [ testProperty "(:~:) instance" (prop_matchesShow :: Int -> Int :~: Int -> Bool) + [ testProperty "(:~:) instance" (prop_matchesShow :: Int -> Int :~: Int -> Bool) ] #endif -#if MIN_VERSION_base(4,4,0) , testGroup "Text.Show.Text.Data.Typeable" - [ -- testProperty "TypeRep instance" (prop_matchesShow :: Int -> NewT.TypeRep -> Bool) - testProperty "TyCon instance" (prop_matchesShow :: Int -> NewT.TyCon -> Bool) + [ testProperty "TypeRep instance" (prop_matchesShow :: Int -> NewT.TypeRep -> Bool) + , testProperty "TyCon instance" (prop_matchesShow :: Int -> NewT.TyCon -> Bool) ] -#endif , testGroup "Text.Show.Text.Data.Version" - [ testProperty "Version instance" (prop_matchesShow :: Int -> Version -> Bool) - , testProperty "showbVersionConcrete output" prop_showVersion + [ testProperty "Version instance" (prop_matchesShow :: Int -> Version -> Bool) + , testProperty "showbVersionConcrete output" prop_showVersion ] , testGroup "Text.Show.Text.Foreign.C.Types" - [ testProperty "CChar" (prop_matchesShow :: Int -> CChar -> Bool) - , testProperty "CSChar instance" (prop_matchesShow :: Int -> CSChar -> Bool) - , testProperty "CUChar instance" (prop_matchesShow :: Int -> CUChar -> Bool) - , testProperty "CShort instance" (prop_matchesShow :: Int -> CShort -> Bool) - , testProperty "CUShort instance" (prop_matchesShow :: Int -> CUShort -> Bool) - , testProperty "CInt instance" (prop_matchesShow :: Int -> CInt -> Bool) - , testProperty "CUInt instance" (prop_matchesShow :: Int -> CUInt -> Bool) - , testProperty "CLong instance" (prop_matchesShow :: Int -> CLong -> Bool) - , testProperty "CULong instance" (prop_matchesShow :: Int -> CULong -> Bool) - , testProperty "CPtrdiff instance" (prop_matchesShow :: Int -> CPtrdiff -> Bool) - , testProperty "CSize instance" (prop_matchesShow :: Int -> CSize -> Bool) - , testProperty "CWchar instance" (prop_matchesShow :: Int -> CWchar -> Bool) - , testProperty "CSigAtomic instance" (prop_matchesShow :: Int -> CSigAtomic -> Bool) - , testProperty "CLLong instance" (prop_matchesShow :: Int -> CLLong -> Bool) - , testProperty "CULLong instance" (prop_matchesShow :: Int -> CULLong -> Bool) - , testProperty "CIntPtr instance" (prop_matchesShow :: Int -> CIntPtr -> Bool) - , testProperty "CUIntPtr instance" (prop_matchesShow :: Int -> CUIntPtr -> Bool) - , testProperty "CIntMax instance" (prop_matchesShow :: Int -> CIntMax -> Bool) - , testProperty "CUIntPtr instance" (prop_matchesShow :: Int -> CUIntPtr -> Bool) - , testProperty "CIntMax instance" (prop_matchesShow :: Int -> CIntMax -> Bool) - , testProperty "CUIntMax instance" (prop_matchesShow :: Int -> CUIntMax -> Bool) - , testProperty "CClock instance" (prop_matchesShow :: Int -> CClock -> Bool) - , testProperty "CTime instance" (prop_matchesShow :: Int -> CTime -> Bool) -#if MIN_VERSION_base(4,4,0) - , testProperty "CUSeconds instance" (prop_matchesShow :: Int -> CUSeconds -> Bool) - , testProperty "CSUSeconds instance" (prop_matchesShow :: Int -> CSUSeconds -> Bool) -#endif - , testProperty "CFloat instance" (prop_matchesShow :: Int -> CFloat -> Bool) - , testProperty "CDouble instance" (prop_matchesShow :: Int -> CUChar -> Bool) + [ testProperty "CChar" (prop_matchesShow :: Int -> CChar -> Bool) + , testProperty "CSChar instance" (prop_matchesShow :: Int -> CSChar -> Bool) + , testProperty "CUChar instance" (prop_matchesShow :: Int -> CUChar -> Bool) + , testProperty "CShort instance" (prop_matchesShow :: Int -> CShort -> Bool) + , testProperty "CUShort instance" (prop_matchesShow :: Int -> CUShort -> Bool) + , testProperty "CInt instance" (prop_matchesShow :: Int -> CInt -> Bool) + , testProperty "CUInt instance" (prop_matchesShow :: Int -> CUInt -> Bool) + , testProperty "CLong instance" (prop_matchesShow :: Int -> CLong -> Bool) + , testProperty "CULong instance" (prop_matchesShow :: Int -> CULong -> Bool) + , testProperty "CPtrdiff instance" (prop_matchesShow :: Int -> CPtrdiff -> Bool) + , testProperty "CSize instance" (prop_matchesShow :: Int -> CSize -> Bool) + , testProperty "CWchar instance" (prop_matchesShow :: Int -> CWchar -> Bool) + , testProperty "CSigAtomic instance" (prop_matchesShow :: Int -> CSigAtomic -> Bool) + , testProperty "CLLong instance" (prop_matchesShow :: Int -> CLLong -> Bool) + , testProperty "CULLong instance" (prop_matchesShow :: Int -> CULLong -> Bool) + , testProperty "CIntPtr instance" (prop_matchesShow :: Int -> CIntPtr -> Bool) + , testProperty "CUIntPtr instance" (prop_matchesShow :: Int -> CUIntPtr -> Bool) + , testProperty "CIntMax instance" (prop_matchesShow :: Int -> CIntMax -> Bool) + , testProperty "CUIntPtr instance" (prop_matchesShow :: Int -> CUIntPtr -> Bool) + , testProperty "CIntMax instance" (prop_matchesShow :: Int -> CIntMax -> Bool) + , testProperty "CUIntMax instance" (prop_matchesShow :: Int -> CUIntMax -> Bool) + , testProperty "CClock instance" (prop_matchesShow :: Int -> CClock -> Bool) + , testProperty "CTime instance" (prop_matchesShow :: Int -> CTime -> Bool) + , testProperty "CUSeconds instance" (prop_matchesShow :: Int -> CUSeconds -> Bool) + , testProperty "CSUSeconds instance" (prop_matchesShow :: Int -> CSUSeconds -> Bool) + , testProperty "CFloat instance" (prop_matchesShow :: Int -> CFloat -> Bool) + , testProperty "CDouble instance" (prop_matchesShow :: Int -> CUChar -> Bool) ] , testGroup "Text.Show.Text.Foreign.Ptr" - [ testProperty "Ptr Int instance" (prop_matchesShow :: Int -> Ptr Int -> Bool) - , testProperty "FunPtr Int instance" (prop_matchesShow :: Int -> FunPtr Int -> Bool) - , testProperty "IntPtr instance" (prop_matchesShow :: Int -> IntPtr -> Bool) - , testProperty "WordPtr instance" (prop_matchesShow :: Int -> WordPtr -> Bool) --- , testProperty "ForeignPtr instance" (prop_matchesShow :: Int -> ForeignPtr Int -> Bool) + [ testProperty "Ptr Int instance" (prop_matchesShow :: Int -> Ptr Int -> Bool) + , testProperty "FunPtr Int instance" (prop_matchesShow :: Int -> FunPtr Int -> Bool) + , testProperty "IntPtr instance" (prop_matchesShow :: Int -> IntPtr -> Bool) + , testProperty "WordPtr instance" (prop_matchesShow :: Int -> WordPtr -> Bool) +-- , testProperty "ForeignPtr instance" (prop_matchesShow :: Int -> ForeignPtr Int -> Bool) ] --- #if MIN_VERSION_base(4,4,0) && !defined(mingw32_HOST_OS) +-- #if !defined(mingw32_HOST_OS) -- , testGroup "Text.Show.Text.GHC.Event" --- [ testProperty "Event instance" (prop_matchesShow :: Int -> Event -> Bool) --- , testProperty "FdKey instance" (prop_matchesShow :: Int -> FdKey -> Bool) +-- [ testProperty "Event instance" (prop_matchesShow :: Int -> Event -> Bool) +-- , testProperty "FdKey instance" (prop_matchesShow :: Int -> FdKey -> Bool) -- ] -- #endif + , testGroup "Text.Show.Text.Generic" + [ testProperty "ConType instance" (prop_matchesShow :: Int -> ConType -> Bool) + , testProperty "ConType generic show" (prop_genericShow :: Int -> ConType -> Bool) + ] #if defined(mingw32_HOST_OS) , testGroup "Text.Show.Text.GHC.Conc.Windows" - [ testProperty "ConsoleEvent instance" (prop_matchesShow :: Int -> ConsoleEvent -> Bool) + [ testProperty "ConsoleEvent instance" (prop_matchesShow :: Int -> ConsoleEvent -> Bool) ] #endif -#if MIN_VERSION_base(4,4,0) , testGroup "Text.Show.Text.GHC.Fingerprint" - [ testProperty "Fingerprint instance" (prop_matchesShow :: Int -> Fingerprint -> Bool) + [ testProperty "Fingerprint instance" (prop_matchesShow :: Int -> Fingerprint -> Bool) ] -#endif , testGroup "Text.Show.Text.GHC.Generics" - [ testProperty "U1 Int instance" (prop_matchesShow :: Int -> U1 Int -> Bool) - , testProperty "Par1 Int instance" (prop_matchesShow :: Int -> Par1 Int -> Bool) - , testProperty "Rec1 Maybe Int instance" (prop_matchesShow :: Int -> Rec1 Maybe Int -> Bool) - , testProperty "K1 () Int () instance" (prop_matchesShow :: Int -> K1 () Int () -> Bool) - , testProperty "M1 () () Maybe Int instance" (prop_matchesShow :: Int -> M1 () () Maybe Int -> Bool) - , testProperty "(Maybe :+: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :+: Maybe) Int -> Bool) - , testProperty "(Maybe :*: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :*: Maybe) Int -> Bool) - , testProperty "(Maybe :.: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :.: Maybe) Int -> Bool) - , testProperty "Fixity instance" (prop_matchesShow :: Int -> G.Fixity -> Bool) - , testProperty "Associativity instance" (prop_matchesShow :: Int -> Associativity -> Bool) - , testProperty "Arity instance" (prop_matchesShow :: Int -> Arity -> Bool) + [ testProperty "U1 Int instance" (prop_matchesShow :: Int -> U1 Int -> Bool) + , testProperty "Par1 Int instance" (prop_matchesShow :: Int -> Par1 Int -> Bool) + , testProperty "Rec1 Maybe Int instance" (prop_matchesShow :: Int -> Rec1 Maybe Int -> Bool) + , testProperty "K1 () Int () instance" (prop_matchesShow :: Int -> K1 () Int () -> Bool) + , testProperty "M1 () () Maybe Int instance" (prop_matchesShow :: Int -> M1 () () Maybe Int -> Bool) + , testProperty "(Maybe :+: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :+: Maybe) Int -> Bool) + , testProperty "(Maybe :*: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :*: Maybe) Int -> Bool) + , testProperty "(Maybe :.: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :.: Maybe) Int -> Bool) + , testProperty "Fixity instance" (prop_matchesShow :: Int -> G.Fixity -> Bool) + , testProperty "Associativity instance" (prop_matchesShow :: Int -> Associativity -> Bool) + , testProperty "Arity instance" (prop_matchesShow :: Int -> Arity -> Bool) ] #if MIN_VERSION_base(4,8,0) , testGroup "Text.Show.Text.GHC.RTS.Flags" - [ -- testProperty "RTSFlags instance" (prop_matchesShow :: Int -> RTSFlags -> Bool) --- , testProperty "GCFlags instance" (prop_matchesShow :: Int -> GCFlags -> Bool) - testProperty "ConcFlags instance" (prop_matchesShow :: Int -> ConcFlags -> Bool) - , testProperty "MiscFlags instance" (prop_matchesShow :: Int -> MiscFlags -> Bool) - , testProperty "DebugFlags instance" (prop_matchesShow :: Int -> DebugFlags -> Bool) --- , testProperty "CCFlags instance" (prop_matchesShow :: Int -> CCFlags -> Bool) --- , testProperty "ProfFlags instance" (prop_matchesShow :: Int -> ProfFlags -> Bool) --- , testProperty "TraceFlags instance" (prop_matchesShow :: Int -> TraceFlags -> Bool) - , testProperty "TickyFlags instance" (prop_matchesShow :: Int -> TickyFlags -> Bool) + [ -- testProperty "RTSFlags instance" (prop_matchesShow :: Int -> RTSFlags -> Bool) +-- , testProperty "GCFlags instance" (prop_matchesShow :: Int -> GCFlags -> Bool) + testProperty "ConcFlags instance" (prop_matchesShow :: Int -> ConcFlags -> Bool) + , testProperty "MiscFlags instance" (prop_matchesShow :: Int -> MiscFlags -> Bool) + , testProperty "DebugFlags instance" (prop_matchesShow :: Int -> DebugFlags -> Bool) +-- , testProperty "CCFlags instance" (prop_matchesShow :: Int -> CCFlags -> Bool) +-- , testProperty "ProfFlags instance" (prop_matchesShow :: Int -> ProfFlags -> Bool) +-- , testProperty "TraceFlags instance" (prop_matchesShow :: Int -> TraceFlags -> Bool) + , testProperty "TickyFlags instance" (prop_matchesShow :: Int -> TickyFlags -> Bool) ] , testGroup "Text.Show.Text.GHC.StaticPtr" - [ testProperty "StaticPtrInfo instance" (prop_matchesShow :: Int -> StaticPtrInfo -> Bool) + [ testProperty "StaticPtrInfo instance" (prop_matchesShow :: Int -> StaticPtrInfo -> Bool) ] #endif -#if MIN_VERSION_base(4,5,0) , testGroup "Text.Show.Text.GHC.Stats" - [ testProperty "GCStats instance" (prop_matchesShow :: Int -> GCStats -> Bool) + [ testProperty "GCStats instance" (prop_matchesShow :: Int -> GCStats -> Bool) ] -#endif #if MIN_VERSION_base(4,6,0) , testGroup "Text.Show.Text.GHC.TypeLits" [ # if MIN_VERSION_base(4,7,0) - testProperty "SomeNat instance" (prop_matchesShow :: Int -> SomeNat -> Bool) - , testProperty "SomeSymbol instance" (prop_matchesShow :: Int -> SomeSymbol -> Bool) + testProperty "SomeNat instance" (prop_matchesShow :: Int -> SomeNat -> Bool) + , testProperty "SomeSymbol instance" (prop_matchesShow :: Int -> SomeSymbol -> Bool) -- # else --- testProperty "IsEven instance" (prop_matchesShow :: Int -> IsEven -> Bool) --- , testProperty "IsZero instance" (prop_matchesShow :: Int -> IsZero -> Bool) +-- testProperty "IsEven instance" (prop_matchesShow :: Int -> IsEven -> Bool) +-- , testProperty "IsZero instance" (prop_matchesShow :: Int -> IsZero -> Bool) # endif ] #endif , testGroup "Text.Show.Text.Numeric.Natural" - [ testProperty "Natural instance" (prop_matchesShow :: Int -> Natural -> Bool) + [ testProperty "Natural instance" (prop_matchesShow :: Int -> Natural -> Bool) ] , testGroup "Text.Show.Text.System.Exit" - [ testProperty "ExitCode instance" (prop_matchesShow :: Int -> ExitCode -> Bool) + [ testProperty "ExitCode instance" (prop_matchesShow :: Int -> ExitCode -> Bool) ] , testGroup "Text.Show.Text.System.IO" - [ -- testProperty "Handle instance" (prop_matchesShow :: Int -> Handle -> Bool) - testProperty "IOMode instance" (prop_matchesShow :: Int -> IOMode -> Bool) - , testProperty "BufferMode instance" (prop_matchesShow :: Int -> BufferMode -> Bool) --- , testProperty "HandlePosn instance" (prop_matchesShow :: Int -> HandlePosn -> Bool) - , testProperty "SeekMode instance" (prop_matchesShow :: Int -> SeekMode -> Bool) --- #if MIN_VERSION_base(4,3,0) --- , testProperty "TextEncoding" (prop_matchesShow :: Int -> TextEncoding -> Bool) --- #endif -#if MIN_VERSION_base(4,4,0) - , testProperty "CodingProgress instance" (prop_matchesShow :: Int -> CodingProgress -> Bool) - , testProperty "CodingFailureMode instance" (prop_matchesShow :: Int -> CodingFailureMode -> Bool) -#endif - , testProperty "Newline instance" (prop_matchesShow :: Int -> Newline -> Bool) - , testProperty "NewlineMode instance" (prop_matchesShow :: Int -> NewlineMode -> Bool) + [ testProperty "Handle instance" (prop_matchesShow :: Int -> Handle -> Bool) + , testProperty "IOMode instance" (prop_matchesShow :: Int -> IOMode -> Bool) + , testProperty "BufferMode instance" (prop_matchesShow :: Int -> BufferMode -> Bool) +-- , testProperty "HandlePosn instance" (prop_matchesShow :: Int -> HandlePosn -> Bool) + , testProperty "SeekMode instance" (prop_matchesShow :: Int -> SeekMode -> Bool) +-- , testProperty "TextEncoding" (prop_matchesShow :: Int -> TextEncoding -> Bool) + , testProperty "CodingProgress instance" (prop_matchesShow :: Int -> CodingProgress -> Bool) + , testProperty "CodingFailureMode instance" (prop_matchesShow :: Int -> CodingFailureMode -> Bool) + , testProperty "Newline instance" (prop_matchesShow :: Int -> Newline -> Bool) + , testProperty "NewlineMode instance" (prop_matchesShow :: Int -> NewlineMode -> Bool) ] , testGroup "Text.Show.Text.System.Posix.Types" [ #if defined(HTYPE_DEV_T) - testProperty "CDev instance" (prop_matchesShow :: Int -> CDev -> Bool) + testProperty "CDev instance" (prop_matchesShow :: Int -> CDev -> Bool) #endif #if defined(HTYPE_INO_T) - , testProperty "CIno instance" (prop_matchesShow :: Int -> CIno -> Bool) + , testProperty "CIno instance" (prop_matchesShow :: Int -> CIno -> Bool) #endif #if defined(HTYPE_MODE_T) - , testProperty "CMode instance" (prop_matchesShow :: Int -> CMode -> Bool) + , testProperty "CMode instance" (prop_matchesShow :: Int -> CMode -> Bool) #endif #if defined(HTYPE_OFF_T) - , testProperty "COff instance" (prop_matchesShow :: Int -> COff -> Bool) + , testProperty "COff instance" (prop_matchesShow :: Int -> COff -> Bool) #endif #if defined(HTYPE_PID_T) - , testProperty "CPid instance" (prop_matchesShow :: Int -> CPid -> Bool) + , testProperty "CPid instance" (prop_matchesShow :: Int -> CPid -> Bool) #endif #if defined(HTYPE_SSIZE_T) - , testProperty "CSsize instance" (prop_matchesShow :: Int -> CSsize -> Bool) + , testProperty "CSsize instance" (prop_matchesShow :: Int -> CSsize -> Bool) #endif #if defined(HTYPE_GID_T) - , testProperty "CGid instance" (prop_matchesShow :: Int -> CGid -> Bool) + , testProperty "CGid instance" (prop_matchesShow :: Int -> CGid -> Bool) #endif #if defined(HTYPE_NLINK_T) - , testProperty "CNlink instance" (prop_matchesShow :: Int -> CNlink -> Bool) + , testProperty "CNlink instance" (prop_matchesShow :: Int -> CNlink -> Bool) #endif #if defined(HTYPE_UID_T) - , testProperty "CUid instance" (prop_matchesShow :: Int -> CUid -> Bool) + , testProperty "CUid instance" (prop_matchesShow :: Int -> CUid -> Bool) #endif #if defined(HTYPE_CC_T) - , testProperty "CCc instance" (prop_matchesShow :: Int -> CCc -> Bool) + , testProperty "CCc instance" (prop_matchesShow :: Int -> CCc -> Bool) #endif #if defined(HTYPE_SPEED_T) - , testProperty "CSpeed instance" (prop_matchesShow :: Int -> CSpeed -> Bool) + , testProperty "CSpeed instance" (prop_matchesShow :: Int -> CSpeed -> Bool) #endif #if defined(HTYPE_TCFLAG_T) - , testProperty "CTcflag instance" (prop_matchesShow :: Int -> CTcflag -> Bool) + , testProperty "CTcflag instance" (prop_matchesShow :: Int -> CTcflag -> Bool) #endif #if defined(HTYPE_RLIM_T) - , testProperty "CRLim instance" (prop_matchesShow :: Int -> CRLim -> Bool) + , testProperty "CRLim instance" (prop_matchesShow :: Int -> CRLim -> Bool) #endif - , testProperty "Fd instance" (prop_matchesShow :: Int -> Fd -> Bool) + , testProperty "Fd instance" (prop_matchesShow :: Int -> Fd -> Bool) ] -- , testGroup "Text.Show.Text.Text.Read.Lex" --- [ testProperty "Lexeme instance" (prop_matchesShow :: Int -> Lexeme -> Bool) --- , testProperty "Number instance" (prop_matchesShow :: Int -> Number -> Bool) +-- [ testProperty "Lexeme instance" (prop_matchesShow :: Int -> Lexeme -> Bool) +-- , testProperty "Number instance" (prop_matchesShow :: Int -> Number -> Bool) -- ] ] diff --git a/tests/Properties/Builder.hs b/tests/Properties/Builder.hs --- a/tests/Properties/Builder.hs +++ b/tests/Properties/Builder.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| Module: Properties.Builder Copyright: (C) 2014-2015 Ryan Scott @@ -18,20 +17,11 @@ import Text.Show.Text (Builder, fromString, fromText, lengthB, toString, toText, unlinesB, unwordsB) -#if !defined(mingw32_HOST_OS) -import Text.Show.Text (replicateB, singleton) -#endif -- | Verifies 'lengthB' and 'length' produce the same output. prop_lengthB :: String -> Bool prop_lengthB s = fromIntegral (lengthB $ fromString s) == length s -#if !defined(mingw32_HOST_OS) --- | Verifies 'replicateB' and 'replicate' produce the same output. -prop_replicateB :: Int -> Char -> Bool -prop_replicateB i c = replicateB (fromIntegral i) (singleton c) == fromString (replicate i c) -#endif - -- | Verifies @fromText . toText = id@. prop_toText :: Builder -> Bool prop_toText b = fromText (toText b) == b @@ -52,10 +42,6 @@ builderTests = [ testGroup "Builder-related functions" [ testProperty "lengthB output" prop_lengthB -#if !defined(mingw32_HOST_OS) --- TODO: Figure out why this diverges on Windows - , testProperty "replicateB output" prop_replicateB -#endif , testProperty "fromString . toString = id" prop_toString , testProperty "fromText . toText = id" prop_toText , testProperty "unlinesB output" prop_unlinesB diff --git a/tests/Properties/Derived.hs b/tests/Properties/Derived.hs --- a/tests/Properties/Derived.hs +++ b/tests/Properties/Derived.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP, TypeOperators #-} {-| Module: Properties.BaseAndFriends Copyright: (C) 2014-2015 Ryan Scott @@ -16,66 +16,94 @@ import Instances.Derived () -import Properties.Utils (prop_matchesShow) +import Properties.Utils (prop_matchesShow, prop_genericShow) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Text.Show.Text (showb, showbPrec, FromStringShow(..)) - --- | Verifies that the two 'Show' instances of 'GADT' coincide. -prop_showGADT :: Int -- ^ The precedence to show with - -> Double -- ^ The argument to 'GADTCon2' - -> Int -- ^ The argument to 'GADTCon3' - -> Char -- ^ The argument to 'GADTCon4' - -> String -- ^ The argument to 'GADTCon5' - -> Bool -prop_showGADT p d i c s - = let gc1 :: GADT Char Int Int - gc1 = GADTCon1 - - gc2 :: GADT Double Double Int - gc2 = GADTCon2 d - - gc3 :: GADT Int String Int - gc3 = GADTCon3 i - - gc4 :: GADT Char String Int - gc4 = GADTCon4 c - - gc5 :: GADT String String Int - gc5 = GADTCon5 s - in showb (FromStringShow gc1) == showb gc1 - && showbPrec p (FromStringShow gc2) == showbPrec p gc2 - && showbPrec p (FromStringShow gc3) == showbPrec p gc3 - && showbPrec p (FromStringShow gc4) == showbPrec p gc4 - && showbPrec p (FromStringShow gc5) == showbPrec p gc5 - derivedTests :: [TestTree] derivedTests = [ testGroup "Template Haskell-derived data types" - [ testProperty "Nullary instance" (prop_matchesShow :: Int -> Nullary -> Bool) - , testProperty "PhantomNullary Int instance" (prop_matchesShow :: Int -> PhantomNullary Int -> Bool) - , testProperty "MonomorphicUnary instance" (prop_matchesShow :: Int -> MonomorphicUnary -> Bool) - , testProperty "PolymorphicUnary Int Int instance" (prop_matchesShow :: Int -> PolymorphicUnary Int Int -> Bool) - , testProperty "MonomorphicNewtype instance" (prop_matchesShow :: Int -> MonomorphicNewtype -> Bool) - , testProperty "PolymorphicNewtype Int Int instance" (prop_matchesShow :: Int -> PolymorphicNewtype Int Int -> Bool) - , testProperty "MonomorphicProduct instance" (prop_matchesShow :: Int -> MonomorphicProduct -> Bool) - , testProperty "PolymorphicProduct Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicProduct Int Int Int Int -> Bool) - , testProperty "MonomorphicRecord instance" (prop_matchesShow :: Int -> MonomorphicRecord -> Bool) - , testProperty "PolymorphicRecord Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicRecord Int Int Int Int -> Bool) - , testProperty "MonomorphicInfix instance" (prop_matchesShow :: Int -> MonomorphicInfix -> Bool) - , testProperty "PolymorphicInfix Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicInfix Int Int Int -> Bool) - , testProperty "MonomorphicForall instance" (prop_matchesShow :: Int -> MonomorphicForall -> Bool) - , testProperty "PolymorphicForall Int Int instance" (prop_matchesShow :: Int -> PolymorphicForall Int Int -> Bool) - , testProperty "AllAtOnce Int Int Int Int instance" (prop_matchesShow :: Int -> AllAtOnce Int Int Int Int -> Bool) - , testProperty "GADT instance" prop_showGADT --- TODO: These tests take forever. Look at quickcheck-instances (specifically, at the Tree instance) to see how to fix this. --- , testProperty "LeftAssocTree Int instance" (prop_matchesShow :: Int -> LeftAssocTree Int -> Bool) --- , testProperty "RightAssocTree Int instance" (prop_matchesShow :: Int -> RightAssocTree Int -> Bool) - , testProperty "Int :?: Int instance" (prop_matchesShow :: Int -> Int :?: Int -> Bool) - , testProperty "HigherKindedTypeParams Maybe Int instance" (prop_matchesShow :: Int -> HigherKindedTypeParams Maybe Int -> Bool) - , testProperty "RestrictedContext Int instance" (prop_matchesShow :: Int -> RestrictedContext Int -> Bool) - , testProperty "Fix Maybe instance" (prop_matchesShow :: Int -> Fix Maybe -> Bool) + [ testProperty "Nullary instance" (prop_matchesShow :: Int -> Nullary -> Bool) + , testProperty "PhantomNullary Int instance" (prop_matchesShow :: Int -> PhantomNullary Int -> Bool) + , testProperty "MonomorphicUnary instance" (prop_matchesShow :: Int -> MonomorphicUnary -> Bool) + , testProperty "PolymorphicUnary Int Int instance" (prop_matchesShow :: Int -> PolymorphicUnary Int Int -> Bool) + , testProperty "MonomorphicProduct instance" (prop_matchesShow :: Int -> MonomorphicProduct -> Bool) + , testProperty "PolymorphicProduct Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicProduct Int Int Int Int -> Bool) + , testProperty "MonomorphicRecord instance" (prop_matchesShow :: Int -> MonomorphicRecord -> Bool) + , testProperty "PolymorphicRecord Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicRecord Int Int Int Int -> Bool) + , testProperty "MonomorphicInfix instance" (prop_matchesShow :: Int -> MonomorphicInfix -> Bool) + , testProperty "PolymorphicInfix Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicInfix Int Int Int -> Bool) + , testProperty "MonomorphicForall instance" (prop_matchesShow :: Int -> MonomorphicForall -> Bool) + , testProperty "PolymorphicForall Int Int instance" (prop_matchesShow :: Int -> PolymorphicForall Int Int -> Bool) + , testProperty "AllAtOnce Int Int Int Int instance" (prop_matchesShow :: Int -> AllAtOnce Int Int Int Int -> Bool) + , testProperty "GADT Char Int Int instance" (prop_matchesShow :: Int -> GADT Char Int Int -> Bool) + , testProperty "GADT Double Double Int instance" (prop_matchesShow :: Int -> GADT Double Double Int -> Bool) + , testProperty "GADT Int String Int instance" (prop_matchesShow :: Int -> GADT Int String Int -> Bool) + , testProperty "GADT Ordering Int Int instance" (prop_matchesShow :: Int -> GADT Ordering Int Int -> Bool) + , testProperty "GADT Int Int Int instance" (prop_matchesShow :: Int -> GADT Int Int Int -> Bool) + , testProperty "LeftAssocTree Int instance" (prop_matchesShow :: Int -> LeftAssocTree Int -> Bool) + , testProperty "RightAssocTree Int instance" (prop_matchesShow :: Int -> RightAssocTree Int -> Bool) + , testProperty "Int :?: Int instance" (prop_matchesShow :: Int -> Int :?: Int -> Bool) + , testProperty "HigherKindedTypeParams Maybe Int instance" (prop_matchesShow :: Int -> HigherKindedTypeParams Maybe Int -> Bool) + , testProperty "RestrictedContext Int instance" (prop_matchesShow :: Int -> RestrictedContext Int -> Bool) + , testProperty "Fix Maybe instance" (prop_matchesShow :: Int -> Fix Maybe -> Bool) +#if MIN_VERSION_template_haskell(2,7,0) + , testProperty "AllShow () () Int Int instance" (prop_matchesShow :: Int -> AllShow () () Int Int -> Bool) + , testProperty "AllShow Int Int Int Int instance" (prop_matchesShow :: Int -> AllShow Int Int Int Int -> Bool) + , testProperty "AllShow Bool Bool Int Int instance" (prop_matchesShow :: Int -> AllShow Bool Bool Int Int -> Bool) + , testProperty "AllShow Char Double Int Int instance" (prop_matchesShow :: Int -> AllShow Char Double Int Int -> Bool) + , testProperty "AllShow Float Ordering Int Int instance" (prop_matchesShow :: Int -> AllShow Float Ordering Int Int -> Bool) + , testProperty "NotAllShow Int Int Int Int instance" (prop_matchesShow :: Int -> NotAllShow Int Int Int Int -> Bool) + , testProperty "OneDataInstance Int Int Int Int instance" (prop_matchesShow :: Int -> OneDataInstance Int Int Int Int -> Bool) + , testProperty "AssocData1 () instance" (prop_matchesShow :: Int -> AssocData1 () -> Bool) + , testProperty "AssocData2 () instance" (prop_matchesShow :: Int -> AssocData2 () Int Int -> Bool) +# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 + , testProperty "NullaryData instance" (prop_matchesShow :: Int -> NullaryData -> Bool) +# endif + , testProperty "GADTFam Char Int Int instance" (prop_matchesShow :: Int -> GADTFam Char Int Int -> Bool) + , testProperty "GADTFam Double Double Int instance" (prop_matchesShow :: Int -> GADTFam Double Double Int -> Bool) + , testProperty "GADTFam Int String Int instance" (prop_matchesShow :: Int -> GADTFam Int String Int -> Bool) + , testProperty "GADTFam Ordering Int Int instance" (prop_matchesShow :: Int -> GADTFam Ordering Int Int -> Bool) + , testProperty "GADTFam Int Int Int instance" (prop_matchesShow :: Int -> GADTFam Int Int Int -> Bool) +#endif + , testProperty "Nullary generic show" (prop_genericShow :: Int -> Nullary -> Bool) + , testProperty "PhantomNullary Int generic show" (prop_genericShow :: Int -> PhantomNullary Int -> Bool) + , testProperty "MonomorphicUnary generic show" (prop_genericShow :: Int -> MonomorphicUnary -> Bool) + , testProperty "PolymorphicUnary Int Int generic show" (prop_genericShow :: Int -> PolymorphicUnary Int Int -> Bool) + , testProperty "MonomorphicProduct generic show" (prop_genericShow :: Int -> MonomorphicProduct -> Bool) + , testProperty "PolymorphicProduct Int Int Int Int generic show" (prop_genericShow :: Int -> PolymorphicProduct Int Int Int Int -> Bool) + , testProperty "MonomorphicRecord generic show" (prop_genericShow :: Int -> MonomorphicRecord -> Bool) + , testProperty "PolymorphicRecord Int Int Int Int generic show" (prop_genericShow :: Int -> PolymorphicRecord Int Int Int Int -> Bool) + , testProperty "MonomorphicInfix generic show" (prop_genericShow :: Int -> MonomorphicInfix -> Bool) + , testProperty "PolymorphicInfix Int Int Int generic show" (prop_genericShow :: Int -> PolymorphicInfix Int Int Int -> Bool) +-- , testProperty "MonomorphicForall generic show" (prop_genericShow :: Int -> MonomorphicForall -> Bool) +-- , testProperty "PolymorphicForall Int Int generic show" (prop_genericShow :: Int -> PolymorphicForall Int Int -> Bool) +-- , testProperty "AllAtOnce Int Int Int Int generic show" (prop_genericShow :: Int -> AllAtOnce Int Int Int Int -> Bool) +-- , testProperty "GADT Char Int Int generic show" (prop_genericShow :: Int -> GADT Char Int Int -> Bool) +-- , testProperty "GADT Double Double Int generic show" (prop_genericShow :: Int -> GADT Double Double Int -> Bool) +-- , testProperty "GADT Int String Int generic show" (prop_genericShow :: Int -> GADT Int String Int -> Bool) +-- , testProperty "GADT Ordering Int Int generic show" (prop_genericShow :: Int -> GADT Ordering Int Int -> Bool) +-- , testProperty "GADT Int Int Int generic show" (prop_genericShow :: Int -> GADT Int Int Int -> Bool) + , testProperty "LeftAssocTree Int generic show" (prop_genericShow :: Int -> LeftAssocTree Int -> Bool) + , testProperty "RightAssocTree Int generic show" (prop_genericShow :: Int -> RightAssocTree Int -> Bool) + , testProperty "Int :?: Int generic show" (prop_genericShow :: Int -> Int :?: Int -> Bool) + , testProperty "HigherKindedTypeParams Maybe Int generic show" (prop_genericShow :: Int -> HigherKindedTypeParams Maybe Int -> Bool) + , testProperty "RestrictedContext Int generic show" (prop_genericShow :: Int -> RestrictedContext Int -> Bool) + , testProperty "Fix Maybe generic show" (prop_genericShow :: Int -> Fix Maybe -> Bool) +#if MIN_VERSION_template_haskell(2,7,0) && __GLASGOW_HASKELL__ >= 706 + , testProperty "AllShow () () Int Int generic show" (prop_matchesShow :: Int -> AllShow () () Int Int -> Bool) + , testProperty "AllShow Int Int Int Int generic show" (prop_matchesShow :: Int -> AllShow Int Int Int Int -> Bool) + , testProperty "AllShow Bool Bool Int Int generic show" (prop_matchesShow :: Int -> AllShow Bool Bool Int Int -> Bool) + , testProperty "AllShow Char Double Int Int generic show" (prop_matchesShow :: Int -> AllShow Char Double Int Int -> Bool) + , testProperty "AllShow Float Ordering Int Int generic show" (prop_matchesShow :: Int -> AllShow Float Ordering Int Int -> Bool) + , testProperty "NotAllShow Int Int Int Int generic show" (prop_genericShow :: Int -> NotAllShow Int Int Int Int -> Bool) + , testProperty "OneDataInstance Int Int Int Int generic show" (prop_genericShow :: Int -> OneDataInstance Int Int Int Int -> Bool) + , testProperty "AssocData1 () generic show" (prop_genericShow :: Int -> AssocData1 () -> Bool) + , testProperty "AssocData2 () generic show" (prop_genericShow :: Int -> AssocData2 () Int Int -> Bool) +# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 + , testProperty "NullaryData generic show" (prop_genericShow :: Int -> NullaryData -> Bool) +# endif +#endif ] ] diff --git a/tests/Properties/MkShow.hs b/tests/Properties/MkShow.hs --- a/tests/Properties/MkShow.hs +++ b/tests/Properties/MkShow.hs @@ -12,55 +12,60 @@ Stability: Experimental Portability: GHC -@QuickCheck@ properties for 'mkShow' and related functions in "Text.Show.Text.TH". +@QuickCheck@ properties for 'mkShowbPrec' in "Text.Show.Text.TH". -} module Properties.MkShow (mkShowTests) where -import qualified Data.Text as TS (pack) -import qualified Data.Text.Lazy as TL (pack) -import Data.Text.Lazy.Builder (fromString) - -import Derived +import Derived (AllAtOnce) +#if MIN_VERSION_template_haskell(2,7,0) +import Derived (NotAllShow(..), OneDataInstance) +#endif import Instances.Derived () -import Test.Tasty.QuickCheck (NonZero) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.QuickCheck (Arbitrary, testProperty) -import Text.Show.Text.TH +import qualified Text.Show as S (Show) +import Text.Show.Text (Builder, FromStringShow(..), showbPrec) +import Text.Show.Text.TH (mkShowbPrec) --- | Verifies 'mkShow' (and related functions) produce the same output as their --- 'String' counterparts. This uses a data type that is a 'Show' instance. -prop_mkShowIsInstance :: Int -> AllAtOnce Int Int Int Int -> Bool -prop_mkShowIsInstance p a = - TS.pack (show a ) == $(mkShow ''AllAtOnce) a - && TL.pack (show a ) == $(mkShowLazy ''AllAtOnce) a - && TS.pack (showsPrec p a "") == $(mkShowPrec ''AllAtOnce) p a - && TL.pack (showsPrec p a "") == $(mkShowPrecLazy ''AllAtOnce) p a - && fromString (show a ) == $(mkShowb ''AllAtOnce) a - && fromString (showsPrec p a "") == $(mkShowbPrec ''AllAtOnce) p a +-- | Verifies 'mkShowbPrec' produces the same output as 'showsPrec' does. +prop_mkShowbPrec :: (Arbitrary a, S.Show a) + => (Int -> a -> Builder) -- ^ TH-generated 'mkShowbPrec' function + -> Int -> a -> Bool +prop_mkShowbPrec sf p x = showbPrec p (FromStringShow x) == sf p x --- | Verifies 'mkShow' (and related functions) produce the same output as their --- 'String' counterparts. This uses a data type that is not a 'Show' instance. -prop_mkShowIsNotInstance :: Int -> NonZero Int -> Bool -prop_mkShowIsNotInstance p a = - TS.pack (show a ) == $(mkShow ''NonZero) a - && TL.pack (show a ) == $(mkShowLazy ''NonZero) a - && TS.pack (showsPrec p a "") == $(mkShowPrec ''NonZero) p a - && TL.pack (showsPrec p a "") == $(mkShowPrecLazy ''NonZero) p a - && fromString (show a ) == $(mkShowb ''NonZero) a - && fromString (showsPrec p a "") == $(mkShowbPrec ''NonZero) p a +-- | Verifies 'mkShowbPrec' produces the same output as 'showsPrec' does. +-- This uses a plain type constructor. +prop_mkShowbPrecTyCon :: Int -> AllAtOnce Int Int Int Int -> Bool +prop_mkShowbPrecTyCon = prop_mkShowbPrec $(mkShowbPrec ''AllAtOnce) --- prop_mkPrintIsInstance --- prop_mkPrintIsNotInstance +#if MIN_VERSION_template_haskell(2,7,0) +-- | Verifies 'mkShowbPrec' produces the same output as 'showsPrec' does. +-- This uses a data family name. +prop_mkShowbPrecDataFam :: Int -> OneDataInstance Int Int Int Int -> Bool +prop_mkShowbPrecDataFam = prop_mkShowbPrec $(mkShowbPrec ''OneDataInstance) +-- | Verifies 'mkShowbPrec' produces the same output as 'showsPrec' does. +-- This uses a data family instance constructor. +prop_mkShowbPrecDataFamInstCon :: Int -> NotAllShow Int Int Int Int -> Bool +prop_mkShowbPrecDataFamInstCon = prop_mkShowbPrec $(mkShowbPrec 'NASShow1) +#endif + +-- prop_mkPrint +-- prop_trace + mkShowTests :: [TestTree] mkShowTests = [ testGroup "mkShow and related functions" - [ testProperty "$(mkShow ''AllAtOnce) (a Show instance)" prop_mkShowIsInstance - , testProperty "$(mkShow ''NonZero) (not a Show instance)" prop_mkShowIsNotInstance --- , testProperty "$(mkPrint ''AllAtOnce) (a Show instance)" prop_mkPrintIsInstance --- , testProperty "$(mkPrint ''NonZero) (not a Show instance)" prop_mkPrintIsNotInstance + [ testProperty "$(mkShowbPrec ''AllAtOnce) (a plain type constructor)" prop_mkShowbPrecTyCon +-- , testProperty "$(mkPrint ''AllAtOnce) (a plain type constructor)" prop_mkPrintTyCon +#if MIN_VERSION_template_haskell(2,7,0) + , testProperty "$(mkShowbPrec ''NotAllShow) (a data family instance constructor)" prop_mkShowbPrecDataFamInstCon +-- , testProperty "$(mkPrint ''NotAllShow) (a data family instance constructor)" prop_mkShowDataFamInstCon + , testProperty "$(mkShowbPrec ''OneDataInstance) (a data family name)" prop_mkShowbPrecDataFam +-- , testProperty "$(mkPrint ''OneDataInstance) (a data family name)" prop_mkPrintDataFam +#endif ] ] diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs --- a/tests/Properties/Utils.hs +++ b/tests/Properties/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-| Module: Properties.Utils Copyright: (C) 2014-2015 Ryan Scott @@ -8,17 +9,36 @@ @QuickCheck@ property-related utility functions. -} -module Properties.Utils (prop_matchesShow) where +module Properties.Utils (prop_matchesShow, prop_genericShow) where -import Prelude hiding (Show) +import GHC.Generics (Generic, Rep) +import Prelude hiding (Show(..)) + import Test.Tasty.QuickCheck (Arbitrary) import qualified Text.Show as S (Show) import qualified Text.Show.Text as T (Show) -import Text.Show.Text (showbPrec, FromStringShow(..)) +import Text.Show.Text hiding (Show) +import Text.Show.Text.Generic -- | Verifies that a type's @Show@ instances coincide for both 'String's and 'Text', -- irrespective of precedence. prop_matchesShow :: (S.Show a, T.Show a, Arbitrary a) => Int -> a -> Bool prop_matchesShow p x = showbPrec p (FromStringShow x) == showbPrec p x + +-- | Verifies that a type's @Show@ instance coincides with the output produced +-- by the equivalent 'Generic' functions. +-- TODO: Add other generic functions +-- TODO: Put in tuples +prop_genericShow :: (S.Show a, T.Show a, Arbitrary a, Generic a, GShow (Rep a)) + => Int -> a -> Bool +prop_genericShow p x = show x == genericShow x + && showLazy x == genericShowLazy x + && showPrec p x == genericShowPrec p x + && showPrecLazy p x == genericShowPrecLazy p x + && showList [x] == genericShowList [x] + && showListLazy [x] == genericShowListLazy [x] + && showb x == genericShowb x + && showbPrec p x == genericShowbPrec p x + && showbList [x] == genericShowbList [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: 0.5 +version: 0.6 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 @@ -39,6 +39,10 @@ depending on the precedence end with @Prec@ (e.g., @showbIntPrec@), whereas functions that show the same values regardless of precedence do not end with @Prec@ (e.g., @showbBool@). + . + Support for automatically deriving @Show@ instances can be found + in the "Text.Show.Text.TH" and "Text.Show.Text.Generic" modules. + If you don't know which one to use, use @Text.Show.Text.TH@. homepage: https://github.com/RyanGlScott/text-show bug-reports: https://github.com/RyanGlScott/text-show/issues license: BSD3 @@ -56,19 +60,6 @@ type: git location: git://github.com/RyanGlScott/text-show.git -flag integer-gmp2 - description: Use @integer-gmp2@. - default: True - -flag recent-text - description: Use a recent version of @text@ that fixes a bug related to - converting large @Integer@s to a @Builder@. - default: True - -flag transformers-four - description: Use a recent version of @transformers@. - default: True - library exposed-modules: Text.Show.Text Text.Show.Text.Debug.Trace @@ -127,23 +118,21 @@ -- , containers >= 0.1 && < 0.6 , bytestring  >= 0.9 && < 0.11 , ghc-prim + , semigroups >= 0.16.1 && < 1 + , text >= 0.8 && < 1.3 , template-haskell >= 2.4 && < 2.11 hs-source-dirs: src ghc-options: -Wall include-dirs: include includes: inline.h + , utils.h install-includes: inline.h - - if flag(recent-text) - cpp-options: -DRECENT_TEXT - build-depends: text >= 1.2.0.2 && < 1.3 - else - build-depends: integer-gmp >= 0.2 - , text >= 0.2 && < 1.2.0.2 - ghc-options: -fobject-code + , utils.h if impl(ghc >= 7.2) - exposed-modules: Text.Show.Text.GHC.Fingerprint + exposed-modules: Text.Show.Text.Debug.Trace.Generic + Text.Show.Text.Generic + Text.Show.Text.GHC.Fingerprint Text.Show.Text.GHC.Generics if !os(windows) exposed-modules: Text.Show.Text.GHC.Event @@ -166,16 +155,10 @@ if impl(ghc < 7.9) build-depends: nats >= 0.1 && < 2 + , transformers >= 0.2.1 && < 0.5 , void >= 0.5 && < 1 - - if flag(transformers-four) - build-depends: transformers >= 0.4 && < 0.5 - else - build-depends: transformers >= 0.2.1 && < 0.4 - , transformers-compat >= 0.3 && < 1 else - if flag(integer-gmp2) - build-depends: integer-gmp >= 1.0 && < 1.1 + build-depends: integer-gmp >= 1.0 && < 1.1 if impl(ghc >= 7.10) exposed-modules: Text.Show.Text.GHC.RTS.Flags @@ -190,6 +173,7 @@ other-modules: Derived Instances.BaseAndFriends Instances.Derived + Instances.Utils Properties.BaseAndFriends Properties.Builder Properties.Derived @@ -202,10 +186,15 @@ , tasty >= 0.8 && < 0.11 , tasty-hunit >= 0.8 && < 0.10 , tasty-quickcheck >= 0.8 && < 0.9 - , text >= 0.2 && < 1.3 - , text-show == 0.5 + , text >= 0.8 && < 1.3 + , text-show == 0.6 hs-source-dirs: tests ghc-options: -Wall + include-dirs: include + includes: overlap.h + , utils.h + install-includes: overlap.h + , utils.h -- Prior to GHC 7.6, GHC generics lived in ghc-prim if impl(ghc >= 7.2) && impl(ghc < 7.6) @@ -216,10 +205,6 @@ if impl(ghc < 7.9) build-depends: nats >= 0.1 && < 2 - , void >= 0.5 && < 1 - - if flag(transformers-four) - build-depends: transformers >= 0.4 && < 0.5 - else - build-depends: transformers >= 0.2.1 && < 0.4 + , transformers >= 0.2.1 && < 0.5 , transformers-compat >= 0.3 && < 1 + , void >= 0.5 && < 1