diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +## 3.4 +* The default definitions of `showt` and `showtl` were changed to `showtPrec 0` and `showtlPrec 0`, respectively +* `deriveTextShowOptions`, `deriveTextShow1Options`, and `deriveTextShow2Options` added to `TextShow.TH`, which allow further configuration of how `TextShow(1)(2)` instances should be derived using the new `Options` data type. `Options` itself contains `GenTextMethods`, which configures whether manual implementations of `TextShow` should implement the methods that return strict and lazy `Text`. + * The `defaultOptions` uses `SometimesTextMethods`, which only implements the `Text`-returning methods if the datatype contains only nullary constructors (i.e., it is an enumeration type). For example, `deriveTextShow = deriveTextShowOptions defaultOptions`. One can also choose `AlwaysTextMethods` or `NeverTextMethods` instead. +* The internals of `TextShow.Generic` were refactored so that is possible to generically derive `showbPrec`, `showtPrec`, and `showtlPrec` (which use `Builder`, strict `Text`, and lazy `Text`, respectively). Before, only generic derivation of `showbPrec` was possible, and all other generic functions were defined in terms of `showbPrec`. + * The internal class `GTextShow` was split up into `GShowB`, `GShowT`, and `GShowTL`, depending on what type it returns. + * As a result, functions like `genericShowtPrec` might be faster than before if they are showing something like an enumeration type, since they no longer construct an intermediate `Builder`. On the other hand, they might be slower if they are showing a constructor with many fields, since they will now be appending lots of `Text`s. If so, make sure to switch to `genericShowbPrec` and convert the final `Builder` to `Text` instead. +* Added `showtParen`, `showtSpace`, `showtlParen`, `showtlSpace`, `liftShowtPrec`, `liftShowtPrec2`, `liftShowtlPrec`, and `liftShowtlPrec2` to `TextShow` +* Added `showtPrecToShowbPrec`, `showtlPrecToShowbPrec`, `showtToShowb`, `showtlToShowb`, `showbPrecToShowtPrec`, `showbPrecToShowtlPrec`, `showbToShowt`, and `showbToShowtl` to `TextShow` +* Added `showtListWith` and `showtlListWith` to `TextShow.Data.List` +* Added `Data` instance for `ConType` in `TextShow.Generic` +* Require `generic-deriving-1.11` or later + ## 3.3 * Refactored the internals of `TextShow.Generic` to avoid the use of proxies. * Made benchmark suite more comprehensive, including benchmarks for showing an enumeration type diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs --- a/benchmarks/Bench.hs +++ b/benchmarks/Bench.hs @@ -24,7 +24,7 @@ import GHC.Generics (Generic) import TextShow (TextShow(..)) -import TextShow.Generic (genericShowbPrec) +import TextShow.Generic (genericShowbPrec, genericShowtPrec, genericShowtlPrec) import TextShow.TH (deriveTextShow) main :: IO () @@ -114,7 +114,9 @@ newtype Color2 = Color2 Color instance TextShow Color2 where - showbPrec p (Color2 c) = genericShowbPrec p c + showbPrec p (Color2 c) = genericShowbPrec p c + showtPrec p (Color2 c) = genericShowtPrec p c + showtlPrec p (Color2 c) = genericShowtlPrec p c colorShowt :: Color -> T.Text colorShowt c = case c of diff --git a/src/TextShow.hs b/src/TextShow.hs --- a/src/TextShow.hs +++ b/src/TextShow.hs @@ -15,15 +15,23 @@ -- ** 'TextShow' TextShow(..) , showbParen + , showtParen + , showtlParen , showbSpace + , showtSpace + , showtlSpace -- ** 'TextShow1' , TextShow1(..) , showbPrec1 , showbUnaryWith + , liftShowtPrec + , liftShowtlPrec -- ** 'TextShow2' , TextShow2(..) , showbPrec2 , showbBinaryWith + , liftShowtPrec2 + , liftShowtlPrec2 -- * 'Builder's -- ** The 'Builder' type , Builder @@ -47,7 +55,8 @@ , printTL , hPrintT , hPrintTL - -- * Conversion between 'TextShow' and string @Show@ + -- * Conversions + -- ** Conversion between 'TextShow' and string 'Show' , FromStringShow(..) , FromTextShow(..) , FromStringShow1(..) @@ -58,13 +67,24 @@ , showsToShowb , showbPrecToShowsPrec , showbToShows + -- ** Conversions between 'Builder', strict 'TS.Text', and lazy 'TL.Text' + , showtPrecToShowbPrec + , showtlPrecToShowbPrec + , showtToShowb + , showtlToShowb + , showbPrecToShowtPrec + , showbPrecToShowtlPrec + , showbToShowt + , showbToShowtl ) where -import Data.Text.Lazy.Builder +import qualified Data.Text as TS () +import qualified Data.Text.Lazy as TL () +import Data.Text.Lazy.Builder -import Prelude () +import Prelude () -import TextShow.Classes -import TextShow.FromStringTextShow -import TextShow.Instances () -import TextShow.Utils (toString, toText, lengthB, unlinesB, unwordsB) +import TextShow.Classes +import TextShow.FromStringTextShow +import TextShow.Instances () +import TextShow.Utils (toString, toText, lengthB, unlinesB, unwordsB) diff --git a/src/TextShow/Classes.hs b/src/TextShow/Classes.hs --- a/src/TextShow/Classes.hs +++ b/src/TextShow/Classes.hs @@ -21,18 +21,19 @@ import Data.Data (Typeable) #endif import Data.Monoid.Compat ((<>)) -import Data.Text as TS (Text) +import qualified Data.Text as TS (Text, singleton) import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) -import qualified Data.Text.Lazy as TL (Text) +import qualified Data.Text.Lazy as TL (Text, singleton) import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText) +import Data.Text.Lazy.Builder (Builder, fromLazyText, fromString, + fromText, singleton, toLazyText) import GHC.Show (appPrec, appPrec1) import System.IO (Handle) -import TextShow.Utils (toString) +import TextShow.Utils (toString, toText) ------------------------------------------------------------------------------- @@ -108,13 +109,16 @@ -- efficiency, but it should satisfy: -- -- @ + -- 'showt' = 'showtPrec' 0 -- 'showt' = 'toStrict' . 'showtl' -- @ -- + -- The first equation is the default definition of 'showt'. + -- -- /Since: 3/ showt :: a -- ^ The value to be converted to a strict 'TS.Text'. -> TS.Text - showt = toStrict . showtl + showt = showtPrec 0 -- | Converts a list of values to a strict 'TS.Text'. This can be overridden for -- efficiency, but it should satisfy: @@ -146,13 +150,16 @@ -- efficiency, but it should satisfy: -- -- @ + -- 'showtl' = 'showtlPrec' 0 -- 'showtl' = 'toLazyText' . 'showb' -- @ -- + -- The first equation is the default definition of 'showtl'. + -- -- /Since: 3/ showtl :: a -- ^ The value to be converted to a lazy 'TL.Text'. -> TL.Text - showtl = toLazyText . showb + showtl = showtlPrec 0 -- | Converts a list of values to a lazy 'TL.Text'. This can be overridden for -- efficiency, but it should satisfy: @@ -178,7 +185,6 @@ showbParen :: Bool -> Builder -> Builder showbParen p builder | p = singleton '(' <> builder <> singleton ')' | otherwise = builder -{-# INLINE showbParen #-} -- | Construct a 'Builder' containing a single space character. -- @@ -189,7 +195,7 @@ -- | Converts a list of values into a 'Builder' in which the values are surrounded -- by square brackets and each value is separated by a comma. The function argument -- controls how each element is shown. - +-- -- @'showbListWith' 'showb'@ is the default implementation of 'showbList' save for -- a few special cases (e.g., 'String'). -- @@ -200,8 +206,58 @@ where go (y:ys) = singleton ',' <> showbx y <> go ys -- ..,.. go [] = singleton ']' -- ..]" -{-# INLINE showbListWith #-} +-- | Surrounds strict 'TS.Text' output with parentheses if the 'Bool' parameter is 'True'. +-- +-- /Since: 3.4/ +showtParen :: Bool -> TS.Text -> TS.Text +showtParen p t | p = TS.singleton '(' <> t <> TS.singleton ')' + | otherwise = t + +-- | Construct a strict 'TS.Text' containing a single space character. +-- +-- /Since: 3.4/ +showtSpace :: TS.Text +showtSpace = TS.singleton ' ' + +-- | Converts a list of values into a strict 'TS.Text' in which the values are surrounded +-- by square brackets and each value is separated by a comma. The function argument +-- controls how each element is shown. +-- +-- /Since: 3.4/ +showtListWith :: (a -> TS.Text) -> [a] -> TS.Text +showtListWith _ [] = "[]" +showtListWith showtx (x:xs) = TS.singleton '[' <> showtx x <> go xs -- "[.. + where + go (y:ys) = TS.singleton ',' <> showtx y <> go ys -- ..,.. + go [] = TS.singleton ']' -- ..]" + +-- | Surrounds lazy 'TL.Text' output with parentheses if the 'Bool' parameter is 'True'. +-- +-- /Since: 3.4/ +showtlParen :: Bool -> TL.Text -> TL.Text +showtlParen p t | p = TL.singleton '(' <> t <> TL.singleton ')' + | otherwise = t +{-# INLINE showtlParen #-} + +-- | Construct a lazy 'TL.Text' containing a single space character. +-- +-- /Since: 3.4/ +showtlSpace :: TL.Text +showtlSpace = TL.singleton ' ' + +-- | Converts a list of values into a lazy 'TL.Text' in which the values are surrounded +-- by square brackets and each value is separated by a comma. The function argument +-- controls how each element is shown. +-- +-- /Since: 3.4/ +showtlListWith :: (a -> TL.Text) -> [a] -> TL.Text +showtlListWith _ [] = "[]" +showtlListWith showtlx (x:xs) = TL.singleton '[' <> showtlx x <> go xs -- "[.. + where + go (y:ys) = TL.singleton ',' <> showtlx y <> go ys -- ..,.. + go [] = TL.singleton ']' -- ..]" + -- | Writes a value's strict 'TS.Text' representation to the standard output, followed -- by a newline. -- @@ -234,34 +290,90 @@ hPrintTL h = TL.hPutStrLn h . showtl {-# INLINE hPrintTL #-} --- | Convert a precedence-aware @ShowS@-based show function to a @Builder@-based one. +-- | Convert a precedence-aware 'ShowS'-based show function to a 'Builder'-based one. -- -- /Since: 3/ showsPrecToShowbPrec :: (Int -> a -> ShowS) -> Int -> a -> Builder showsPrecToShowbPrec sp p x = fromString $ sp p x "" {-# INLINE showsPrecToShowbPrec #-} --- | Convert a @ShowS@-based show function to a @Builder@-based one. +-- | Convert a precedence-aware, strict 'TS.Text'-based show function to a 'Builder'-based one. -- +-- /Since: 3.4/ +showtPrecToShowbPrec :: (Int -> a -> TS.Text) -> Int -> a -> Builder +showtPrecToShowbPrec sp p = fromText . sp p +{-# INLINE showtPrecToShowbPrec #-} + +-- | Convert a precedence-aware, lazy 'TL.Text'-based show function to a 'Builder'-based one. +-- +-- /Since: 3.4/ +showtlPrecToShowbPrec :: (Int -> a -> TL.Text) -> Int -> a -> Builder +showtlPrecToShowbPrec sp p = fromLazyText . sp p +{-# INLINE showtlPrecToShowbPrec #-} + +-- | Convert a 'ShowS'-based show function to a 'Builder'-based one. +-- -- /Since: 3/ showsToShowb :: (a -> ShowS) -> a -> Builder showsToShowb sf x = fromString $ sf x "" {-# INLINE showsToShowb #-} --- | Convert a precedence-aware @Builder@-based show function to a @ShowS@-based one. +-- | Convert a strict 'TS.Text'-based show function to a 'Builder'-based one. -- +-- /Since: 3.4/ +showtToShowb :: (a -> TS.Text) -> a -> Builder +showtToShowb sf = fromText . sf +{-# INLINE showtToShowb #-} + +-- | Convert a lazy 'TL.Text'-based show function to a 'Builder'-based one. +-- +-- /Since: 3.4/ +showtlToShowb :: (a -> TL.Text) -> a -> Builder +showtlToShowb sf = fromLazyText . sf +{-# INLINE showtlToShowb #-} + +-- | Convert a precedence-aware 'Builder'-based show function to a 'ShowS'-based one. +-- -- /Since: 3/ showbPrecToShowsPrec :: (Int -> a -> Builder) -> Int -> a -> ShowS showbPrecToShowsPrec sp p = showString . toString . sp p {-# INLINE showbPrecToShowsPrec #-} --- | Convert a @Builder@-based show function to a @ShowS@-based one. +-- | Convert a precedence-aware 'Builder'-based show function to a strict 'TS.Text'-based one. -- +-- /Since: 3.4/ +showbPrecToShowtPrec :: (Int -> a -> Builder) -> Int -> a -> TS.Text +showbPrecToShowtPrec sp p = toText . sp p +{-# INLINE showbPrecToShowtPrec #-} + +-- | Convert a precedence-aware 'Builder'-based show function to a lazy 'TL.Text'-based one. +-- +-- /Since: 3.4/ +showbPrecToShowtlPrec :: (Int -> a -> Builder) -> Int -> a -> TL.Text +showbPrecToShowtlPrec sp p = toLazyText . sp p +{-# INLINE showbPrecToShowtlPrec #-} + +-- | Convert a 'Builder'-based show function to a 'ShowS'-based one. +-- -- /Since: 3/ showbToShows :: (a -> Builder) -> a -> ShowS -showbToShows sl = showString . toString . sl +showbToShows sf = showString . toString . sf {-# INLINE showbToShows #-} +-- | Convert a 'Builder'-based show function to a strict 'TS.Text'-based one. +-- +-- /Since: 3/ +showbToShowt :: (a -> Builder) -> a -> TS.Text +showbToShowt sf = toText . sf +{-# INLINE showbToShowt #-} + +-- | Convert a 'Builder'-based show function to a lazy 'TL.Text'-based one. +-- +-- /Since: 3/ +showbToShowtl :: (a -> Builder) -> a -> TL.Text +showbToShowtl sf = toLazyText . sf +{-# INLINE showbToShowtl #-} + ------------------------------------------------------------------------------- -- | Lifting of the 'TextShow' class to unary type constructors. @@ -309,6 +421,26 @@ nameB <> showbSpace <> sp appPrec1 x {-# INLINE showbUnaryWith #-} +-- | 'showtPrec' function for an application of the type constructor +-- based on 'showtPrec' and 'showtList' functions for the argument type. +-- +-- The current implementation is based on `liftShowbPrec` internally. +-- +-- /Since: 3.4/ +liftShowtPrec :: TextShow1 f => (Int -> a -> TS.Text) -> ([a] -> TS.Text) + -> Int -> f a -> TS.Text +liftShowtPrec sp sl = showbPrecToShowtPrec $ liftShowbPrec (showtPrecToShowbPrec sp) (showtToShowb sl) + +-- | 'showtlPrec' function for an application of the type constructor +-- based on 'showtlPrec' and 'showtlList' functions for the argument type. +-- +-- The current implementation is based on `liftShowbPrec` internally. +-- +-- /Since: 3.4/ +liftShowtlPrec :: TextShow1 f => (Int -> a -> TL.Text) -> ([a] -> TL.Text) + -> Int -> f a -> TL.Text +liftShowtlPrec sp sl = showbPrecToShowtlPrec $ liftShowbPrec (showtlPrecToShowbPrec sp) (showtlToShowb sl) + ------------------------------------------------------------------------------- -- | Lifting of the 'TextShow' class to binary type constructors. @@ -359,3 +491,31 @@ <> showbSpace <> sp1 appPrec1 x <> showbSpace <> sp2 appPrec1 y {-# INLINE showbBinaryWith #-} + +-- | 'showtPrec' function for an application of the type constructor +-- based on 'showtPrec' and 'showtList' functions for the argument type. +-- +-- The current implementation is based on `liftShowbPrec2` internally. +-- +-- /Since: 3.4/ +liftShowtPrec2 :: TextShow2 f + => (Int -> a -> TS.Text) -> ([a] -> TS.Text) + -> (Int -> b -> TS.Text) -> ([b] -> TS.Text) + -> Int -> f a b -> TS.Text +liftShowtPrec2 sp1 sl1 sp2 sl2 = showbPrecToShowtPrec $ + liftShowbPrec2 (showtPrecToShowbPrec sp1) (showtToShowb sl1) + (showtPrecToShowbPrec sp2) (showtToShowb sl2) + +-- | 'showtlPrec' function for an application of the type constructor +-- based on 'showtlPrec' and 'showtlList' functions for the argument type. +-- +-- The current implementation is based on `liftShowbPrec2` internally. +-- +-- /Since: 3.4/ +liftShowtlPrec2 :: TextShow2 f + => (Int -> a -> TL.Text) -> ([a] -> TL.Text) + -> (Int -> b -> TL.Text) -> ([b] -> TL.Text) + -> Int -> f a b -> TL.Text +liftShowtlPrec2 sp1 sl1 sp2 sl2 = showbPrecToShowtlPrec $ + liftShowbPrec2 (showtlPrecToShowbPrec sp1) (showtlToShowb sl1) + (showtlPrecToShowbPrec sp2) (showtlToShowb sl2) diff --git a/src/TextShow/Data/Floating.hs b/src/TextShow/Data/Floating.hs --- a/src/TextShow/Data/Floating.hs +++ b/src/TextShow/Data/Floating.hs @@ -159,7 +159,7 @@ -> Bool -- ^ Should a decimal point always be shown? -> a -> Builder -{-# SPECIALIZE formatRealFloatAltB :: FPFormat -> Maybe Int -> Bool -> Float -> Builder #-} +{-# SPECIALIZE formatRealFloatAltB :: FPFormat -> Maybe Int -> Bool -> Float -> Builder #-} {-# SPECIALIZE formatRealFloatAltB :: FPFormat -> Maybe Int -> Bool -> Double -> Builder #-} formatRealFloatAltB fmt decs alt x | isNaN x = "NaN" diff --git a/src/TextShow/Data/Integral.hs b/src/TextShow/Data/Integral.hs --- a/src/TextShow/Data/Integral.hs +++ b/src/TextShow/Data/Integral.hs @@ -124,6 +124,17 @@ -- -- /Since: 2/ showbIntAtBase :: (Integral a, TextShow a) => a -> (Int -> Char) -> a -> Builder +{-# SPECIALIZE showbIntAtBase :: Int -> (Int -> Char) -> Int -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Int8 -> (Int -> Char) -> Int8 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Int16 -> (Int -> Char) -> Int16 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Int32 -> (Int -> Char) -> Int32 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Int64 -> (Int -> Char) -> Int64 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Integer -> (Int -> Char) -> Integer -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Word -> (Int -> Char) -> Word -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Word8 -> (Int -> Char) -> Word8 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Word16 -> (Int -> Char) -> Word16 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Word32 -> (Int -> Char) -> Word32 -> Builder #-} +{-# SPECIALIZE showbIntAtBase :: Word64 -> (Int -> Char) -> Word64 -> Builder #-} showbIntAtBase base toChr n0 | base <= 1 = error . toString $ "TextShow.Int.showbIntAtBase: applied to unsupported base" <> showb base | n0 < 0 = error . toString $ "TextShow.Int.showbIntAtBase: applied to negative number " <> showb n0 diff --git a/src/TextShow/Data/List.hs b/src/TextShow/Data/List.hs --- a/src/TextShow/Data/List.hs +++ b/src/TextShow/Data/List.hs @@ -8,11 +8,11 @@ Stability: Provisional Portability: GHC -Exports 'showbListWith'. +Exports 'showbListWith', 'showtListWith', and 'showtlListWith'. -} -module TextShow.Data.List (showbListWith) where +module TextShow.Data.List (showbListWith, showtListWith, showtlListWith) where -import TextShow.Classes (TextShow(..), TextShow1(..), showbListWith) +import TextShow.Classes (TextShow(..), TextShow1(..), showbListWith, showtListWith, showtlListWith) import TextShow.Data.Char () import TextShow.Data.Integral () diff --git a/src/TextShow/Data/Proxy.hs b/src/TextShow/Data/Proxy.hs --- a/src/TextShow/Data/Proxy.hs +++ b/src/TextShow/Data/Proxy.hs @@ -26,7 +26,8 @@ import Data.Text.Lazy.Builder (Builder) import TextShow.Classes (TextShow(..)) -import TextShow.TH.Internal (deriveTextShow1, makeShowbPrec) +import TextShow.TH.Internal (deriveTextShow1, makeShowbPrec, + makeShowtPrec, makeShowtlPrec) #include "inline.h" @@ -38,7 +39,11 @@ {-# INLINE showbProxy #-} instance TextShow (Proxy s) where - showbPrec = $(makeShowbPrec ''Proxy) + showbPrec = $(makeShowbPrec ''Proxy) + showtPrec = $(makeShowtPrec ''Proxy) + showtlPrec = $(makeShowtlPrec ''Proxy) INLINE_INST_FUN(showbPrec) + INLINE_INST_FUN(showtPrec) + INLINE_INST_FUN(showtlPrec) $(deriveTextShow1 ''Proxy) diff --git a/src/TextShow/Data/Tuple.hs b/src/TextShow/Data/Tuple.hs --- a/src/TextShow/Data/Tuple.hs +++ b/src/TextShow/Data/Tuple.hs @@ -42,7 +42,6 @@ -- -- /Since: 2/ showbUnit :: () -> Builder --- showbUnit () = "()" showbUnit = showb -- | Converts a 2-tuple into a 'Builder' with the given show functions. diff --git a/src/TextShow/Debug/Trace/Generic.hs b/src/TextShow/Debug/Trace/Generic.hs --- a/src/TextShow/Debug/Trace/Generic.hs +++ b/src/TextShow/Debug/Trace/Generic.hs @@ -25,22 +25,22 @@ import Prelude.Compat import TextShow.Debug.Trace -import TextShow.Generic (GTextShow, Zero, genericShowt) +import TextShow.Generic (GTextShowT, Zero, genericShowt) -- | A 'Generic' implementation of 'traceTextShow'. -- -- /Since: 2/ -genericTraceTextShow :: (Generic a, GTextShow Zero (Rep a)) => a -> b -> b +genericTraceTextShow :: (Generic a, GTextShowT Zero (Rep a)) => a -> b -> b genericTraceTextShow = tracet . genericShowt -- | A 'Generic' implementation of 'traceTextShowId'. -- -- /Since: 2/ -genericTraceTextShowId :: (Generic a, GTextShow Zero (Rep a)) => a -> a +genericTraceTextShowId :: (Generic a, GTextShowT Zero (Rep a)) => a -> a genericTraceTextShowId a = tracet (genericShowt a) a -- | A 'Generic' implementation of 'traceShowM'. -- -- /Since: 2/ -genericTraceTextShowM :: (Generic a, GTextShow Zero (Rep a), Applicative f) => a -> f () +genericTraceTextShowM :: (Generic a, GTextShowT Zero (Rep a), Applicative f) => a -> f () genericTraceTextShowM = tracetM . genericShowt diff --git a/src/TextShow/FromStringTextShow.hs b/src/TextShow/FromStringTextShow.hs --- a/src/TextShow/FromStringTextShow.hs +++ b/src/TextShow/FromStringTextShow.hs @@ -16,12 +16,12 @@ #endif #if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 800 diff --git a/src/TextShow/Generic.hs b/src/TextShow/Generic.hs --- a/src/TextShow/Generic.hs +++ b/src/TextShow/Generic.hs @@ -20,6 +20,7 @@ #endif #if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif @@ -65,25 +66,35 @@ , genericHPrintTL , genericLiftShowbPrec , genericShowbPrec1 - -- * 'GTextShow' and friends - , GTextShow(..) - , GTextShowCon(..) + -- * Internals + -- ** 'Builder' + , GTextShowB(..) + , GTextShowConB(..) + , ShowFunsB(..) + -- ** Strict 'TS.Text' + , GTextShowT(..) + , GTextShowConT(..) + , ShowFunsT(..) + -- ** Lazy 'TL.Text' + , GTextShowTL(..) + , GTextShowConTL(..) + , ShowFunsTL(..) + -- ** Other internals , IsNullary(..) , ConType(..) - , ShowFuns(..) , Zero , One ) where +import Data.Data (Data, Typeable) import Data.Functor.Contravariant (Contravariant(..)) import Data.Monoid.Compat ((<>)) -import qualified Data.Text as TS (Text) +import qualified Data.Text as TS (Text, pack, singleton) import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText) -import qualified Data.Text.Lazy as TL (Text) +import qualified Data.Text.Lazy as TL (Text, pack, singleton) import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) -import Data.Typeable (Typeable) +import qualified Data.Text.Lazy.Builder as TB (fromString, singleton) +import Data.Text.Lazy.Builder (Builder) import Generics.Deriving.Base #if __GLASGOW_HASKELL__ < 702 @@ -101,8 +112,12 @@ import System.IO (Handle) import TextShow.Classes (TextShow(..), TextShow1(..), - showbListWith, showbParen, showbSpace) + showbListWith, showbParen, showbSpace, + showtListWith, showtParen, showtSpace, + showtlListWith, showtlParen, showtlSpace, + liftShowtPrec, liftShowtlPrec) import TextShow.Instances () +import TextShow.TH.Internal (deriveTextShow) import TextShow.Utils (isInfixTypeCon, isTupleString) #include "inline.h" @@ -145,108 +160,108 @@ compile-time, you might get an error message that begins roughly as follows: @ -No instance for ('GTextShow' 'Zero' (Rep Oops)) +No instance for ('GTextShowB' 'Zero' (Rep Oops)) @ This error can be confusing, but don't let it intimidate you. The correct fix is simply to add the missing \"@deriving 'Generic'@\" clause. -Similarly, if the compiler complains about not having an instance for @('GTextShow' +Similarly, if the compiler complains about not having an instance for @('GTextShowB' 'One' (Rep1 Oops1))@, add a \"@deriving 'Generic1'@\" clause. -} -- | A 'Generic' implementation of 'showt'. -- -- /Since: 2/ -genericShowt :: (Generic a, GTextShow Zero (Rep a)) => a -> TS.Text -genericShowt = toStrict . genericShowtl +genericShowt :: (Generic a, GTextShowT Zero (Rep a)) => a -> TS.Text +genericShowt = genericShowtPrec 0 -- | A 'Generic' implementation of 'showtl'. -- -- /Since: 2/ -genericShowtl :: (Generic a, GTextShow Zero (Rep a)) => a -> TL.Text -genericShowtl = toLazyText . genericShowb +genericShowtl :: (Generic a, GTextShowTL Zero (Rep a)) => a -> TL.Text +genericShowtl = genericShowtlPrec 0 -- | A 'Generic' implementation of 'showPrect'. -- -- /Since: 2/ -genericShowtPrec :: (Generic a, GTextShow Zero (Rep a)) => Int -> a -> TS.Text -genericShowtPrec p = toStrict . genericShowtlPrec p +genericShowtPrec :: (Generic a, GTextShowT Zero (Rep a)) => Int -> a -> TS.Text +genericShowtPrec p = gShowtPrec NoShowFunsT p . from -- | A 'Generic' implementation of 'showtlPrec'. -- -- /Since: 2/ -genericShowtlPrec :: (Generic a, GTextShow Zero (Rep a)) => Int -> a -> TL.Text -genericShowtlPrec p = toLazyText . genericShowbPrec p +genericShowtlPrec :: (Generic a, GTextShowTL Zero (Rep a)) => Int -> a -> TL.Text +genericShowtlPrec p = gShowtlPrec NoShowFunsTL p . from -- | A 'Generic' implementation of 'showtList'. -- -- /Since: 2/ -genericShowtList :: (Generic a, GTextShow Zero (Rep a)) => [a] -> TS.Text -genericShowtList = toStrict . genericShowtlList +genericShowtList :: (Generic a, GTextShowT Zero (Rep a)) => [a] -> TS.Text +genericShowtList = showtListWith genericShowt -- | A 'Generic' implementation of 'showtlList'. -- -- /Since: 2/ -genericShowtlList :: (Generic a, GTextShow Zero (Rep a)) => [a] -> TL.Text -genericShowtlList = toLazyText . genericShowbList +genericShowtlList :: (Generic a, GTextShowTL Zero (Rep a)) => [a] -> TL.Text +genericShowtlList = showtlListWith genericShowtl -- | A 'Generic' implementation of 'showb'. -- -- /Since: 2/ -genericShowb :: (Generic a, GTextShow Zero (Rep a)) => a -> Builder +genericShowb :: (Generic a, GTextShowB Zero (Rep a)) => a -> Builder genericShowb = genericShowbPrec 0 -- | A 'Generic' implementation of 'showbPrec'. -- -- /Since: 2/ -genericShowbPrec :: (Generic a, GTextShow Zero (Rep a)) => Int -> a -> Builder -genericShowbPrec p = gShowbPrec NoShowFuns p . from +genericShowbPrec :: (Generic a, GTextShowB Zero (Rep a)) => Int -> a -> Builder +genericShowbPrec p = gShowbPrec NoShowFunsB p . from -- | A 'Generic' implementation of 'showbList'. -- -- /Since: 2/ -genericShowbList :: (Generic a, GTextShow Zero (Rep a)) => [a] -> Builder +genericShowbList :: (Generic a, GTextShowB Zero (Rep a)) => [a] -> Builder genericShowbList = showbListWith genericShowb -- | A 'Generic' implementation of 'printT'. -- -- /Since: 2/ -genericPrintT :: (Generic a, GTextShow Zero (Rep a)) => a -> IO () +genericPrintT :: (Generic a, GTextShowT Zero (Rep a)) => a -> IO () genericPrintT = TS.putStrLn . genericShowt -- | A 'Generic' implementation of 'printTL'. -- -- /Since: 2/ -genericPrintTL :: (Generic a, GTextShow Zero (Rep a)) => a -> IO () +genericPrintTL :: (Generic a, GTextShowTL Zero (Rep a)) => a -> IO () genericPrintTL = TL.putStrLn . genericShowtl -- | A 'Generic' implementation of 'hPrintT'. -- -- /Since: 2/ -genericHPrintT :: (Generic a, GTextShow Zero (Rep a)) => Handle -> a -> IO () +genericHPrintT :: (Generic a, GTextShowT Zero (Rep a)) => Handle -> a -> IO () genericHPrintT h = TS.hPutStrLn h . genericShowt -- | A 'Generic' implementation of 'hPrintTL'. -- -- /Since: 2/ -genericHPrintTL :: (Generic a, GTextShow Zero (Rep a)) => Handle -> a -> IO () +genericHPrintTL :: (Generic a, GTextShowTL Zero (Rep a)) => Handle -> a -> IO () genericHPrintTL h = TL.hPutStrLn h . genericShowtl -- | A 'Generic1' implementation of 'genericLiftShowbPrec'. -- -- /Since: 2/ -genericLiftShowbPrec :: (Generic1 f, GTextShow One (Rep1 f)) +genericLiftShowbPrec :: (Generic1 f, GTextShowB One (Rep1 f)) => (Int -> a -> Builder) -> ([a] -> Builder) -> Int -> f a -> Builder -genericLiftShowbPrec sp sl p = gShowbPrec (Show1Funs sp sl) p . from1 +genericLiftShowbPrec sp sl p = gShowbPrec (Show1FunsB sp sl) p . from1 -- | A 'Generic'/'Generic1' implementation of 'showbPrec1'. -- -- /Since: 2/ genericShowbPrec1 :: ( Generic a, Generic1 f - , GTextShow Zero (Rep a) - , GTextShow One (Rep1 f) + , GTextShowB Zero (Rep a) + , GTextShowB One (Rep1 f) ) => Int -> f a -> Builder genericShowbPrec1 = genericLiftShowbPrec genericShowbPrec genericShowbList @@ -258,7 +273,8 @@ -- -- /Since: 2/ data ConType = Rec | Tup | Pref | Inf String - deriving ( Eq + deriving ( Data + , Eq , Ord , Read , Show @@ -271,24 +287,6 @@ #endif ) -instance TextShow ConType where - showbPrec = genericShowbPrec - INLINE_INST_FUN(showbPrec) - --- | A 'ShowFuns' value either stores nothing (for 'TextShow') or it stores --- the two function arguments that show occurrences of the type parameter (for --- 'TextShow1'). --- --- /Since: 3.3/ -data ShowFuns arity a where - NoShowFuns :: ShowFuns Zero a - Show1Funs :: (Int -> a -> Builder) -> ([a] -> Builder) -> ShowFuns One a - deriving Typeable - -instance Contravariant (ShowFuns arity) where - contramap _ NoShowFuns = NoShowFuns - contramap f (Show1Funs sp sl) = Show1Funs (\p -> sp p . f) (sl . map f) - -- | A type-level indicator that 'TextShow' is being derived generically. -- -- /Since: 3.2/ @@ -299,161 +297,234 @@ -- /Since: 3.2/ data One --- | Class of generic representation types that can be converted to --- a 'Builder'. The @arity@ type variable indicates which type class is --- used. @'GTextShow' 'Zero'@ indicates 'TextShow' behavior, and --- @'GTextShow' 'One'@ indicates 'TextShow1' behavior. --- --- /Since: 3.2/ -class GTextShow arity f where - -- | This is used as the default generic implementation of 'showbPrec' (if the - -- @arity@ is 'Zero') or 'liftShowbPrec' (if the @arity@ is 'One'). - gShowbPrec :: ShowFuns arity a -> Int -> f a -> Builder - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable GTextShow -#endif - -instance GTextShow arity f => GTextShow arity (D1 d f) where - gShowbPrec sfs p (M1 x) = gShowbPrec sfs p x - -instance GTextShow Zero V1 where - gShowbPrec _ _ !_ = error "Void showbPrec" - -instance GTextShow One V1 where - gShowbPrec _ _ !_ = error "Void liftShowbPrec" - -instance (GTextShow arity f, GTextShow arity g) => GTextShow arity (f :+: g) where - gShowbPrec sfs p (L1 x) = gShowbPrec sfs p x - gShowbPrec sfs p (R1 x) = gShowbPrec sfs p x - -instance (Constructor c, GTextShowCon arity f, IsNullary f) - => GTextShow arity (C1 c f) where - gShowbPrec sfs p c@(M1 x) = case fixity of - Prefix -> showbParen ( p > appPrec - && not (isNullary x || conIsTuple c) - ) $ - (if conIsTuple c - then mempty - else let cn = conName c - in showbParen (isInfixTypeCon cn) $ fromString cn) - <> (if isNullary x || conIsTuple c - then mempty - else singleton ' ') - <> showbBraces t (gShowbPrecCon t sfs appPrec1 x) - Infix _ m -> showbParen (p > m) $ gShowbPrecCon t sfs (m+1) x - where - fixity :: Fixity - fixity = conFixity c - - t :: ConType - t = if conIsRecord c - then Rec - else case conIsTuple c of - True -> Tup - False -> case fixity of - Prefix -> Pref - Infix _ _ -> Inf $ conName c - - showbBraces :: ConType -> Builder -> Builder - showbBraces Rec b = singleton '{' <> b <> singleton '}' - showbBraces Tup b = singleton '(' <> b <> singleton ')' - showbBraces Pref b = b - showbBraces (Inf _) b = b +{- +I'm not particularly proud of the code below. The issue is that we need to be able to +generically work over Builders, strict Text, and lazy Text. We could just work +generically over Builders only and then convert to Text after the fact, but that results +in a drastic slowdown for certain datatypes (see GH-21 for an example). - conIsTuple :: C1 c f p -> Bool - conIsTuple = isTupleString . conName +For the most part, the shared functionality could be abstracted with a subclass of +Monoid that supports fromString, fromChar, etc. But there's a very small chance that +the code below is ever going to inline properly, and the runtime cost of all those +dictinary lookups is likely to be as bad as converting to Text at the end, if not worse. --- | Class of generic representation types for which the 'ConType' has been --- determined. The @arity@ type variable indicates which type class is --- used. @'GTextShow' 'Zero'@ indicates 'TextShow' behavior, and --- @'GTextShow' 'One'@ indicates 'TextShow1' behavior. -class GTextShowCon arity f where - -- | Convert value of a specific 'ConType' to a 'Builder' with the given - -- precedence. - gShowbPrecCon :: ConType -> ShowFuns arity a -> Int -> f a -> Builder +Therefore, I perform some ugly CPP hackery to copy-paste the generic functionality three +times, once for each Text/Builder variant. I suppose I could use TH instead to make this +look a little nicer, but I haven't attempted that. +-} #if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable GTextShowCon +#define DERIVE_TYPEABLE(name) deriving instance Typeable name +#else +#define DERIVE_TYPEABLE(name) #endif -instance GTextShowCon arity U1 where - gShowbPrecCon _ _ _ U1 = mempty - -instance GTextShowCon One Par1 where - gShowbPrecCon _ (Show1Funs sp _) p (Par1 x) = sp p x - -instance TextShow c => GTextShowCon arity (K1 i c) where - gShowbPrecCon _ _ p (K1 x) = showbPrec p x - -instance TextShow1 f => GTextShowCon One (Rec1 f) where - gShowbPrecCon _ (Show1Funs sp sl) p (Rec1 x) = liftShowbPrec sp sl p x - -instance (Selector s, GTextShowCon arity f) => GTextShowCon arity (S1 s f) where - gShowbPrecCon t sfs p sel@(M1 x) - | selName sel == "" = gShowbPrecCon t sfs p x - | otherwise = fromString (selName sel) - <> " = " - <> gShowbPrecCon t sfs 0 x - -instance (GTextShowCon arity f, GTextShowCon arity g) - => GTextShowCon arity (f :*: g) where - gShowbPrecCon t@Rec sfs _ (a :*: b) = - gShowbPrecCon t sfs 0 a - <> ", " - <> gShowbPrecCon t sfs 0 b - gShowbPrecCon t@(Inf o) sfs p (a :*: b) = - gShowbPrecCon t sfs p a - <> showbSpace - <> infixOp - <> showbSpace - <> gShowbPrecCon t sfs p b - where - infixOp :: Builder - infixOp = if isInfixTypeCon o - then fromString o - else singleton '`' <> fromString o <> singleton '`' - gShowbPrecCon t@Tup sfs _ (a :*: b) = - gShowbPrecCon t sfs 0 a - <> singleton ',' - <> gShowbPrecCon t sfs 0 b - gShowbPrecCon t@Pref sfs p (a :*: b) = - gShowbPrecCon t sfs p a - <> showbSpace - <> gShowbPrecCon t sfs p b - -instance (TextShow1 f, GTextShowCon One g) => GTextShowCon One (f :.: g) where - gShowbPrecCon t sfs p (Comp1 x) = - let gspc = gShowbPrecCon t sfs - in liftShowbPrec gspc (showbListWith (gspc 0)) p x - -instance GTextShowCon arity UChar where - gShowbPrecCon _ _ p (UChar c) = showbPrec (hashPrec p) (C# c) <> oneHash - -instance GTextShowCon arity UDouble where - gShowbPrecCon _ _ p (UDouble d) = showbPrec (hashPrec p) (D# d) <> twoHash - -instance GTextShowCon arity UFloat where - gShowbPrecCon _ _ p (UFloat f) = showbPrec (hashPrec p) (F# f) <> oneHash - -instance GTextShowCon arity UInt where - gShowbPrecCon _ _ p (UInt i) = showbPrec (hashPrec p) (I# i) <> oneHash - -instance GTextShowCon arity UWord where - gShowbPrecCon _ _ p (UWord w) = showbPrec (hashPrec p) (W# w) <> twoHash - -oneHash, twoHash :: Builder -hashPrec :: Int -> Int #if __GLASGOW_HASKELL__ >= 711 -oneHash = singleton '#' -twoHash = fromString "##" -hashPrec = const 0 +#define HASH_FUNS(text_type,one_hash,two_hash,hash_prec,from_char,from_string) \ +one_hash, two_hash :: text_type; \ +hash_prec :: Int -> Int; \ +one_hash = from_char '#'; \ +two_hash = from_string "##"; \ +hash_prec = const 0 #else -oneHash = mempty -twoHash = mempty -hashPrec = id +#define HASH_FUNS(text_type,one_hash,two_hash,hash_prec,from_char,from_string) \ +one_hash, two_hash :: text_type; \ +hash_prec :: Int -> Int; \ +one_hash = mempty; \ +two_hash = mempty; \ +hash_prec = id #endif +#define GTEXT_SHOW(text_type,show_funs,no_show_funs,show1_funs,one_hash,two_hash,hash_prec,gtext_show,gshow_prec,gtext_show_con,gshow_prec_con,show_prec,lift_show_prec,show_space,show_paren,show_list_with,from_char,from_string) \ +{- | A 'show_funs' value either stores nothing (for 'TextShow') or it stores \ +the two function arguments that show occurrences of the type parameter (for \ +'TextShow1'). \ + \ +/Since: 3.4/ \ +-}; \ +data show_funs arity a where { \ + no_show_funs :: show_funs Zero a \ + ; show1_funs :: (Int -> a -> text_type) -> ([a] -> text_type) -> show_funs One a \ + } deriving Typeable; \ + \ +instance Contravariant (show_funs arity) where { \ + contramap _ no_show_funs = no_show_funs \ + ; contramap f (show1_funs sp sl) = show1_funs (\p -> sp p . f) (sl . map f) \ + }; \ + \ +{- | Class of generic representation types that can be converted to \ +a 'text_type'. The @arity@ type variable indicates which type class is \ +used. @'gtext_show' 'Zero'@ indicates 'TextShow' behavior, and \ +@'gtext_show' 'One'@ indicates 'TextShow1' behavior. \ + \ +/Since: 3.4/ \ +-}; \ +class gtext_show arity f where { \ + {- | This is used as the default generic implementation of 'show_prec' (if the \ + @arity@ is 'Zero') or 'lift_show_prec' (if the @arity@ is 'One'). \ + -} \ + ; gshow_prec :: show_funs arity a -> Int -> f a -> text_type \ + }; \ + \ +DERIVE_TYPEABLE(gtext_show); \ + \ +instance gtext_show arity f => gtext_show arity (D1 d f) where { \ + gshow_prec sfs p (M1 x) = gshow_prec sfs p x \ + }; \ + \ +instance gtext_show Zero V1 where { \ + gshow_prec _ _ !_ = error "Void show_prec" \ + }; \ + \ +instance gtext_show One V1 where { \ + gshow_prec _ _ !_ = error "Void lift_show_prec" \ + }; \ + \ +instance (gtext_show arity f, gtext_show arity g) => gtext_show arity (f :+: g) where { \ + gshow_prec sfs p (L1 x) = gshow_prec sfs p x \ + ; gshow_prec sfs p (R1 x) = gshow_prec sfs p x \ + }; \ + \ +instance (Constructor c, gtext_show_con arity f, IsNullary f) \ + => gtext_show arity (C1 c f) where { \ + gshow_prec sfs p c@(M1 x) = case fixity of { \ + Prefix -> show_paren ( p > appPrec \ + && not (isNullary x || conIsTuple c) \ + ) $ \ + (if conIsTuple c \ + then mempty \ + else let cn = conName c \ + in show_paren (isInfixTypeCon cn) $ from_string cn) \ + <> (if isNullary x || conIsTuple c \ + then mempty \ + else from_char ' ') \ + <> showbBraces t (gshow_prec_con t sfs appPrec1 x) \ + ; Infix _ m -> show_paren (p > m) $ gshow_prec_con t sfs (m+1) x \ + } \ + where { \ + fixity :: Fixity \ + ; fixity = conFixity c \ + \ + ; t :: ConType \ + ; t = if conIsRecord c \ + then Rec \ + else case conIsTuple c of { \ + True -> Tup \ + ; False -> case fixity of { \ + Prefix -> Pref \ + ; Infix _ _ -> Inf $ conName c \ + }; \ + } \ + \ + ; showbBraces :: ConType -> text_type -> text_type \ + ; showbBraces Rec b = from_char '{' <> b <> from_char '}' \ + ; showbBraces Tup b = from_char '(' <> b <> from_char ')' \ + ; showbBraces Pref b = b \ + ; showbBraces (Inf _) b = b \ + \ + ; conIsTuple :: C1 c f p -> Bool \ + ; conIsTuple = isTupleString . conName \ + }; \ + }; \ + \ +{- | Class of generic representation types for which the 'ConType' has been \ +determined. The @arity@ type variable indicates which type class is \ +used. @'gtext_show_con' 'Zero'@ indicates 'TextShow' behavior, and \ +@'gtext_show_con' 'One'@ indicates 'TextShow1' behavior. \ +-}; \ +class gtext_show_con arity f where { \ + {- | Convert value of a specific 'ConType' to a 'text_type' with the given \ + precedence. \ + -} \ + ; gshow_prec_con :: ConType -> show_funs arity a -> Int -> f a -> text_type \ + }; \ + \ +DERIVE_TYPEABLE(gtext_show_con); \ + \ +instance gtext_show_con arity U1 where { \ + gshow_prec_con _ _ _ U1 = mempty \ + }; \ + \ +instance gtext_show_con One Par1 where { \ + gshow_prec_con _ (show1_funs sp _) p (Par1 x) = sp p x \ + }; \ + \ +instance TextShow c => gtext_show_con arity (K1 i c) where { \ + gshow_prec_con _ _ p (K1 x) = show_prec p x \ + }; \ + \ +instance TextShow1 f => gtext_show_con One (Rec1 f) where { \ + gshow_prec_con _ (show1_funs sp sl) p (Rec1 x) = lift_show_prec sp sl p x \ + }; \ + \ +instance (Selector s, gtext_show_con arity f) => gtext_show_con arity (S1 s f) where { \ + gshow_prec_con t sfs p sel@(M1 x) \ + | selName sel == "" = gshow_prec_con t sfs p x \ + | otherwise = from_string (selName sel) \ + <> " = " \ + <> gshow_prec_con t sfs 0 x \ + }; \ + \ +instance (gtext_show_con arity f, gtext_show_con arity g) \ + => gtext_show_con arity (f :*: g) where { \ + gshow_prec_con t@Rec sfs _ (a :*: b) = \ + gshow_prec_con t sfs 0 a \ + <> ", " \ + <> gshow_prec_con t sfs 0 b \ + ; gshow_prec_con t@(Inf o) sfs p (a :*: b) = \ + gshow_prec_con t sfs p a \ + <> show_space \ + <> infixOp \ + <> show_space \ + <> gshow_prec_con t sfs p b \ + where { \ + infixOp :: text_type \ + ; infixOp = if isInfixTypeCon o \ + then from_string o \ + else from_char '`' <> from_string o <> from_char '`' \ + } \ + ; gshow_prec_con t@Tup sfs _ (a :*: b) = \ + gshow_prec_con t sfs 0 a \ + <> from_char ',' \ + <> gshow_prec_con t sfs 0 b \ + ; gshow_prec_con t@Pref sfs p (a :*: b) = \ + gshow_prec_con t sfs p a \ + <> show_space \ + <> gshow_prec_con t sfs p b \ + }; \ + \ +instance (TextShow1 f, gtext_show_con One g) => gtext_show_con One (f :.: g) where { \ + gshow_prec_con t sfs p (Comp1 x) = \ + let gspc = gshow_prec_con t sfs \ + in lift_show_prec gspc (show_list_with (gspc 0)) p x \ + }; \ + \ +instance gtext_show_con arity UChar where { \ + gshow_prec_con _ _ p (UChar c) = show_prec (hash_prec p) (C# c) <> one_hash \ + }; \ + \ +instance gtext_show_con arity UDouble where { \ + gshow_prec_con _ _ p (UDouble d) = show_prec (hash_prec p) (D# d) <> two_hash \ + }; \ + \ +instance gtext_show_con arity UFloat where { \ + gshow_prec_con _ _ p (UFloat f) = show_prec (hash_prec p) (F# f) <> one_hash \ + }; \ + \ +instance gtext_show_con arity UInt where { \ + gshow_prec_con _ _ p (UInt i) = show_prec (hash_prec p) (I# i) <> one_hash \ + }; \ + \ +instance gtext_show_con arity UWord where { \ + gshow_prec_con _ _ p (UWord w) = show_prec (hash_prec p) (W# w) <> two_hash \ + }; \ + \ +HASH_FUNS(text_type,one_hash,two_hash,hash_prec,from_char,from_string); + +GTEXT_SHOW(Builder,ShowFunsB,NoShowFunsB,Show1FunsB,oneHashB,twoHashB,hashPrecB,GTextShowB,gShowbPrec,GTextShowConB,gShowbPrecCon,showbPrec,liftShowbPrec,showbSpace,showbParen,showbListWith,TB.singleton,TB.fromString) +GTEXT_SHOW(TS.Text,ShowFunsT,NoShowFunsT,Show1FunsT,oneHashT,twoHashT,hashPrecT,GTextShowT,gShowtPrec,GTextShowConT,gShowtPrecCon,showtPrec,liftShowtPrec,showtSpace,showtParen,showtListWith,TS.singleton,TS.pack) +GTEXT_SHOW(TL.Text,ShowFunsTL,NoShowFunsTL,Show1FunsTL,oneHashTL,twoHashTL,hashPrecTL,GTextShowTL,gShowtlPrec,GTextShowConTL,gShowtlPrecCon,showtlPrec,liftShowtlPrec,showtlSpace,showtlParen,showtlListWith,TL.singleton,TL.pack) + -- | Class of generic representation types that represent a constructor with -- zero or more fields. class IsNullary f where @@ -497,6 +568,8 @@ isNullary _ = False ------------------------------------------------------------------------------- + +$(deriveTextShow ''ConType) #if __GLASGOW_HASKELL__ < 702 $(Generics.deriveAll ''ConType) diff --git a/src/TextShow/Options.hs b/src/TextShow/Options.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Options.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +#endif + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +#endif + +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif + +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE DeriveLift #-} +#endif + +{-| +Module: TextShow.FromStringTextShow +Copyright: (C) 2014-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Options' and related datatypes. + +/Since: 3.4/ +-} +module TextShow.Options (Options(..), GenTextMethods(..), defaultOptions) where + +import Data.Data (Data, Typeable) +import Data.Ix (Ix) + +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (Generic) +#else +import qualified Generics.Deriving.TH as Generics +#endif + +import Language.Haskell.TH.Lift + +-- | Options that specify how to derive 'TextShow' instances using Template Haskell. +-- +-- /Since: 3.4/ +newtype Options = Options + { genTextMethods :: GenTextMethods + -- ^ When Template Haskell should generate definitions for methods which + -- return @Text@? + } deriving ( Data + , Eq + , Ord + , Read + , Show + , Typeable +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif + ) + +-- | When should Template Haskell generate implementations for the methods of +-- 'TextShow' which return @Text@? +-- +-- /Since: 3.4/ +data GenTextMethods + = AlwaysTextMethods -- ^ Always generate them. + | SometimesTextMethods -- ^ Only generate when @text-show@ feels it's appropriate. + | NeverTextMethods -- ^ Never generate them under any circumstances. + deriving ( Bounded + , Data + , Enum + , Eq + , Ix + , Ord + , Read + , Show + , Typeable +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif + ) + +-- | Sensible default 'Options'. +-- +-- /Since: 3.4/ +defaultOptions :: Options +defaultOptions = Options { genTextMethods = SometimesTextMethods } + +------------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 702 +$(Generics.deriveAll ''Options) +$(Generics.deriveAll ''GenTextMethods) +#endif + +#if __GLASGOW_HASKELL__ < 800 +$(deriveLift ''Options) +$(deriveLift ''GenTextMethods) +#endif diff --git a/src/TextShow/TH.hs b/src/TextShow/TH.hs --- a/src/TextShow/TH.hs +++ b/src/TextShow/TH.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module: TextShow.TH Copyright: (C) 2014-2016 Ryan Scott @@ -16,3 +19,8 @@ import TextShow.Instances () import TextShow.TH.Internal + +------------------------------------------------------------------------------- + +$(deriveTextShow ''Options) +$(deriveTextShow ''GenTextMethods) diff --git a/src/TextShow/TH/Internal.hs b/src/TextShow/TH/Internal.hs --- a/src/TextShow/TH/Internal.hs +++ b/src/TextShow/TH/Internal.hs @@ -46,6 +46,13 @@ , makeShowbPrec1 , makeLiftShowbPrec2 , makeShowbPrec2 + -- * 'Options' + , Options(..) + , defaultOptions + , GenTextMethods(..) + , deriveTextShowOptions + , deriveTextShow1Options + , deriveTextShow2Options ) where import Control.Monad (liftM, unless, when) @@ -62,11 +69,12 @@ import Data.Monoid.Compat ((<>)) import qualified Data.Set as Set import Data.Set (Set) -import qualified Data.Text as TS () +import qualified Data.Text as TS import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText) -import qualified Data.Text.Lazy as TL () +import qualified Data.Text.Lazy.Builder as TB +import Data.Text.Lazy.Builder (Builder, toLazyText) +import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..)) @@ -84,7 +92,9 @@ import Prelude.Compat import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..), - showbListWith, showbParen, showbSpace) + showbListWith, showbParen, showbSpace, + showtParen, showtSpace, showtlParen, showtlSpace) +import TextShow.Options (Options(..), GenTextMethods(..), defaultOptions) import TextShow.Utils (isInfixTypeCon, isTupleString) ------------------------------------------------------------------------------- @@ -165,8 +175,14 @@ -- -- /Since: 2/ deriveTextShow :: Name -> Q [Dec] -deriveTextShow = deriveTextShowClass TextShow +deriveTextShow = deriveTextShowOptions defaultOptions +-- | Like 'deriveTextShow', but takes an 'Options' argument. +-- +-- /Since: 3.4/ +deriveTextShowOptions :: Options -> Name -> Q [Dec] +deriveTextShowOptions = deriveTextShowClass TextShow + {- $deriveTextShow1 'deriveTextShow1' automatically generates a 'Show1' instance declaration for a data @@ -222,8 +238,14 @@ -- -- /Since: 2/ deriveTextShow1 :: Name -> Q [Dec] -deriveTextShow1 = deriveTextShowClass TextShow1 +deriveTextShow1 = deriveTextShow1Options defaultOptions +-- | Like 'deriveTextShow1', but takes an 'Options' argument. +-- +-- /Since: 3.4/ +deriveTextShow1Options :: Options -> Name -> Q [Dec] +deriveTextShow1Options = deriveTextShowClass TextShow1 + {- $deriveTextShow2 'deriveTextShow2' automatically generates a 'TextShow2' instance declaration for a data @@ -280,8 +302,14 @@ -- -- /Since: 2/ deriveTextShow2 :: Name -> Q [Dec] -deriveTextShow2 = deriveTextShowClass TextShow2 +deriveTextShow2 = deriveTextShow2Options defaultOptions +-- | Like 'deriveTextShow2', but takes an 'Options' argument. +-- +-- /Since: 3.4/ +deriveTextShow2Options :: Options -> Name -> Q [Dec] +deriveTextShow2Options = deriveTextShowClass TextShow2 + {- $make There may be scenarios in which you want to show an arbitrary data type or data @@ -311,28 +339,28 @@ -- -- /Since: 2/ makeShowt :: Name -> Q Exp -makeShowt name = [| toStrict . $(makeShowtl name) |] +makeShowt name = makeShowtPrec name `appE` integerE 0 -- | Generates a lambda expression which behaves like 'showtl' (without requiring a -- 'TextShow' instance). -- -- /Since: 2/ makeShowtl :: Name -> Q Exp -makeShowtl name = [| toLazyText . $(makeShowb name) |] +makeShowtl name = makeShowtlPrec name `appE` integerE 0 -- | Generates a lambda expression which behaves like 'showtPrec' (without requiring a -- 'TextShow' instance). -- -- /Since: 2/ makeShowtPrec :: Name -> Q Exp -makeShowtPrec name = [| \p -> toStrict . $(makeShowtlPrec name) p |] +makeShowtPrec = makeShowbPrecClass TextShow ShowtPrec -- | Generates a lambda expression which behaves like 'showtlPrec' (without -- requiring a 'TextShow' instance). -- -- /Since: 2/ makeShowtlPrec :: Name -> Q Exp -makeShowtlPrec name = [| \p -> toLazyText . $(makeShowbPrec name) p |] +makeShowtlPrec = makeShowbPrecClass TextShow ShowtlPrec -- | Generates a lambda expression which behaves like 'showtList' (without requiring a -- 'TextShow' instance). @@ -353,25 +381,21 @@ -- -- /Since: 2/ makeShowb :: Name -> Q Exp -makeShowb name = makeShowbPrec name `appE` [| zero |] - where - -- To prevent the generated TH code from having a type ascription - zero :: Int - zero = 0 +makeShowb name = makeShowbPrec name `appE` integerE 0 -- | Generates a lambda expression which behaves like 'showbPrec' (without requiring a -- 'TextShow' instance). -- -- /Since: 2/ makeShowbPrec :: Name -> Q Exp -makeShowbPrec = makeShowbPrecClass TextShow +makeShowbPrec = makeShowbPrecClass TextShow ShowbPrec -- | Generates a lambda expression which behaves like 'liftShowbPrec' (without -- requiring a 'TextShow1' instance). -- -- /Since: 3/ makeLiftShowbPrec :: Name -> Q Exp -makeLiftShowbPrec = makeShowbPrecClass TextShow1 +makeLiftShowbPrec = makeShowbPrecClass TextShow1 ShowbPrec -- | Generates a lambda expression which behaves like 'showbPrec1' (without -- requiring a 'TextShow1' instance). @@ -385,7 +409,7 @@ -- -- /Since: 3/ makeLiftShowbPrec2 :: Name -> Q Exp -makeLiftShowbPrec2 = makeShowbPrecClass TextShow2 +makeLiftShowbPrec2 = makeShowbPrecClass TextShow2 ShowbPrec -- | Generates a lambda expression which behaves like 'showbPrec2' (without -- requiring a 'TextShow2' instance). @@ -435,8 +459,8 @@ -- | Derive a TextShow(1)(2) instance declaration (depending on the TextShowClass -- argument's value). -deriveTextShowClass :: TextShowClass -> Name -> Q [Dec] -deriveTextShowClass tsClass name = withType name fromCons +deriveTextShowClass :: TextShowClass -> Options -> Name -> Q [Dec] +deriveTextShowClass tsClass opts name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) <$> do @@ -444,24 +468,37 @@ <- buildTypeInstance tsClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) - (showbPrecDecs tsClass cons) + (showbPrecDecs tsClass opts cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (showbPrec for TextShow, liftShowbPrec for TextShow1, and -- liftShowbPrec2 for TextShow2). -showbPrecDecs :: TextShowClass -> [Con] -> [Q Dec] -showbPrecDecs tsClass cons = - [ funD (showbPrecName tsClass) - [ clause [] - (normalB $ makeTextShowForCons tsClass cons) - [] - ] - ] +showbPrecDecs :: TextShowClass -> Options -> [Con] -> [Q Dec] +showbPrecDecs tsClass opts cons = + [genMethod ShowbPrec (showbPrecName tsClass)] + ++ if tsClass == TextShow && shouldGenTextMethods + then [genMethod ShowtPrec 'showtPrec, genMethod ShowtlPrec 'showtlPrec] + else [] + where + shouldGenTextMethods :: Bool + shouldGenTextMethods = case genTextMethods opts of + AlwaysTextMethods -> True + SometimesTextMethods -> all isNullaryCon cons + NeverTextMethods -> False + genMethod :: TextShowFun -> Name -> Q Dec + genMethod method methodName + = funD methodName + [ clause [] + (normalB $ makeTextShowForCons tsClass method cons) + [] + ] + + -- | Generates a lambda expression which behaves like showbPrec (for TextShow), -- liftShowbPrec (for TextShow1), or liftShowbPrec2 (for TextShow2). -makeShowbPrecClass :: TextShowClass -> Name -> Q Exp -makeShowbPrecClass tsClass name = withType name fromCons +makeShowbPrecClass :: TextShowClass -> TextShowFun -> Name -> Q Exp +makeShowbPrecClass tsClass tsFun name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = @@ -469,103 +506,125 @@ -- or not the provided datatype can actually have showbPrec/liftShowbPrec/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance tsClass name' ctxt tvbs mbTys - `seq` makeTextShowForCons tsClass cons + `seq` makeTextShowForCons tsClass tsFun cons -- | Generates a lambda expression for showbPrec/liftShowbPrec/etc. for the -- given constructors. All constructors must be from the same type. -makeTextShowForCons :: TextShowClass -> [Con] -> Q Exp -makeTextShowForCons _ [] = error "Must have at least one data constructor" -makeTextShowForCons tsClass cons = do +makeTextShowForCons :: TextShowClass -> TextShowFun -> [Con] -> Q Exp +makeTextShowForCons _ _ [] = error "Must have at least one data constructor" +makeTextShowForCons tsClass tsFun cons = do p <- newName "p" value <- newName "value" sps <- newNameList "sp" $ fromEnum tsClass sls <- newNameList "sl" $ fromEnum tsClass let spls = zip sps sls spsAndSls = interleave sps sls - matches <- concatMapM (makeTextShowForCon p tsClass spls) cons + matches <- concatMapM (makeTextShowForCon p tsClass tsFun spls) cons lamE (map varP $ spsAndSls ++ [p, value]) . appsE - $ [ varE $ showbPrecConstName tsClass + $ [ varE $ showPrecConstName tsClass tsFun , caseE (varE value) (map return matches) ] ++ map varE spsAndSls ++ [varE p, varE value] -- | Generates a lambda expression for howbPrec/liftShowbPrec/etc. for a -- single constructor. -makeTextShowForCon :: Name -> TextShowClass -> [(Name, Name)] -> Con -> Q [Match] -makeTextShowForCon _ _ _ (NormalC conName []) = do +makeTextShowForCon :: Name + -> TextShowClass + -> TextShowFun + -> [(Name, Name)] + -> Con + -> Q [Match] +makeTextShowForCon _ _ tsFun _ (NormalC conName []) = do m <- match (conP conName []) - (normalB [| fromString $(stringE (parenInfixConName conName "")) |]) + (normalB $ varE (fromStringName tsFun) `appE` stringE (parenInfixConName conName "")) [] return [m] -makeTextShowForCon p tsClass spls (NormalC conName [_]) = do +makeTextShowForCon p tsClass tsFun spls (NormalC conName [_]) = do ([argTy], tvMap) <- reifyConTys tsClass spls conName arg <- newName "arg" - let showArg = makeTextShowForArg appPrec1 tsClass conName tvMap argTy arg - namedArg = [| fromString $(stringE (parenInfixConName conName " ")) <> $(showArg) |] + let showArg = makeTextShowForArg appPrec1 tsClass tsFun conName tvMap argTy arg + namedArg = infixApp (varE (fromStringName tsFun) `appE` stringE (parenInfixConName conName " ")) + [| (<>) |] + showArg m <- match (conP conName [varP arg]) - (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArg) |]) + (normalB $ varE (showParenName tsFun) + `appE` infixApp (varE p) [| (>) |] (integerE appPrec) + `appE` namedArg) [] return [m] -makeTextShowForCon p tsClass spls (NormalC conName _) = do +makeTextShowForCon p tsClass tsFun spls (NormalC conName _) = do (argTys, tvMap) <- reifyConTys tsClass spls conName args <- newNameList "arg" $ length argTys m <- if isNonUnitTuple conName then do - let showArgs = zipWith (makeTextShowForArg 0 tsClass conName tvMap) argTys args - parenCommaArgs = [| singleton '(' |] : intersperse [| singleton ',' |] showArgs - mappendArgs = foldr (`infixApp` [| (<>) |]) - [| singleton ')' |] - parenCommaArgs + let showArgs = zipWith (makeTextShowForArg 0 tsClass tsFun conName tvMap) argTys args + parenCommaArgs = (varE (singletonName tsFun) `appE` charE '(') + : intersperse (varE (singletonName tsFun) `appE` charE ',') showArgs + mappendArgs = foldr' (`infixApp` [| (<>) |]) + (varE (singletonName tsFun) `appE` charE ')') + parenCommaArgs match (conP conName $ map varP args) (normalB mappendArgs) [] else do - let showArgs = zipWith (makeTextShowForArg appPrec1 tsClass conName tvMap) argTys args - mappendArgs = foldr1 (\v q -> [| $(v) <> showbSpace <> $(q) |]) showArgs - namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |] + let showArgs = zipWith (makeTextShowForArg appPrec1 tsClass tsFun conName tvMap) argTys args + mappendArgs = foldr1 (\v q -> infixApp v + [| (<>) |] + (infixApp (varE $ showSpaceName tsFun) + [| (<>) |] + q)) showArgs + namedArgs = infixApp (varE (fromStringName tsFun) `appE` stringE (parenInfixConName conName " ")) + [| (<>) |] + mappendArgs match (conP conName $ map varP args) - (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArgs) |]) + (normalB $ varE (showParenName tsFun) + `appE` infixApp (varE p) [| (>) |] (integerE appPrec) + `appE` namedArgs) [] return [m] -makeTextShowForCon p tsClass spls (RecC conName []) = - makeTextShowForCon p tsClass spls $ NormalC conName [] -makeTextShowForCon p tsClass spls (RecC conName ts) = do +makeTextShowForCon p tsClass tsFun spls (RecC conName []) = + makeTextShowForCon p tsClass tsFun spls $ NormalC conName [] +makeTextShowForCon p tsClass tsFun spls (RecC conName ts) = do (argTys, tvMap) <- reifyConTys tsClass spls conName args <- newNameList "arg" $ length argTys let showArgs = concatMap (\((argName, _, _), argTy, arg) - -> [ [| fromString $(stringE (nameBase argName ++ " = ")) |] - , makeTextShowForArg 0 tsClass conName tvMap argTy arg - , [| fromString ", " |] + -> [ varE (fromStringName tsFun) `appE` stringE (nameBase argName ++ " = ") + , makeTextShowForArg 0 tsClass tsFun conName tvMap argTy arg + , varE (fromStringName tsFun) `appE` stringE ", " ] ) (zip3 ts argTys args) - braceCommaArgs = [| singleton '{' |] : take (length showArgs - 1) showArgs - mappendArgs = foldr (`infixApp` [| (<>) |]) - [| singleton '}' |] - braceCommaArgs - namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |] + braceCommaArgs = (varE (singletonName tsFun) `appE` charE '{') : take (length showArgs - 1) showArgs + mappendArgs = foldr' (`infixApp` [| (<>) |]) + (varE (singletonName tsFun) `appE` charE '}') + braceCommaArgs + namedArgs = infixApp (varE (fromStringName tsFun) `appE` stringE (parenInfixConName conName " ")) + [| (<>) |] + mappendArgs m <- match (conP conName $ map varP args) - (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArgs) |]) + (normalB $ varE (showParenName tsFun) + `appE` infixApp (varE p) [| (>) |] (integerE appPrec) + `appE` namedArgs) [] return [m] -makeTextShowForCon p tsClass spls (InfixC _ conName _) = do +makeTextShowForCon p tsClass tsFun spls (InfixC _ conName _) = do ([alTy, arTy], tvMap) <- reifyConTys tsClass spls conName al <- newName "argL" ar <- newName "argR" info <- reify conName -#if __GLASGOW_HASKELL__ >= 711 +#if MIN_VERSION_template_haskell(2,11,0) conPrec <- case info of DataConI{} -> do fi <- fromMaybe defaultFixity <$> reifyFixity conName @@ -578,24 +637,26 @@ _ -> error $ "TextShow.TH.makeTextShowForCon: Unsupported type: " ++ show info let opName = nameBase conName - infixOpE = if isInfixTypeCon opName - then [| fromString $(stringE $ " " ++ opName ++ " " ) |] - else [| fromString $(stringE $ " `" ++ opName ++ "` ") |] + infixOpE = appE (varE $ fromStringName tsFun) . stringE $ + if isInfixTypeCon opName + then " " ++ opName ++ " " + else " `" ++ opName ++ "` " m <- match (infixP (varP al) conName (varP ar)) - (normalB $ appE [| showbParen ($(varE p) > conPrec) |] - [| $(makeTextShowForArg (conPrec + 1) tsClass conName tvMap alTy al) - <> $(infixOpE) - <> $(makeTextShowForArg (conPrec + 1) tsClass conName tvMap arTy ar) - |] + (normalB $ (varE (showParenName tsFun) `appE` infixApp (varE p) [| (>) |] (integerE conPrec)) + `appE` (infixApp (makeTextShowForArg (conPrec + 1) tsClass tsFun conName tvMap alTy al) + [| (<>) |] + (infixApp infixOpE + [| (<>) |] + (makeTextShowForArg (conPrec + 1) tsClass tsFun conName tvMap arTy ar))) ) [] return [m] -makeTextShowForCon p tsClass spls (ForallC _ _ con) = - makeTextShowForCon p tsClass spls con +makeTextShowForCon p tsClass tsFun spls (ForallC _ _ con) = + makeTextShowForCon p tsClass tsFun spls con #if MIN_VERSION_template_haskell(2,11,0) -makeTextShowForCon p tsClass spls (GadtC conNames ts _) = +makeTextShowForCon p tsClass tsFun spls (GadtC conNames ts _) = let con :: Name -> Q Con con conName = do mbFi <- reifyFixity conName @@ -605,54 +666,55 @@ then let [t1, t2] = ts in InfixC t1 conName t2 else NormalC conName ts - in concatMapM (makeTextShowForCon p tsClass spls <=< con) conNames -makeTextShowForCon p tsClass spls (RecGadtC conNames ts _) = - concatMapM (makeTextShowForCon p tsClass spls . flip RecC ts) conNames + in concatMapM (makeTextShowForCon p tsClass tsFun spls <=< con) conNames +makeTextShowForCon p tsClass tsFun spls (RecGadtC conNames ts _) = + concatMapM (makeTextShowForCon p tsClass tsFun spls . flip RecC ts) conNames #endif -- | Generates a lambda expression for howbPrec/liftShowbPrec/etc. for an -- argument of a constructor. makeTextShowForArg :: Int -> TextShowClass + -> TextShowFun -> Name -> TyVarMap -> Type -> Name -> Q Exp -makeTextShowForArg p _ _ _ (ConT tyName) tyExpName = -#if __GLASGOW_HASKELL__ >= 711 --- Starting with GHC 7.10, data types containing unlifted types with derived @Show@ --- instances show hashed literals with actual hash signs, and negative hashed --- literals are not surrounded with parentheses. +makeTextShowForArg p _ tsFun _ _ (ConT tyName) tyExpName = showE where - tyVarE :: Q Exp - tyVarE = varE tyExpName + tyVarE, showPrecE :: Q Exp + tyVarE = varE tyExpName + showPrecE = varE (showPrecName TextShow tsFun) showE :: Q Exp - showE | tyName == ''Char# = [| showbPrec 0 (C# $(tyVarE)) <> singleton '#' |] - | tyName == ''Double# = [| showbPrec 0 (D# $(tyVarE)) <> fromString "##" |] - | tyName == ''Float# = [| showbPrec 0 (F# $(tyVarE)) <> singleton '#' |] - | tyName == ''Int# = [| showbPrec 0 (I# $(tyVarE)) <> singleton '#' |] - | tyName == ''Word# = [| showbPrec 0 (W# $(tyVarE)) <> fromString "##" |] - | otherwise = [| showbPrec p $(tyVarE) |] -#else - [| showbPrec p $(expr) |] - where - tyVarE :: Q Exp - tyVarE = varE tyExpName + showE | tyName == ''Char# = showPrimE 'C# oneHashE + | tyName == ''Double# = showPrimE 'D# twoHashE + | tyName == ''Float# = showPrimE 'F# oneHashE + | tyName == ''Int# = showPrimE 'I# oneHashE + | tyName == ''Word# = showPrimE 'W# twoHashE + | otherwise = showPrecE `appE` integerE p `appE` tyVarE - expr :: Q Exp - expr | tyName == ''Char# = [| C# $(tyVarE) |] - | tyName == ''Double# = [| D# $(tyVarE) |] - | tyName == ''Float# = [| F# $(tyVarE) |] - | tyName == ''Int# = [| I# $(tyVarE) |] - | tyName == ''Word# = [| W# $(tyVarE) |] - | otherwise = tyVarE + -- Starting with GHC 7.10, data types containing unlifted types with derived Show + -- instances show hashed literals with actual hash signs, and negative hashed + -- literals are not surrounded with parentheses. + showPrimE :: Name -> Q Exp -> Q Exp + showPrimE con _hashE +#if __GLASGOW_HASKELL__ >= 711 + = infixApp (showPrecE `appE` integerE 0 `appE` (conE con `appE` tyVarE)) + [| (<>) |] + _hashE +#else + = showPrecE `appE` integerE p `appE` (conE con `appE` tyVarE) #endif -makeTextShowForArg p tsClass conName tvMap ty tyExpName = - [| $(makeTextShowForType tsClass conName tvMap False ty) p $(varE tyExpName) |] + oneHashE, twoHashE :: Q Exp + oneHashE = varE (singletonName tsFun) `appE` charE '#' + twoHashE = varE (fromStringName tsFun) `appE` stringE "##" +makeTextShowForArg p tsClass tsFun conName tvMap ty tyExpName = + [| $(makeTextShowForType tsClass tsFun conName tvMap False ty) p $(varE tyExpName) |] + -- | Generates a lambda expression for howbPrec/liftShowbPrec/etc. for a -- specific type. The generated expression depends on the number of type variables. -- @@ -661,19 +723,23 @@ -- 3. If the type is of kind * -> * -> * (T a b), apply -- liftShowbPrec2 $(makeTextShowForType a) $(makeTextShowForType b) makeTextShowForType :: TextShowClass + -> TextShowFun -> Name -> TyVarMap -> Bool -- ^ True if we are using the function of type ([a] -> Builder), -- False if we are using the function of type (Int -> a -> Builder). -> Type -> Q Exp -makeTextShowForType _ _ tvMap sl (VarT tyName) = - case Map.lookup tyName tvMap of - Just (spExp, slExp) -> varE (if sl then slExp else spExp) - Nothing -> if sl then [| showbList |] else [| showbPrec |] -makeTextShowForType tsClass conName tvMap sl (SigT ty _) = makeTextShowForType tsClass conName tvMap sl ty -makeTextShowForType tsClass conName tvMap sl (ForallT _ _ ty) = makeTextShowForType tsClass conName tvMap sl ty -makeTextShowForType tsClass conName tvMap sl ty = do +makeTextShowForType _ tsFun _ tvMap sl (VarT tyName) = + varE $ case Map.lookup tyName tvMap of + Just (spExp, slExp) -> if sl then slExp else spExp + Nothing -> if sl then showListName TextShow tsFun + else showPrecName TextShow tsFun +makeTextShowForType tsClass tsFun conName tvMap sl (SigT ty _) = + makeTextShowForType tsClass tsFun conName tvMap sl ty +makeTextShowForType tsClass tsFun conName tvMap sl (ForallT _ _ ty) = + makeTextShowForType tsClass tsFun conName tvMap sl ty +makeTextShowForType tsClass tsFun conName tvMap sl ty = do let tyCon :: Type tyArgs :: [Type] tyCon :| tyArgs = unapplyTy ty @@ -692,11 +758,12 @@ || itf && any (`mentionsName` tyVarNames) tyArgs then outOfPlaceTyVarError tsClass conName else if any (`mentionsName` tyVarNames) rhsArgs - then appsE $ [ varE . showbPrecOrListName sl $ toEnum numLastArgs] - ++ zipWith (makeTextShowForType tsClass conName tvMap) + then appsE $ [ varE $ showPrecOrListName sl (toEnum numLastArgs) tsFun] + ++ zipWith (makeTextShowForType tsClass tsFun conName tvMap) (cycle [False,True]) (interleave rhsArgs rhsArgs) - else if sl then [| showbList |] else [| showbPrec |] + else varE $ if sl then showListName TextShow tsFun + else showPrecName TextShow tsFun ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation @@ -1293,6 +1360,36 @@ data TextShowClass = TextShow | TextShow1 | TextShow2 deriving (Enum, Eq, Ord) +-- | A representation of which TextShow method is being used to +-- implement something. +data TextShowFun = ShowbPrec | ShowtPrec | ShowtlPrec + +fromStringName :: TextShowFun -> Name +fromStringName ShowbPrec = 'TB.fromString +fromStringName ShowtPrec = 'TS.pack +fromStringName ShowtlPrec = 'TL.pack + +singletonName :: TextShowFun -> Name +singletonName ShowbPrec = 'TB.singleton +singletonName ShowtPrec = 'TS.singleton +singletonName ShowtlPrec = 'TL.singleton + +showParenName :: TextShowFun -> Name +showParenName ShowbPrec = 'showbParen +showParenName ShowtPrec = 'showtParen +showParenName ShowtlPrec = 'showtlParen + +showSpaceName :: TextShowFun -> Name +showSpaceName ShowbPrec = 'showbSpace +showSpaceName ShowtPrec = 'showtSpace +showSpaceName ShowtlPrec = 'showtlSpace + +showPrecConstName :: TextShowClass -> TextShowFun -> Name +showPrecConstName tsClass ShowbPrec = showbPrecConstName tsClass +showPrecConstName TextShow ShowtPrec = 'showtPrecConst +showPrecConstName TextShow ShowtlPrec = 'showtlPrecConst +showPrecConstName _ _ = error "showPrecConstName" + showbPrecConstName :: TextShowClass -> Name showbPrecConstName TextShow = 'showbPrecConst showbPrecConstName TextShow1 = 'liftShowbPrecConst @@ -1303,21 +1400,34 @@ textShowClassName TextShow1 = ''TextShow1 textShowClassName TextShow2 = ''TextShow2 +showPrecName :: TextShowClass -> TextShowFun -> Name +showPrecName tsClass ShowbPrec = showbPrecName tsClass +showPrecName TextShow ShowtPrec = 'showtPrec +showPrecName TextShow ShowtlPrec = 'showtlPrec +showPrecName _ _ = error "showPrecName" + showbPrecName :: TextShowClass -> Name showbPrecName TextShow = 'showbPrec showbPrecName TextShow1 = 'liftShowbPrec showbPrecName TextShow2 = 'liftShowbPrec2 +showListName :: TextShowClass -> TextShowFun -> Name +showListName tsClass ShowbPrec = showbListName tsClass +showListName TextShow ShowtPrec = 'showtPrec +showListName TextShow ShowtlPrec = 'showtlPrec +showListName _ _ = error "showListName" + showbListName :: TextShowClass -> Name showbListName TextShow = 'showbList showbListName TextShow1 = 'liftShowbList showbListName TextShow2 = 'liftShowbList2 -showbPrecOrListName :: Bool -- ^ showbListName if True, showbPrecName if False - -> TextShowClass - -> Name -showbPrecOrListName False = showbPrecName -showbPrecOrListName True = showbListName +showPrecOrListName :: Bool -- ^ showbListName if True, showbPrecName if False + -> TextShowClass + -> TextShowFun + -> Name +showPrecOrListName False = showPrecName +showPrecOrListName True = showListName -- | A type-restricted version of 'const'. This is useful when generating the lambda -- expression in 'makeShowbPrec' for a data type with only nullary constructors (since @@ -1329,6 +1439,14 @@ -> Int -> a -> Builder showbPrecConst b _ _ = b +showtPrecConst :: TS.Text + -> Int -> a -> TS.Text +showtPrecConst t _ _ = t + +showtlPrecConst :: TL.Text + -> Int -> a -> TL.Text +showtlPrecConst tl _ _ = tl + liftShowbPrecConst :: Builder -> (Int -> a -> Builder) -> ([a] -> Builder) -> Int -> f a -> Builder @@ -1375,6 +1493,12 @@ -- Assorted utilities ------------------------------------------------------------------------------- +integerE :: Int -> Q Exp +integerE = litE . integerL . fromIntegral + +charE :: Char -> Q Exp +charE = litE . charL + -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True @@ -1647,6 +1771,17 @@ constructorName (RecGadtC names _ _) = head names # endif #endif + +isNullaryCon :: Con -> Bool +isNullaryCon (NormalC _ []) = True +isNullaryCon (RecC _ []) = True +isNullaryCon InfixC{} = False +isNullaryCon (ForallC _ _ con) = isNullaryCon con +#if MIN_VERSION_template_haskell(2,11,0) +isNullaryCon (GadtC _ [] _) = True +isNullaryCon (RecGadtC _ [] _) = True +#endif +isNullaryCon _ = False interleave :: [a] -> [a] -> [a] interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s diff --git a/tests/Derived/DataFamilies.hs b/tests/Derived/DataFamilies.hs --- a/tests/Derived/DataFamilies.hs +++ b/tests/Derived/DataFamilies.hs @@ -63,14 +63,9 @@ #if MIN_VERSION_template_haskell(2,7,0) import Text.Show.Deriving (deriveShow1) import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) -#endif -#if defined(NEW_FUNCTOR_CLASSES) -# if MIN_VERSION_template_haskell(2,7,0) +# if defined(NEW_FUNCTOR_CLASSES) import Text.Show.Deriving (deriveShow2) -# else -import Data.Functor.Classes (Show1(..), Show2(..), - showsUnaryWith, showsBinaryWith) # endif #endif @@ -95,22 +90,14 @@ , NASShow2 <$> arbitrary ] -#if !defined(NEW_FUNCTOR_CLASSES) +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1 'NASShow1) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1 'NASShow1) $(deriveShow2 'NASShow2) -#else -instance (Show b, Show c) => Show1 (NotAllShow Int b c) where - liftShowsPrec = liftShowsPrec2 showsPrec showList -instance Show b => Show2 (NotAllShow Int b) where - liftShowsPrec2 sp1 _ _ _ p (NASShow1 c b) = - showsBinaryWith sp1 showsPrec "NASShow1" p c b - liftShowsPrec2 _ _ sp2 _ p (NASShow2 d) = - showsUnaryWith sp2 "NASShow2" p d -#endif +# endif -#if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'NASShow1) $(deriveTextShow1 'NASShow2) $(deriveTextShow2 'NASShow1) @@ -154,29 +141,17 @@ => Arbitrary (KindDistinguished (a :: Bool) b c) where arbitrary = KindDistinguishedBool <$> arbitrary <*> arbitrary -#if !defined(NEW_FUNCTOR_CLASSES) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1 'KindDistinguishedUnit) $(deriveShow1 'KindDistinguishedBool) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1 'KindDistinguishedUnit) $(deriveShow2 'KindDistinguishedUnit) $(deriveShow1 'KindDistinguishedBool) $(deriveShow2 'KindDistinguishedBool) -#else -instance Show b => Show1 (KindDistinguished (a :: ()) b) where - liftShowsPrec = liftShowsPrec2 showsPrec showList -instance Show b => Show1 (KindDistinguished (a :: Bool) b) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Show2 (KindDistinguished (a :: ())) where - liftShowsPrec2 sp1 _ sp2 _ p (KindDistinguishedUnit b c) = - showsBinaryWith sp1 sp2 "KindDistinguishedUnit" p b c -instance Show2 (KindDistinguished (a :: Bool)) where - liftShowsPrec2 sp1 _ sp2 _ p (KindDistinguishedBool b c) = - showsBinaryWith sp1 sp2 "KindDistinguishedBool" p b c -#endif +# endif $(deriveTextShow 'KindDistinguishedUnit) $(deriveTextShow1 'KindDistinguishedUnit) @@ -203,8 +178,4 @@ deriving (Arbitrary, Show, Generic) $(deriveTextShow 'NullaryCon) - -# if __GLASGOW_HASKELL__ < 706 -$(Generics.deriveAll 'NullaryCon) -# endif #endif diff --git a/tests/Derived/DatatypeContexts.hs b/tests/Derived/DatatypeContexts.hs --- a/tests/Derived/DatatypeContexts.hs +++ b/tests/Derived/DatatypeContexts.hs @@ -30,11 +30,6 @@ #if defined(NEW_FUNCTOR_CLASSES) import Data.Functor.Classes (Show2(..)) import Text.Show.Deriving (makeLiftShowsPrec, makeLiftShowsPrec2) -# if MIN_VERSION_template_haskell(2,7,0) -import Text.Show.Deriving (deriveShow2) -# else -import GHC.Show (appPrec, appPrec1, showSpace) -# endif #else import Text.Show.Deriving (makeShowsPrec1) #endif @@ -74,33 +69,6 @@ liftShowsPrec2 = $(makeLiftShowsPrec2 ''TyCon) #endif -#if !defined(NEW_FUNCTOR_CLASSES) -instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where - showsPrec1 = $(makeShowsPrec1 'TyFamily) -#elif MIN_VERSION_template_haskell(2,7,0) -instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where - liftShowsPrec = $(makeLiftShowsPrec 'TyFamily) - -instance (Ord a, Show a) => Show2 (TyFamily a) where - liftShowsPrec2 = $(makeLiftShowsPrec2 'TyFamily) -#else -instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance (Ord a, Show a) => Show2 (TyFamily a) where - liftShowsPrec2 sp1 _ sp2 _ p (TyFamily a b c) = - showsThree sp1 sp2 "TyFamily" p a b c - -showsThree :: Show a - => (Int -> b -> ShowS) -> (Int -> c -> ShowS) - -> String -> Int -> a -> b -> c -> ShowS -showsThree sp1 sp2 name p a b c = showParen (p > appPrec) $ - showString name . showSpace - . showsPrec appPrec1 a . showSpace - . sp1 appPrec1 b . showSpace - . sp2 appPrec1 c -#endif - instance (Ord a, TextShow a, TextShow b, TextShow c) => TextShow (TyCon a b c) where showbPrec = $(makeShowbPrec ''TyCon) instance (Ord a, TextShow a, TextShow b) => TextShow1 (TyCon a b) where @@ -109,6 +77,17 @@ liftShowbPrec2 = $(makeLiftShowbPrec2 ''TyCon) #if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) +instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where + showsPrec1 = $(makeShowsPrec1 'TyFamily) +# else +instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where + liftShowsPrec = $(makeLiftShowsPrec 'TyFamily) + +instance (Ord a, Show a) => Show2 (TyFamily a) where + liftShowsPrec2 = $(makeLiftShowsPrec2 'TyFamily) +# endif + instance (Ord a, TextShow a, TextShow b, TextShow c) => TextShow (TyFamily a b c) where showbPrec = $(makeShowbPrec 'TyFamily) instance (Ord a, TextShow a, TextShow b) => TextShow1 (TyFamily a b) where diff --git a/tests/Derived/ExistentialQuantification.hs b/tests/Derived/ExistentialQuantification.hs --- a/tests/Derived/ExistentialQuantification.hs +++ b/tests/Derived/ExistentialQuantification.hs @@ -23,17 +23,13 @@ import Test.QuickCheck (Arbitrary(..), Gen, oneof) import Text.Show.Deriving (deriveShow1) -import TextShow (TextShow) -import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) - #if defined(NEW_FUNCTOR_CLASSES) import Text.Show.Deriving (deriveShow2) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (Show1(..), Show2(..), showsBinaryWith) -import GHC.Show (appPrec, appPrec1, showSpace) -# endif #endif +import TextShow (TextShow) +import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) + ------------------------------------------------------------------------------- data TyCon a b c d where @@ -113,39 +109,14 @@ $(deriveTextShow1 ''TyCon) $(deriveTextShow2 ''TyCon) -#if !defined(NEW_FUNCTOR_CLASSES) +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1 'TyFamilyClassConstraints) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1 'TyFamilyTypeRefinement1) $(deriveShow2 'TyFamilyTypeRefinement1) -#else -instance (Show a, Show b, Show c) => Show1 (TyFamily a b c) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance (Show a, Show b) => Show2 (TyFamily a b) where - liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyClassConstraints a b c d) = - showsFour sp1 sp2 "TyFamilyClassConstraints" p a b c d - liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyEqualityConstraints a b c d) = - showsFour sp1 sp2 "TyFamilyEqualityConstraints" p a b c d - liftShowsPrec2 _ _ sp2 _ p (TyFamilyTypeRefinement1 i d) = - showsBinaryWith showsPrec sp2 "TyFamilyTypeRefinement1" p i d - liftShowsPrec2 _ _ sp2 _ p (TyFamilyTypeRefinement2 i d) = - showsBinaryWith showsPrec sp2 "TyFamilyTypeRefinement2" p i d - liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyForalls p' q d c) = - showsFour sp2 sp1 "TyFamilyForalls" p p' q d c - -showsFour :: (Show a, Show b) - => (Int -> c -> ShowS) -> (Int -> d -> ShowS) - -> String -> Int -> a -> b -> c -> d -> ShowS -showsFour sp1 sp2 name p a b c d = showParen (p > appPrec) $ - showString name . showSpace - . showsPrec appPrec1 a . showSpace - . showsPrec appPrec1 b . showSpace - . sp1 appPrec1 c . showSpace - . sp2 appPrec1 d -#endif +# endif -#if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'TyFamilyClassConstraints) $(deriveTextShow1 'TyFamilyTypeRefinement1) $(deriveTextShow2 'TyFamilyTypeRefinement2) diff --git a/tests/Derived/Infix.hs b/tests/Derived/Infix.hs --- a/tests/Derived/Infix.hs +++ b/tests/Derived/Infix.hs @@ -8,6 +8,10 @@ {-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +#endif + {-| Module: Derived.Infix Copyright: (C) 2014-2016 Ryan Scott @@ -44,16 +48,12 @@ import Test.QuickCheck (Arbitrary(..), oneof) import Text.Show.Deriving (deriveShow1) -import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) - #if defined(NEW_FUNCTOR_CLASSES) import Text.Show.Deriving (deriveShow2) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (Show1(..), Show2(..), showsBinaryWith) -import GHC.Show (appPrec, appPrec1, showSpace) -# endif #endif +import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) + ------------------------------------------------------------------------------- infixl 3 :!: @@ -169,58 +169,29 @@ $(deriveTextShow1 ''TyConGADT) $(deriveTextShow2 ''TyConGADT) -#if !defined(NEW_FUNCTOR_CLASSES) +#if __GLASGOW_HASKELL__ < 706 +$(Generics.deriveMeta ''TyConPlain) +$(Generics.deriveRepresentable1 ''TyConPlain) +$(Generics.deriveAll0And1 ''TyConGADT) +#endif + +#if __GLASGOW_HASKELL__ < 702 +$(Generics.deriveRepresentable0 ''TyConPlain) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1 '(:#:)) $(deriveShow1 '(:*)) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1 '(:#:)) $(deriveShow2 '(:$:)) $(deriveShow1 '(:*)) $(deriveShow2 '(:***)) -#else -instance Show a => Show1 (TyFamilyPlain a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList -instance Show a => Show1 (TyFamilyGADT a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Show2 TyFamilyPlain where - liftShowsPrec2 sp1 _ sp2 _ p (a :#: b) = - showsBinaryWith sp1 sp2 "(:#:)" p a b - liftShowsPrec2 sp1 _ sp2 _ p (a :$: b) = - showsInfix sp1 sp2 ":$:" p 4 a b - liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyPlain a b) = - showsInfix sp1 sp2 "`TyFamilyPlain`" p 5 a b - liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyFakeInfix a b) = - showsBinaryWith sp1 sp2 "TyFamilyFakeInfix" p a b -instance Show2 TyFamilyGADT where - liftShowsPrec2 sp1 _ sp2 _ p (a :* b) = - showsInfix sp1 sp2 ":*" p 1 a b - liftShowsPrec2 sp1 _ sp2 _ p (a :** b) = - showsBinaryWith sp1 sp2 "(:**)" p a b - liftShowsPrec2 sp1 _ sp2 _ p ((:***) a b i) = - showsTernaryWith sp1 sp2 "(:***)" p a b i - liftShowsPrec2 sp1 _ sp2 _ p (a :**** b) = - showsBinaryWith sp1 sp2 "(:****)" p a b - -showsInfix :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) - -> String -> Int -> Int -> a -> b -> ShowS -showsInfix sp1 sp2 name p infixPrec a b = showParen (p > infixPrec) $ - sp1 (infixPrec + 1) a . showSpace - . showString name . showSpace - . sp2 (infixPrec + 1) b - -showsTernaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) - -> String -> Int -> a -> b -> Int -> ShowS -showsTernaryWith sp1 sp2 name p a b i = showParen (p > appPrec) $ - showString name . showSpace - . sp1 appPrec1 a . showSpace - . sp2 appPrec1 b . showSpace - . showsPrec appPrec1 i -#endif +# endif -#if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow '(:#:)) $(deriveTextShow1 '(:$:)) $(deriveTextShow2 'TyFamilyPlain) @@ -228,19 +199,7 @@ $(deriveTextShow '(:*)) $(deriveTextShow1 '(:***)) $(deriveTextShow2 '(:****)) -#endif -#if __GLASGOW_HASKELL__ < 706 -$(Generics.deriveMeta ''TyConPlain) -$(Generics.deriveRepresentable1 ''TyConPlain) -$(Generics.deriveAll0And1 ''TyConGADT) -#endif - -#if __GLASGOW_HASKELL__ < 702 -$(Generics.deriveRepresentable0 ''TyConPlain) -#endif - -#if MIN_VERSION_template_haskell(2,7,0) # if !defined(__LANGUAGE_DERIVE_GENERIC1__) $(Generics.deriveMeta '(:#:)) $(Generics.deriveRepresentable1 '(:$:)) diff --git a/tests/Derived/MagicHash.hs b/tests/Derived/MagicHash.hs --- a/tests/Derived/MagicHash.hs +++ b/tests/Derived/MagicHash.hs @@ -7,6 +7,10 @@ {-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +#endif + {-| Module: Derived.MagicHash Copyright: (C) 2014-2016 Ryan Scott @@ -34,17 +38,11 @@ import Test.QuickCheck (Arbitrary(..)) import Text.Show.Deriving (deriveShow1Options, legacyShowOptions) -import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) - #if defined(NEW_FUNCTOR_CLASSES) import Text.Show.Deriving (deriveShow2Options) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (Show1(..), Show2(..)) -import GHC.Show (showSpace) -import GHC.Show (appPrec) -# endif #endif +import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) ------------------------------------------------------------------------------- data TyCon# a b = TyCon# { @@ -116,60 +114,23 @@ $(deriveTextShow1 ''TyCon#) $(deriveTextShow2 ''TyCon#) -#if !defined(NEW_FUNCTOR_CLASSES) +#if __GLASGOW_HASKELL__ < 711 +$(Generics.deriveAll0And1 ''TyCon#) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1Options legacyShowOptions 'TyFamily#) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1Options legacyShowOptions 'TyFamily#) $(deriveShow2Options legacyShowOptions 'TyFamily#) -#else -instance Show a => Show1 (TyFamily# a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Show2 TyFamily# where - liftShowsPrec2 sp1 _ sp2 _ p (TyFamily# a b i f d c w) = - showsHash sp1 sp2 "TyFamily#" "tfA" "tfB" "tfInt#" "tfFloat#" - "tfDouble#" "tfChar#" "tfWord#" p a b i f d c w - -showsHash :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) - -> String -> String -> String -> String -> String -> String -> String -> String - -> Int -> a -> b -> Int# -> Float# -> Double# -> Char# -> Word# - -> ShowS -showsHash sp1 sp2 con rec1 rec2 rec3 rec4 rec5 rec6 rec7 p a b i f d c w = - showParen (p > appPrec) $ - showString con . showSpace - . showChar '{' - . showString rec1 . equals . sp1 0 a . comma - . showString rec2 . equals . sp2 0 b . comma - . showString rec3 . equals . shows (I# i) . oneHash . comma - . showString rec4 . equals . shows (F# f) . oneHash . comma - . showString rec5 . equals . shows (D# d) . twoHash . comma - . showString rec6 . equals . shows (C# c) . oneHash . comma - . showString rec7 . equals . shows (W# w) . twoHash - . showChar '}' - where - comma, equals :: ShowS - comma = showString ", " - equals = showString " = " - - oneHash, twoHash :: ShowS -# if __GLASGOW_HASKELL__ >= 711 - oneHash = showChar '#' - twoHash = showString "##" -# else - oneHash = id - twoHash = id # endif -#endif -#if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'TyFamily#) $(deriveTextShow1 'TyFamily#) $(deriveTextShow2 'TyFamily#) -#endif -#if __GLASGOW_HASKELL__ < 711 -$(Generics.deriveAll0And1 ''TyCon#) -# if MIN_VERSION_template_haskell(2,7,0) +# if __GLASGOW_HASKELL__ < 711 $(Generics.deriveAll0And1 'TyFamily#) # endif #endif diff --git a/tests/Derived/PolyKinds.hs b/tests/Derived/PolyKinds.hs --- a/tests/Derived/PolyKinds.hs +++ b/tests/Derived/PolyKinds.hs @@ -57,18 +57,15 @@ #if defined(NEW_FUNCTOR_CLASSES) import Data.Functor.Classes (Show2(..)) import Text.Show.Deriving (deriveShow2, makeLiftShowsPrec, makeLiftShowsPrec2) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (showsUnaryWith) -import GHC.Show (appPrec, appPrec1, showSpace) -# endif #else import Text.Show.Deriving (makeShowsPrec1) #endif ------------------------------------------------------------------------------- -newtype TyConCompose f g h j k a b = - TyConCompose (f (g (j a) (k a)) (h (j a) (k b))) +-- NB: Don't use k as a type variable here! It'll trigger GHC Trac #12503. +newtype TyConCompose f g h j p a b = + TyConCompose (f (g (j a) (p a)) (h (j a) (p b))) #if __GLASGOW_HASKELL__ >= 702 deriving Generic #endif @@ -267,7 +264,31 @@ instance TextShow2 (f a b c) => TextShow2 (TyConReallyHighKinds f a b c) where liftShowbPrec2 = $(makeLiftShowbPrec2 ''TyConReallyHighKinds) -#if !defined(NEW_FUNCTOR_CLASSES) +#if !defined(__LANGUAGE_DERIVE_GENERIC1__) +$(Generics.deriveMeta ''TyConCompose) +$(Generics.deriveRep1Options False ''TyConCompose) + +instance ( Functor (f (g (j a) (k a))) + , Functor (h (j a)) + ) => Generic1 (TyConCompose f g h j k a) where + type Rep1 (TyConCompose f g h j k a) = $(Generics.makeRep1 ''TyConCompose) f g h j k a + from1 = $(Generics.makeFrom1 ''TyConCompose) + to1 = $(Generics.makeTo1 ''TyConCompose) + +$(Generics.deriveMeta ''TyConProxy) +$(Generics.deriveRepresentable1 ''TyConProxy) +$(Generics.deriveMeta ''TyConReallyHighKinds) +$(Generics.deriveRepresentable1 ''TyConReallyHighKinds) +#endif + +#if __GLASGOW_HASKELL__ < 702 +$(Generics.deriveRepresentable0 ''TyConCompose) +$(Generics.deriveRepresentable0 ''TyConProxy) +$(Generics.deriveRepresentable0 ''TyConReallyHighKinds) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) instance (Functor (f (g (j a) (k a))), Functor (h (j a)), Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) => Show1 (TyFamilyCompose f g h j k a) where @@ -276,7 +297,7 @@ showsPrec1 = $(makeShowsPrec1 'TyFamilyProxy) instance Show1 (f a b c d) => Show1 (TyFamilyReallyHighKinds f a b c d) where showsPrec1 = $(makeShowsPrec1 'TyFamilyReallyHighKinds) -#elif MIN_VERSION_template_haskell(2,7,0) +# else instance (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) => Show1 (TyFamilyCompose f g h j k a) where liftShowsPrec = $(makeLiftShowsPrec 'TyFamilyCompose) @@ -292,66 +313,8 @@ liftShowsPrec2 = $(makeLiftShowsPrec2 'TyFamilyProxy) instance Show2 (f a b c) => Show2 (TyFamilyReallyHighKinds f a b c) where liftShowsPrec2 = $(makeLiftShowsPrec2 'TyFamilyReallyHighKinds) -#else -instance (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) => - Show1 (TyFamilyCompose f g h j k a) where - liftShowsPrec sp sl p (TyFamilyCompose x) = - showsPrecCompose sp sl "TyFamilyCompose" p x -instance Show1 (TyFamilyProxy (a :: *)) where - liftShowsPrec = liftShowsPrec2 undefined undefined -instance Show1 (f a b c d) => Show1 (TyFamilyReallyHighKinds f a b c d) where - liftShowsPrec sp sl p (TyFamilyReallyHighKinds x) = - showsUnaryWith (liftShowsPrec sp sl) "TyFamilyReallyHighKinds" p x - -instance (Show2 f, Show2 g, Show2 h, Show1 j, Show1 k) => - Show2 (TyFamilyCompose f g h j k) where - liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamilyCompose x) = - showsPrecCompose2 sp1 sl1 sp2 sl2 "TyFamilyCompose" p x -instance Show2 TyFamilyProxy where - liftShowsPrec2 _ _ _ _ p (TyFamilyProxy x) = showParen (p > appPrec) $ - showString "TyFamilyProxy " - . showsPrec appPrec1 x -instance Show2 (f a b c) => Show2 (TyFamilyReallyHighKinds f a b c) where - liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamilyReallyHighKinds x) = - showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "TyFamilyReallyHighKinds" p x - -showsPrecCompose :: (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) - => (Int -> b -> ShowS) -> ([b] -> ShowS) - -> String -> Int -> f (g (j a) (k a)) (h (j a) (k b)) -> ShowS -showsPrecCompose sp sl name p x = showParen (p > appPrec) $ - showString name . showSpace - . liftShowsPrec (liftShowsPrec (liftShowsPrec sp sl) - (liftShowList sp sl)) - (liftShowList (liftShowsPrec sp sl) - (liftShowList sp sl)) - appPrec1 x - -showsPrecCompose2 :: (Show2 f, Show2 g, Show2 h, Show1 j, Show1 k) - => (Int -> a -> ShowS) -> ([a] -> ShowS) - -> (Int -> b -> ShowS) -> ([b] -> ShowS) - -> String -> Int -> f (g (j a) (k a)) (h (j a) (k b)) -> ShowS -showsPrecCompose2 sp1 sl1 sp2 sl2 name p x = showParen (p > appPrec) $ - showString name . showSpace - . liftShowsPrec2 (liftShowsPrec2 (liftShowsPrec sp1 sl1) - (liftShowList sp1 sl1) - (liftShowsPrec sp1 sl1) - (liftShowList sp1 sl1)) - (liftShowList2 (liftShowsPrec sp1 sl1) - (liftShowList sp1 sl1) - (liftShowsPrec sp1 sl1) - (liftShowList sp1 sl1)) - (liftShowsPrec2 (liftShowsPrec sp1 sl1) - (liftShowList sp1 sl1) - (liftShowsPrec sp2 sl2) - (liftShowList sp2 sl2)) - (liftShowList2 (liftShowsPrec sp1 sl1) - (liftShowList sp1 sl1) - (liftShowsPrec sp2 sl2) - (liftShowList sp2 sl2)) - appPrec1 x -#endif +# endif -#if MIN_VERSION_template_haskell(2,7,0) instance TextShow (f (g (j a) (k a)) (h (j a) (k b))) => TextShow (TyFamilyCompose f g h j k a b) where showbPrec = $(makeShowbPrec 'TyFamilyCompose) @@ -372,35 +335,10 @@ liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyReallyHighKinds) instance TextShow2 (f a b c) => TextShow2 (TyFamilyReallyHighKinds f a b c) where liftShowbPrec2 = $(makeLiftShowbPrec2 'TyFamilyReallyHighKinds) -#endif -#if !defined(__LANGUAGE_DERIVE_GENERIC1__) -$(Generics.deriveMeta ''TyConCompose) -$(Generics.deriveRep1 ''TyConCompose) - -instance ( Functor (f (g (j a) (k a))) - , Functor (h (j a)) - ) => Generic1 (TyConCompose f g h j k a) where - type Rep1 (TyConCompose f g h j k a) = $(Generics.makeRep1 ''TyConCompose) f g h j k a - from1 = $(Generics.makeFrom1 ''TyConCompose) - to1 = $(Generics.makeTo1 ''TyConCompose) - -$(Generics.deriveMeta ''TyConProxy) -$(Generics.deriveRepresentable1 ''TyConProxy) -$(Generics.deriveMeta ''TyConReallyHighKinds) -$(Generics.deriveRepresentable1 ''TyConReallyHighKinds) -#endif - -#if __GLASGOW_HASKELL__ < 702 -$(Generics.deriveRepresentable0 ''TyConCompose) -$(Generics.deriveRepresentable0 ''TyConProxy) -$(Generics.deriveRepresentable0 ''TyConReallyHighKinds) -#endif - -#if MIN_VERSION_template_haskell(2,7,0) # if !defined(__LANGUAGE_DERIVE_GENERIC1__) -$(Generics.deriveMeta 'TyFamilyCompose) -$(Generics.deriveRep1 'TyFamilyCompose) +$(Generics.deriveMeta 'TyFamilyCompose) +$(Generics.deriveRep1Options False 'TyFamilyCompose) instance ( Functor (f (g (j a) (k a))) , Functor (h (j a)) diff --git a/tests/Derived/RankNTypes.hs b/tests/Derived/RankNTypes.hs --- a/tests/Derived/RankNTypes.hs +++ b/tests/Derived/RankNTypes.hs @@ -35,9 +35,6 @@ #if defined(NEW_FUNCTOR_CLASSES) import Data.Functor.Classes (Show2(..)) import Text.Show.Deriving (deriveShow2, makeLiftShowsPrec, makeLiftShowsPrec2) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (showsBinaryWith) -# endif #else import Text.Show.Deriving (makeShowsPrec1) #endif @@ -103,32 +100,14 @@ $(deriveTextShow1 ''TyCon) $(deriveTextShow2 ''TyCon) -#if !defined(NEW_FUNCTOR_CLASSES) +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1 'TyFamily) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1 'TyFamily) $(deriveShow2 'TyFamily) -#else -instance Show a => Show1 (TyFamily a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Show2 TyFamily where - liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamily b a) = - showsForall sp1 sl1 sp2 sl2 "TyFamily" p b a - -showsForall :: (Int -> a -> ShowS) -> ([a] -> ShowS) - -> (Int -> b -> ShowS) -> ([b] -> ShowS) - -> String -> Int - -> (forall a. Tagged2 a Int b) - -> (forall b. Tagged2 b a a) - -> ShowS -showsForall sp1 sl1 sp2 sl2 name p b a = - showsBinaryWith (liftShowsPrec2 showsPrec showList sp2 sl2) - (liftShowsPrec2 sp1 sl1 sp1 sl1) - name p b a -#endif +# endif -#if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'TyFamily) $(deriveTextShow1 'TyFamily) $(deriveTextShow2 'TyFamily) diff --git a/tests/Derived/Records.hs b/tests/Derived/Records.hs --- a/tests/Derived/Records.hs +++ b/tests/Derived/Records.hs @@ -6,6 +6,10 @@ {-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +#endif + {-| Module: Derived.Records Copyright: (C) 2014-2016 Ryan Scott @@ -37,17 +41,12 @@ import Test.QuickCheck (Arbitrary(..), oneof) import Text.Show.Deriving (deriveShow1) -import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) - #if defined(NEW_FUNCTOR_CLASSES) import Text.Show.Deriving (deriveShow2) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (Show1(..), Show2(..)) -import GHC.Show (showSpace) -import GHC.Show (appPrec) -# endif #endif +import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) + ------------------------------------------------------------------------------- infixl 4 :@: @@ -110,33 +109,14 @@ $(Generics.deriveRepresentable0 ''TyCon) #endif -#if !defined(NEW_FUNCTOR_CLASSES) +#if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) $(deriveShow1 'TyFamilyPrefix) -#elif MIN_VERSION_template_haskell(2,7,0) +# else $(deriveShow1 'TyFamilyPrefix) $(deriveShow2 '(:!:)) -#else -instance Show a => Show1 (TyFamily a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Show2 TyFamily where - liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyPrefix a b) = - showsRecord sp1 sp2 "TyFamilyPrefix" "tf1" "tf2" p a b - liftShowsPrec2 sp1 _ sp2 _ p (a :!: b) = - showsRecord sp2 sp1 "(:!:)" "tf3" "tf4" p a b - -showsRecord :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) - -> String -> String -> String -> Int -> a -> b -> ShowS -showsRecord sp1 sp2 con rec1 rec2 p a b = - showParen (p > appPrec) $ - showString con . showSpace - . showChar '{' - . showString rec1 . showString " = " . sp1 0 a . showString ", " - . showString rec2 . showString " = " . sp2 0 b - . showChar '}' -#endif +# endif -#if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'TyFamilyPrefix) $(deriveTextShow1 '(:!:)) $(deriveTextShow2 'TyFamilyPrefix) diff --git a/tests/Derived/TypeSynonyms.hs b/tests/Derived/TypeSynonyms.hs --- a/tests/Derived/TypeSynonyms.hs +++ b/tests/Derived/TypeSynonyms.hs @@ -7,6 +7,10 @@ {-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +#endif + {-# OPTIONS_GHC -fno-warn-orphans #-} {-| @@ -39,15 +43,12 @@ import Test.QuickCheck (Arbitrary) import Text.Show.Deriving (deriveShow1) -import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) - #if defined(NEW_FUNCTOR_CLASSES) import Text.Show.Deriving (deriveShow2) -# if !(MIN_VERSION_template_haskell(2,7,0)) -import Data.Functor.Classes (Show1(..), Show2(..), showsUnaryWith) -# endif #endif +import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) + ------------------------------------------------------------------------------- type FakeOut a = Int @@ -113,42 +114,6 @@ $(deriveTextShow1 ''TyCon) $(deriveTextShow2 ''TyCon) -#if !defined(NEW_FUNCTOR_CLASSES) -$(deriveShow1 'TyFamily) -#elif MIN_VERSION_template_haskell(2,7,0) -$(deriveShow1 'TyFamily) -$(deriveShow2 'TyFamily) -#else -instance Show a => Show1 (TyFamily a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Show2 TyFamily where - liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamily x) = - showsTypeSynonym sp1 sl1 sp2 sl2 "TyFamily" p x - -showsTypeSynonym :: (Int -> a -> ShowS) -> ([a] -> ShowS) - -> (Int -> b -> ShowS) -> ([b] -> ShowS) - -> String -> Int - -> ( Id (FakeOut (Id a)) - , Id (FakeOut (Id b)) - , Id (Flip Either (Id a) (Id Int)) - , Id (Flip Either (Id b) (Id a)) - ) - -> ShowS -showsTypeSynonym sp1 sl1 sp2 sl2 name p x = - showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 showsPrec showList sp1 sl1) - (liftShowList2 showsPrec showList sp1 sl1) - (liftShowsPrec2 sp1 sl1 sp2 sl2) - (liftShowList2 sp1 sl1 sp2 sl2) - ) name p x -#endif - -#if MIN_VERSION_template_haskell(2,7,0) -$(deriveTextShow 'TyFamily) -$(deriveTextShow1 'TyFamily) -$(deriveTextShow2 'TyFamily) -#endif - #if __GLASGOW_HASKELL__ < 706 $(Generics.deriveMeta ''TyCon) $(Generics.deriveRepresentable1 ''TyCon) @@ -159,6 +124,17 @@ #endif #if MIN_VERSION_template_haskell(2,7,0) +# if !defined(NEW_FUNCTOR_CLASSES) +$(deriveShow1 'TyFamily) +# else +$(deriveShow1 'TyFamily) +$(deriveShow2 'TyFamily) +# endif + +$(deriveTextShow 'TyFamily) +$(deriveTextShow1 'TyFamily) +$(deriveTextShow2 'TyFamily) + # if !defined(__LANGUAGE_DERIVE_GENERIC1__) $(Generics.deriveMeta 'TyFamily) $(Generics.deriveRepresentable1 'TyFamily) diff --git a/tests/Instances/GHC/Stats.hs b/tests/Instances/GHC/Stats.hs --- a/tests/Instances/GHC/Stats.hs +++ b/tests/Instances/GHC/Stats.hs @@ -28,4 +28,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +# if __GLASGOW_HASKELL__ >= 801 + <*> arbitrary +# endif #endif diff --git a/tests/Instances/Options.hs b/tests/Instances/Options.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Options.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: Instances.Options +Copyright: (C) 2014-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Arbitrary' instance for 'Options' and related datatypes. +-} +module Instances.Options () where + +import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum) +import TextShow.TH (Options(..), GenTextMethods) + +deriving instance Arbitrary Options + +instance Arbitrary GenTextMethods where + arbitrary = arbitraryBoundedEnum diff --git a/tests/Spec/OptionsSpec.hs b/tests/Spec/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/OptionsSpec.hs @@ -0,0 +1,32 @@ +{-| +Module: Spec.OptionsSpec +Copyright: (C) 2014-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ tests for 'Options' and related datatypes. +-} +module Spec.OptionsSpec (main, spec) where + +import Instances.Options () + +import Spec.Utils (prop_matchesTextShow, prop_genericTextShow) + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.Hspec.QuickCheck (prop) + +import TextShow.TH (Options, GenTextMethods) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do + describe "Options" $ do + prop "TextShow instance" (prop_matchesTextShow :: Int -> Options -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> Options -> Bool) + describe "GenTextMethods" $ do + prop "TextShow instance" (prop_matchesTextShow :: Int -> GenTextMethods -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> GenTextMethods -> Bool) diff --git a/tests/Spec/Utils.hs b/tests/Spec/Utils.hs --- a/tests/Spec/Utils.hs +++ b/tests/Spec/Utils.hs @@ -48,18 +48,18 @@ ioProperty = morallyDubiousIOProperty #endif --- | Verifies that a type's @Show@ instances coincide for both 'String's and 'Text', +-- | Verifies that a type's 'Show' instances coincide for both 'String's and 'Text', -- irrespective of precedence. prop_matchesTextShow :: (Show a, TextShow a) => Int -> a -> Bool prop_matchesTextShow p x = fromString (showsPrec p x "") == showbPrec p x --- | Verifies that a type's @Show1@ instances coincide for both 'String's and 'Text', +-- | Verifies that a type's 'Show1' instances coincide for both 'String's and 'Text', -- irrespective of precedence. prop_matchesTextShow1 :: (Show1 f, Show a, TextShow1 f, TextShow a) => Int -> f a -> Bool prop_matchesTextShow1 p x = fromString (showsPrec1 p x "") == showbPrec1 p x #if defined(NEW_FUNCTOR_CLASSES) --- | Verifies that a type's @Show2@ instances coincide for both 'String's and 'Text', +-- | Verifies that a type's 'Show2' instances coincide for both 'String's and 'Text', -- irrespective of precedence. prop_matchesTextShow2 :: (Show2 f, Show a, Show b, TextShow2 f, TextShow a, TextShow b) => Int -> f a b -> Bool @@ -68,14 +68,14 @@ -- | Verifies that a type's 'TextShow' instance coincides with the output produced -- by the equivalent 'Generic' functions. -prop_genericTextShow :: (TextShow a, Generic a, GTextShow Zero (Rep a)) +prop_genericTextShow :: (TextShow a, Generic a, GTextShowB Zero (Rep a)) => Int -> a -> Bool prop_genericTextShow p x = showbPrec p x == genericShowbPrec p x -- | Verifies that a type's 'TextShow1' instance coincides with the output produced -- by the equivalent 'Generic1' functions. prop_genericTextShow1 :: ( TextShow1 f, Generic1 f - , GTextShow One (Rep1 f), TextShow a + , GTextShowB One (Rep1 f), TextShow a ) => Int -> f a -> Bool prop_genericTextShow1 p x = diff --git a/text-show.cabal b/text-show.cabal --- a/text-show.cabal +++ b/text-show.cabal @@ -1,5 +1,5 @@ name: text-show -version: 3.3 +version: 3.4 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 @@ -157,6 +157,7 @@ TextShow.Data.Typeable.Utils TextShow.FromStringTextShow TextShow.Instances + TextShow.Options TextShow.TH.Internal TextShow.TH.Names TextShow.Utils @@ -167,7 +168,7 @@ , bytestring-builder , containers >= 0.1 && < 0.6 , contravariant >= 0.5 && < 2 - , generic-deriving >= 1.9 && < 2 + , generic-deriving >= 1.11 && < 2 , ghc-prim , integer-gmp , nats >= 0.1 && < 2 @@ -244,6 +245,7 @@ Instances.Generic Instances.GHC.Generics Instances.Numeric.Natural + Instances.Options Instances.System.Exit Instances.System.IO Instances.System.Posix.Types @@ -324,6 +326,7 @@ Spec.GenericSpec Spec.GHC.GenericsSpec Spec.Numeric.NaturalSpec + Spec.OptionsSpec Spec.System.ExitSpec Spec.System.IOSpec Spec.System.Posix.TypesSpec @@ -368,7 +371,7 @@ , containers >= 0.1 && < 0.6 , contravariant >= 0.5 && < 2 , deriving-compat >= 0.3 && < 1 - , generic-deriving >= 1.10.3 && < 2 + , generic-deriving >= 1.11 && < 2 , ghc-prim , hspec >= 2 && < 3 , integer-gmp @@ -403,7 +406,7 @@ if flag(developer) hs-source-dirs: src else - build-depends: text-show == 3.3 + build-depends: text-show == 3.4 hs-source-dirs: tests default-language: Haskell2010 @@ -416,7 +419,11 @@ benchmark bench -- This SHOULD build with 7.4, but criterion goofed: -- https://github.com/bos/criterion/pull/99 - if impl(ghc < 7.6) + -- + -- It should ALSO run with 7.6, but doing so triggers a bug that occurs + -- due to GHC 7.6 shipping with an old version of binary: + -- https://github.com/bos/criterion/pull/112 + if impl(ghc < 7.8) buildable: False type: exitcode-stdio-1.0 @@ -430,7 +437,7 @@ , contravariant >= 0.5 && < 2 , criterion >= 1 && < 2 , deepseq >= 1.3 && < 2 - , generic-deriving >= 1.9 && < 2 + , generic-deriving >= 1.11 && < 2 , ghc-prim , integer-gmp , nats >= 0.1 && < 2 @@ -462,7 +469,7 @@ if flag(developer) hs-source-dirs: src else - build-depends: text-show == 3.3 + build-depends: text-show == 3.4 hs-source-dirs: benchmarks default-language: Haskell2010