text-show 3.3 → 3.4
raw patch · 29 files changed
+1095/−780 lines, 29 filesdep ~generic-derivingdep ~text-show
Dependency ranges changed: generic-deriving, text-show
Files
- CHANGELOG.md +13/−0
- benchmarks/Bench.hs +4/−2
- src/TextShow.hs +27/−7
- src/TextShow/Classes.hs +174/−14
- src/TextShow/Data/Floating.hs +1/−1
- src/TextShow/Data/Integral.hs +11/−0
- src/TextShow/Data/List.hs +3/−3
- src/TextShow/Data/Proxy.hs +7/−2
- src/TextShow/Data/Tuple.hs +0/−1
- src/TextShow/Debug/Trace/Generic.hs +4/−4
- src/TextShow/FromStringTextShow.hs +1/−1
- src/TextShow/Generic.hs +273/−200
- src/TextShow/Options.hs +110/−0
- src/TextShow/TH.hs +8/−0
- src/TextShow/TH/Internal.hs +260/−125
- tests/Derived/DataFamilies.hs +8/−37
- tests/Derived/DatatypeContexts.hs +11/−32
- tests/Derived/ExistentialQuantification.hs +7/−36
- tests/Derived/Infix.hs +20/−61
- tests/Derived/MagicHash.hs +13/−52
- tests/Derived/PolyKinds.hs +32/−94
- tests/Derived/RankNTypes.hs +4/−25
- tests/Derived/Records.hs +10/−30
- tests/Derived/TypeSynonyms.hs +17/−41
- tests/Instances/GHC/Stats.hs +3/−0
- tests/Instances/Options.hs +23/−0
- tests/Spec/OptionsSpec.hs +32/−0
- tests/Spec/Utils.hs +5/−5
- text-show.cabal +14/−7
CHANGELOG.md view
@@ -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
benchmarks/Bench.hs view
@@ -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
src/TextShow.hs view
@@ -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)
src/TextShow/Classes.hs view
@@ -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)
src/TextShow/Data/Floating.hs view
@@ -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"
src/TextShow/Data/Integral.hs view
@@ -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
src/TextShow/Data/List.hs view
@@ -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 ()
src/TextShow/Data/Proxy.hs view
@@ -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)
src/TextShow/Data/Tuple.hs view
@@ -42,7 +42,6 @@ -- -- /Since: 2/ showbUnit :: () -> Builder--- showbUnit () = "()" showbUnit = showb -- | Converts a 2-tuple into a 'Builder' with the given show functions.
src/TextShow/Debug/Trace/Generic.hs view
@@ -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
src/TextShow/FromStringTextShow.hs view
@@ -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
src/TextShow/Generic.hs view
@@ -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)
+ src/TextShow/Options.hs view
@@ -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
src/TextShow/TH.hs view
@@ -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)
src/TextShow/TH/Internal.hs view
@@ -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
tests/Derived/DataFamilies.hs view
@@ -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
tests/Derived/DatatypeContexts.hs view
@@ -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
tests/Derived/ExistentialQuantification.hs view
@@ -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)
tests/Derived/Infix.hs view
@@ -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 '(:$:))
tests/Derived/MagicHash.hs view
@@ -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
tests/Derived/PolyKinds.hs view
@@ -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))
tests/Derived/RankNTypes.hs view
@@ -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)
tests/Derived/Records.hs view
@@ -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)
tests/Derived/TypeSynonyms.hs view
@@ -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)
tests/Instances/GHC/Stats.hs view
@@ -28,4 +28,7 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+# if __GLASGOW_HASKELL__ >= 801+ <*> arbitrary+# endif #endif
+ tests/Instances/Options.hs view
@@ -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
+ tests/Spec/OptionsSpec.hs view
@@ -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)
tests/Spec/Utils.hs view
@@ -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 =
text-show.cabal view
@@ -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