diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,23 @@ +# 3 +* GHC 8.0 support +* The functions `showt`, `showtl`, `showtPrec`, `showtlPrec`, `showtList`, and `showtlList` are now part of the `TextShow` class. This was done to allow overriding their definitions with more efficient versions specifically for strict or lazy `Text`. (Currently, no `TextShow` instance in the `text-show` package does this, but this may change in the future.) +* Added the `TextShow.Data.Functor.Compose`, `TextShow.Data.Functor.Product`, `TextShow.Data.Functor.Sum`, and `TextShow.Data.Semigroup` modules +* Added `TextShow` instance for `TypeError` in `TextShow.Control.Exception` (GHC 8.0+) +* Added `TextShow` instances for `TrName` and `Module` in `TextShow.Data.Typeable` (GHC 8.0+) +* Added `Lift` instances for the datatypes in `TextShow` and `TextShow.Generic` +* Renamed the class methods of `TextShow1` and `TextShow2` to be consistent with the naming conventions of `transformers-0.5`. They following were renamed: + * `showbPrecWith` → `liftShowbPrec` + * `showbPrecWith2` → `liftShowbPrec2` + * `makeShowbPrecWith` → `makeLiftShowbPrec` + * `makeShowbPrecWith2` → `makeLiftShowbPrec2` + * `genericShowbPrecWith` → `genericLiftShowbPrec` + + In addition, many other monomorphic functions from the various `TextShow` submodules were also renamed to be consistent with the new `lift-` prefix. +* `showsToShowb` and `showbToShows` now only convert functions that ignore precedence (i.e., of type `a -> ShowS` or `a -> Builder`). Their former role has been given to the new functions `showsPrecToShowbPrec` and `showbPrecToShowsPrec` +* Added `FromStringShow1`, `FromTextShow1`, `FromStringShow2`, and `FromTextShow2`, which allow defining string `Show1`/`Show2` instances in terms of `TextShow1`/`TextShow2` instances, and vice versa. Be aware that many of these instances cannot be provided if you are using `tranformers-0.4`, since its version of `Data.Functor.Classes` uses a very differenltly designed `Show1` typeclass (and does not have `Show2` at all). +* Rewrote `TextShow.TH`'s type inferencer. This avoids a nasty GHC 7.8 bug, and it allows `TextShow(1)(2)` to be derived for more datatypes that can only be expressed with `-XTypeInType` enabled. +* Reworked internals of `TextShow.Generic`. Empty datatypes can now be have generic `TextShow` and `TextShow1` instances. + # 2.1.2 * Fixed GHC 7.10.3 build * Extended `TextShow.Generic` to allow `genericShowbPrec` (and friends) to be used on `Generic` datatypes with `Char#`, `Double#`, `Float#`, `Int#`, and `Word#` argument types, just like string `Show` does @@ -20,78 +40,78 @@ # 2 * Changed the top-level module name from `Text.Show.Text` to `TextShow`, since the former was extremely verbose without much benefit. As a result, this will break all existing code that depends on `text-show`. * Several typeclasses and functions were renamed so as to not to clash with the `Prelude`: - * `Show` → `TextShow` - * `Show1` → `TextShow1` - * `Show2` → `TextShow2` - * `show` → `showt` - * `showLazy` → `showtl` - * `showPrec` → `showtPrec` - * `showPrecLazy` → `showtlPrec` - * `showList` → `showtList` - * `showListLazy` → `showtlList` - * `print` → `printT` - * `printLazy` → `printTL` - * `hPrint` → `hPrintT` - * `hPrintLazy` → `hPrintTL` - * `GShow` → `GTextShow` - * `GShow1` → `GTextShow1` - * `genericShow` → `genericShowt` - * `genericShowLazy` → `genericShowtl` - * `genericShowPrec` → `genericShowtPrec` - * `genericShowPrecLazy` → `genericShowtlPrec` - * `genericShowList` → `genericShowtList` - * `genericShowListLazy` → `genericShowtlList` - * `genericPrint` → `genericPrintT` - * `genericPrintLazy` → `genericPrintTL` - * `genericHPrint` → `genericHPrintT` - * `genericHPrintLazy` → `genericHPrintTL` - * `deriveShow` → `deriveTextShow` - * `deriveShow1` → `deriveTextShow1` - * `deriveShow2` → `deriveTextShow2` - * `mkShow` → `makeShowt` - * `mkShowLazy` → `makeShowtl` - * `mkShowPrec` → `makeShowtPrec` - * `mkShowPrecLazy` → `makeShowtlPrec` - * `mkShowList` → `makeShowtList` - * `mkShowListLazy` → `makeShowtlList` - * `mkShowb` → `makeShowb` - * `mkShowbPrec` → `makeShowbPrec` - * `mkShowbList` → `makeShowbList` - * `mkPrint` → `makePrintT` - * `mkPrintLazy` → `makePrintTL` - * `mkHPrint` → `makeHPrintT` - * `mkHPrintLazy` → `makeHPrintTL` - * `mkShowbPrecWith` → `makeShowbPrecWith` - * `mkShowbPrec1` → `makeShowbPrec1` - * `mkShowbPrecWith2` → `makeShowbPrecWith2` - * `mkShowbPrec2` → `makeShowbPrec2` - * `trace` → `tracet` - * `traceLazy` → `tracetl` - * `traceId` → `tracetId` - * `traceIdLazy` → `tracetlId` - * `traceShow` → `traceTextShow` - * `traceShowId` → `traceTextShowId` - * `traceStack` → `tracetStack` - * `traceStackLazy` → `tracetlStack` - * `traceIO` → `tracetIO` - * `traceIOLazy` → `tracetlIO` - * `traceM` → `tracetM` - * `traceMLazy` → `tracetlM` - * `traceShowM` → `traceTextShowM` - * `traceEvent` → `tracetEvent` - * `traceEventLazy` → `tracetlEvent` - * `traceEventIO` → `travetEventIO` - * `traceEventIOLazy` → `tracetlEventIO` - * `traceMarker` → `tracetMarker` - * `traceMarkerLazy` → `tracetlMarker` - * `traceMarkerIO` → `tracetMarkerIO` - * `traceMarkerIOLazy` → `tracetlMarkerIO` - * `genericTraceShow` → `genericTraceTextShow` - * `genericTraceShowId` → `genericTraceTextShowId` - * `genericTraceShowM` → `genericTraceTextShowM` - * `mkTraceShow` → `makeTraceTextShow` - * `mkTraceShowId` → `makeTraceTextShowId` - * `mkTraceShowM` → `makeTraceTextShowM` + * `Show` → `TextShow` + * `Show1` → `TextShow1` + * `Show2` → `TextShow2` + * `show` → `showt` + * `showLazy` → `showtl` + * `showPrec` → `showtPrec` + * `showPrecLazy` → `showtlPrec` + * `showList` → `showtList` + * `showListLazy` → `showtlList` + * `print` → `printT` + * `printLazy` → `printTL` + * `hPrint` → `hPrintT` + * `hPrintLazy` → `hPrintTL` + * `GShow` → `GTextShow` + * `GShow1` → `GTextShow1` + * `genericShow` → `genericShowt` + * `genericShowLazy` → `genericShowtl` + * `genericShowPrec` → `genericShowtPrec` + * `genericShowPrecLazy` → `genericShowtlPrec` + * `genericShowList` → `genericShowtList` + * `genericShowListLazy` → `genericShowtlList` + * `genericPrint` → `genericPrintT` + * `genericPrintLazy` → `genericPrintTL` + * `genericHPrint` → `genericHPrintT` + * `genericHPrintLazy` → `genericHPrintTL` + * `deriveShow` → `deriveTextShow` + * `deriveShow1` → `deriveTextShow1` + * `deriveShow2` → `deriveTextShow2` + * `mkShow` → `makeShowt` + * `mkShowLazy` → `makeShowtl` + * `mkShowPrec` → `makeShowtPrec` + * `mkShowPrecLazy` → `makeShowtlPrec` + * `mkShowList` → `makeShowtList` + * `mkShowListLazy` → `makeShowtlList` + * `mkShowb` → `makeShowb` + * `mkShowbPrec` → `makeShowbPrec` + * `mkShowbList` → `makeShowbList` + * `mkPrint` → `makePrintT` + * `mkPrintLazy` → `makePrintTL` + * `mkHPrint` → `makeHPrintT` + * `mkHPrintLazy` → `makeHPrintTL` + * `mkShowbPrecWith` → `makeShowbPrecWith` + * `mkShowbPrec1` → `makeShowbPrec1` + * `mkShowbPrecWith2` → `makeShowbPrecWith2` + * `mkShowbPrec2` → `makeShowbPrec2` + * `trace` → `tracet` + * `traceLazy` → `tracetl` + * `traceId` → `tracetId` + * `traceIdLazy` → `tracetlId` + * `traceShow` → `traceTextShow` + * `traceShowId` → `traceTextShowId` + * `traceStack` → `tracetStack` + * `traceStackLazy` → `tracetlStack` + * `traceIO` → `tracetIO` + * `traceIOLazy` → `tracetlIO` + * `traceM` → `tracetM` + * `traceMLazy` → `tracetlM` + * `traceShowM` → `traceTextShowM` + * `traceEvent` → `tracetEvent` + * `traceEventLazy` → `tracetlEvent` + * `traceEventIO` → `travetEventIO` + * `traceEventIOLazy` → `tracetlEventIO` + * `traceMarker` → `tracetMarker` + * `traceMarkerLazy` → `tracetlMarker` + * `traceMarkerIO` → `tracetMarkerIO` + * `traceMarkerIOLazy` → `tracetlMarkerIO` + * `genericTraceShow` → `genericTraceTextShow` + * `genericTraceShowId` → `genericTraceTextShowId` + * `genericTraceShowM` → `genericTraceTextShowM` + * `mkTraceShow` → `makeTraceTextShow` + * `mkTraceShowId` → `makeTraceTextShowId` + * `mkTraceShowM` → `makeTraceTextShowM` * Added `TextShow Lifetime` instance in `TextShow.GHC.Event` (if using `base-4.8.1.0` or later) * Generalized `tracetM`, `tracetlM`, and `traceTextShowM` to use an `Applicative` constraint instead of `Monad` * Fixed a bug in which the `TextShow(1)` instances for `Proxy`, `(:~:)`, and `Coercion` didn't use `-XPolyKinds` diff --git a/src/TextShow.hs b/src/TextShow.hs --- a/src/TextShow.hs +++ b/src/TextShow.hs @@ -14,12 +14,6 @@ -- * The @TextShow@ classes -- ** 'TextShow' TextShow(..) - , showt - , showtl - , showtPrec - , showtlPrec - , showtList - , showtlList , showbParen , showbSpace -- ** 'TextShow1' @@ -56,7 +50,13 @@ -- * Conversion between 'TextShow' and string @Show@ , FromStringShow(..) , FromTextShow(..) + , FromStringShow1(..) + , FromTextShow1(..) + , FromStringShow2(..) + , FromTextShow2(..) + , showsPrecToShowbPrec , showsToShowb + , showbPrecToShowsPrec , showbToShows ) where diff --git a/src/TextShow/Classes.hs b/src/TextShow/Classes.hs --- a/src/TextShow/Classes.hs +++ b/src/TextShow/Classes.hs @@ -65,70 +65,112 @@ -- /Since: 2/ showbPrec :: Int -- ^ The operator precedence of the enclosing context (a number -- from @0@ to @11@). Function application has precedence @10@. - -> a -- ^ The value to be converted to a 'String'. + -> a -- ^ The value to be converted to a 'Builder'. -> Builder showbPrec _ = showb - -- | A specialized variant of 'showbPrec' using precedence context zero. + -- | Converts a value to a strict 'TS.Text'. If you hand-define this, it should + -- satisfy: -- + -- @ + -- 'showb' = 'showbPrec' 0 + -- @ + -- -- /Since: 2/ - showb :: a -> Builder + showb :: a -- ^ The value to be converted to a 'Builder'. + -> Builder showb = showbPrec 0 - -- | Allows for specialized display of lists. This is used, for example, when - -- showing lists of 'Char's. + -- | Converts a list of values to a 'Builder'. By default, this is defined as + -- @'showbList = 'showbListWith' 'showb'@, but it can be overridden to allow + -- for specialized displaying of lists (e.g., lists of 'Char's). -- -- /Since: 2/ - showbList :: [a] -> Builder + showbList :: [a] -- ^ The list of values to be converted to a 'Builder'. + -> Builder showbList = showbListWith showb -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL showbPrec | showb #-} + -- | Converts a value to a strict 'TS.Text' with the given precedence. This + -- can be overridden for efficiency, but it should satisfy: + -- + -- @ + -- 'showtPrec' p = 'toStrict' . 'showtlPrec' p + -- @ + -- + -- /Since: 3/ + showtPrec :: Int -- ^ The operator precedence of the enclosing context (a number + -- from @0@ to @11@). Function application has precedence @10@. + -> a -- ^ The value to be converted to a strict 'TS.Text'. + -> TS.Text + showtPrec p = toStrict . showtlPrec p -deriving instance Typeable TextShow -#endif + -- | Converts a value to a strict 'TS.Text'. This can be overridden for + -- efficiency, but it should satisfy: + -- + -- @ + -- 'showt' = 'toStrict' . 'showtl' + -- @ + -- + -- /Since: 3/ + showt :: a -- ^ The value to be converted to a strict 'TS.Text'. + -> TS.Text + showt = toStrict . showtl --- | Constructs a strict 'TS.Text' from a single value. --- --- /Since: 2/ -showt :: TextShow a => a -> TS.Text -showt = toStrict . showtl -{-# INLINE showt #-} + -- | Converts a list of values to a strict 'TS.Text'. This can be overridden for + -- efficiency, but it should satisfy: + -- + -- @ + -- 'showtList' = 'toStrict' . 'showtlList' + -- @ + -- + -- /Since: 3/ + showtList :: [a] -- ^ The list of values to be converted to a strict 'TS.Text'. + -> TS.Text + showtList = toStrict . showtlList --- | Constructs a lazy 'TL.Text' from a single value. --- --- /Since: 2/ -showtl :: TextShow a => a -> TL.Text -showtl = toLazyText . showb -{-# INLINE showtl #-} + -- | Converts a value to a lazy 'TL.Text' with the given precedence. This + -- can be overridden for efficiency, but it should satisfy: + -- + -- @ + -- 'showtlPrec' p = 'toLazyText' . 'showbPrec' p + -- @ + -- + -- /Since: 3/ + showtlPrec :: Int -- ^ The operator precedence of the enclosing context (a number + -- from @0@ to @11@). Function application has precedence @10@. + -> a -- ^ The value to be converted to a lazy 'TL.Text'. + -> TL.Text + showtlPrec p = toLazyText . showbPrec p --- | Constructs a strict 'TS.Text' from a single value with the given precedence. --- --- /Since: 2/ -showtPrec :: TextShow a => Int -> a -> TS.Text -showtPrec p = toStrict . showtlPrec p -{-# INLINE showtPrec #-} + -- | Converts a value to a lazy 'TL.Text'. This can be overridden for + -- efficiency, but it should satisfy: + -- + -- @ + -- 'showtl' = 'toLazyText' . 'showb' + -- @ + -- + -- /Since: 3/ + showtl :: a -- ^ The value to be converted to a lazy 'TL.Text'. + -> TL.Text + showtl = toLazyText . showb --- | Constructs a lazy 'TL.Text' from a single value with the given precedence. --- --- /Since: 2/ -showtlPrec :: TextShow a => Int -> a -> TL.Text -showtlPrec p = toLazyText . showbPrec p -{-# INLINE showtlPrec #-} + -- | Converts a list of values to a lazy 'TL.Text'. This can be overridden for + -- efficiency, but it should satisfy: + -- + -- @ + -- 'showtlList' = 'toLazyText' . 'showbList' + -- @ + -- + -- /Since: 3/ + showtlList :: [a] -- ^ The list of values to be converted to a lazy 'TL.Text'. + -> TL.Text + showtlList = toLazyText . showbList --- | Construct a strict 'TS.Text' from a list of values. --- --- /Since: 2/ -showtList :: TextShow a => [a] -> TS.Text -showtList = toStrict . showtlList -{-# INLINE showtList #-} +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL showbPrec | showb #-} --- | Construct a lazy 'TL.Text' from a list of values. --- --- /Since: 2/ -showtlList :: TextShow a => [a] -> TL.Text -showtlList = toLazyText . showbList -{-# INLINE showtlList #-} +deriving instance Typeable TextShow +#endif -- | Surrounds 'Builder' output with parentheses if the 'Bool' parameter is 'True'. -- @@ -192,18 +234,32 @@ hPrintTL h = TL.hPutStrLn h . showtl {-# INLINE hPrintTL #-} +-- | 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. -- --- /Since: 2.1/ -showsToShowb :: (Int -> a -> ShowS) -> Int -> a -> Builder -showsToShowb sp p x = fromString $ sp p x "" +-- /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. +-- +-- /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. -- --- /Since: 2.1/ -showbToShows :: (Int -> a -> Builder) -> Int -> a -> ShowS -showbToShows sp p = showString . toString . sp p +-- /Since: 3/ +showbToShows :: (a -> Builder) -> a -> ShowS +showbToShows sl = showString . toString . sl {-# INLINE showbToShows #-} ------------------------------------------------------------------------------- @@ -212,20 +268,35 @@ -- -- /Since: 2/ class TextShow1 f where - -- | Lifts a 'showbPrec' function through the type constructor. + -- | 'showbPrec' function for an application of the type constructor + -- based on 'showbPrec' and 'showbList' functions for the argument type. -- - -- /Since: 2/ - showbPrecWith :: (Int -> a -> Builder) -> Int -> f a -> Builder + -- /Since: 3/ + liftShowbPrec :: (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> f a -> Builder + -- | 'showbList' function for an application of the type constructor + -- based on 'showbPrec' and 'showbList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + -- + -- /Since: 3/ + liftShowbList :: (Int -> a -> Builder) -> ([a] -> Builder) + -> [f a] -> Builder + liftShowbList sp sl = showbListWith (liftShowbPrec sp sl 0) + #if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL liftShowbPrec #-} + deriving instance Typeable TextShow1 #endif --- | Lift the standard 'showbPrec' function through the type constructor. +-- | Lift the standard 'showbPrec' and 'showbList' functions through the +-- type constructor. -- -- /Since: 2/ showbPrec1 :: (TextShow1 f, TextShow a) => Int -> f a -> Builder -showbPrec1 = showbPrecWith showbPrec +showbPrec1 = liftShowbPrec showbPrec showbList {-# INLINE showbPrec1 #-} -- | @'showbUnaryWith' sp n p x@ produces the 'Builder' representation of a unary data @@ -244,13 +315,29 @@ -- -- /Since: 2/ class TextShow2 f where - -- | Lifts 'showbPrec' functions through the type constructor. + -- | 'showbPrec' function for an application of the type constructor + -- based on 'showbPrec' and 'showbList' functions for the argument types. -- - -- /Since: 2/ - showbPrecWith2 :: (Int -> a -> Builder) -> (Int -> b -> Builder) -> - Int -> f a b -> Builder + -- /Since: 3/ + liftShowbPrec2 :: (Int -> a -> Builder) -> ([a] -> Builder) + -> (Int -> b -> Builder) -> ([b] -> Builder) + -> Int -> f a b -> Builder + -- | 'showbList' function for an application of the type constructor + -- based on 'showbPrec' and 'showbList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + -- + -- /Since: 3/ + liftShowbList2 :: (Int -> a -> Builder) -> ([a] -> Builder) + -> (Int -> b -> Builder) -> ([b] -> Builder) + -> [f a b] -> Builder + liftShowbList2 sp1 sl1 sp2 sl2 = + showbListWith (liftShowbPrec2 sp1 sl1 sp2 sl2 0) + #if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL liftShowbPrec2 #-} + deriving instance Typeable TextShow2 #endif @@ -258,7 +345,7 @@ -- -- /Since: 2/ showbPrec2 :: (TextShow2 f, TextShow a, TextShow b) => Int -> f a b -> Builder -showbPrec2 = showbPrecWith2 showbPrec showbPrec +showbPrec2 = liftShowbPrec2 showbPrec showbList showbPrec showbList {-# INLINE showbPrec2 #-} -- | @'showbBinaryWith' sp n p x y@ produces the 'Builder' representation of a binary diff --git a/src/TextShow/Control/Applicative.hs b/src/TextShow/Control/Applicative.hs --- a/src/TextShow/Control/Applicative.hs +++ b/src/TextShow/Control/Applicative.hs @@ -13,37 +13,37 @@ /Since: 2/ -} -module TextShow.Control.Applicative (showbConstPrecWith, showbZipListPrecWith) where +module TextShow.Control.Applicative (liftShowbConstPrec, liftShowbZipListPrec) where import Control.Applicative (Const(..), ZipList) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showbPrec), TextShow1(..), +import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..), showbUnaryWith) import TextShow.Data.List () import TextShow.TH.Internal (deriveTextShow, deriveTextShow1) -- | Convert a 'Const' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbConstPrecWith :: (Int -> a -> Builder) -> Int -> Const a b -> Builder -showbConstPrecWith sp = showbPrecWith2 sp undefined +-- /Since: 3/ +liftShowbConstPrec :: (Int -> a -> Builder) -> Int -> Const a b -> Builder +liftShowbConstPrec sp = liftShowbPrec2 sp undefined undefined undefined --- | Convert a 'ZipList' to a 'Builder' with the given show function precedence. +-- | Convert a 'ZipList' to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbZipListPrecWith :: (Int -> a -> Builder) -> Int -> ZipList a -> Builder -showbZipListPrecWith = showbPrecWith +-- /Since: 3/ +liftShowbZipListPrec :: ([a] -> Builder) -> Int -> ZipList a -> Builder +liftShowbZipListPrec sl = liftShowbPrec undefined sl instance TextShow a => TextShow (Const a b) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow a => TextShow1 (Const a) where - showbPrecWith = showbPrecWith2 showbPrec + liftShowbPrec = liftShowbPrec2 showbPrec showbList instance TextShow2 Const where - showbPrecWith2 sp1 _ p (Const x) = showbUnaryWith sp1 "Const" p x + liftShowbPrec2 sp1 _ _ _ p (Const x) = showbUnaryWith sp1 "Const" p x $(deriveTextShow ''ZipList) $(deriveTextShow1 ''ZipList) diff --git a/src/TextShow/Control/Concurrent.hs b/src/TextShow/Control/Concurrent.hs --- a/src/TextShow/Control/Concurrent.hs +++ b/src/TextShow/Control/Concurrent.hs @@ -31,7 +31,7 @@ import GHC.Conc.Sync (ThreadId(..)) import GHC.Prim -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Foreign.C.Types (showbCIntPrec) import TextShow.TH.Internal (deriveTextShow) diff --git a/src/TextShow/Control/Exception.hs b/src/TextShow/Control/Exception.hs --- a/src/TextShow/Control/Exception.hs +++ b/src/TextShow/Control/Exception.hs @@ -31,6 +31,9 @@ #if MIN_VERSION_base(4,8,0) , showbAllocationLimitExceeded #endif +#if MIN_VERSION_base(4,9,0) + , showbTypeError +#endif , showbDeadlock , showbNoMethodError , showbPatternMatchFail @@ -52,7 +55,7 @@ import Prelude () import Prelude.Compat -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.FromStringTextShow (FromStringShow(..)) import TextShow.TH.Internal (deriveTextShow) @@ -164,6 +167,16 @@ {-# INLINE showbAllocationLimitExceeded #-} #endif +#if MIN_VERSION_base(4,9,0) +-- | Convert a 'TypeError' to a 'Builder'. +-- This function is only available with @base-4.9.0.0@ or later. +-- +-- /Since: 3/ +showbTypeError :: TypeError -> Builder +showbTypeError (TypeError err) = fromString err +{-# INLINE showbTypeError #-} +#endif + -- | Convert a 'Deadlock' exception to a 'Builder'. -- -- /Since: 2/ @@ -210,10 +223,12 @@ -- -- /Since: 2/ showbErrorCall :: ErrorCall -> Builder -showbErrorCall (ErrorCall err) = fromString err #if MIN_VERSION_base(4,9,0) +showbErrorCall (ErrorCallWithLocation err "") = fromString err showbErrorCall (ErrorCallWithLocation err loc) = fromString err <> singleton '\n' <> fromString loc +#else +showbErrorCall (ErrorCall err) = fromString err #endif -- | Convert a 'MaskingState' to a 'Builder'. @@ -272,6 +287,12 @@ #if MIN_VERSION_base(4,8,0) instance TextShow AllocationLimitExceeded where showb = showbAllocationLimitExceeded + {-# INLINE showb #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance TextShow TypeError where + showb = showbTypeError {-# INLINE showb #-} #endif diff --git a/src/TextShow/Control/Monad/ST.hs b/src/TextShow/Control/Monad/ST.hs --- a/src/TextShow/Control/Monad/ST.hs +++ b/src/TextShow/Control/Monad/ST.hs @@ -17,7 +17,7 @@ import Control.Monad.ST (ST) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showb), TextShow1(..), TextShow2(..)) +import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..)) #include "inline.h" @@ -29,13 +29,13 @@ {-# INLINE showbST #-} instance TextShow (ST s a) where - showb = showbPrecWith undefined 0 + showb = liftShowbPrec undefined undefined 0 INLINE_INST_FUN(showb) instance TextShow1 (ST s) where - showbPrecWith = showbPrecWith2 undefined - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec = liftShowbPrec2 undefined undefined + INLINE_INST_FUN(liftShowbPrec) instance TextShow2 ST where - showbPrecWith2 _ _ _ _ = "<>" - INLINE_INST_FUN(showbPrecWith2) + liftShowbPrec2 _ _ _ _ _ _ = "<>" + INLINE_INST_FUN(liftShowbPrec2) diff --git a/src/TextShow/Data/Array.hs b/src/TextShow/Data/Array.hs --- a/src/TextShow/Data/Array.hs +++ b/src/TextShow/Data/Array.hs @@ -34,7 +34,7 @@ import Prelude () import Prelude.Compat -import TextShow.Classes (TextShow(showb, showbPrec), showbParen, showbSpace) +import TextShow.Classes (TextShow(..), showbParen, showbSpace) import TextShow.Data.List () import TextShow.Data.Tuple () diff --git a/src/TextShow/Data/ByteString.hs b/src/TextShow/Data/ByteString.hs --- a/src/TextShow/Data/ByteString.hs +++ b/src/TextShow/Data/ByteString.hs @@ -33,7 +33,7 @@ import GHC.Exts (ByteArray#, Char(C#), Int(I#), indexCharArray#) -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Char () import TextShow.Data.List () diff --git a/src/TextShow/Data/Complex.hs b/src/TextShow/Data/Complex.hs --- a/src/TextShow/Data/Complex.hs +++ b/src/TextShow/Data/Complex.hs @@ -21,7 +21,7 @@ import Data.Complex (Complex) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Floating () import TextShow.TH.Internal (makeShowbPrec) #if MIN_VERSION_base(4,4,0) diff --git a/src/TextShow/Data/Data.hs b/src/TextShow/Data/Data.hs --- a/src/TextShow/Data/Data.hs +++ b/src/TextShow/Data/Data.hs @@ -24,7 +24,7 @@ import Data.Data (Constr, ConstrRep, DataRep, DataType, Fixity, showConstr) import Data.Text.Lazy.Builder (Builder, fromString) -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.List () import TextShow.Data.Ratio () import TextShow.TH.Internal (deriveTextShow) diff --git a/src/TextShow/Data/Dynamic.hs b/src/TextShow/Data/Dynamic.hs --- a/src/TextShow/Data/Dynamic.hs +++ b/src/TextShow/Data/Dynamic.hs @@ -21,7 +21,7 @@ import Prelude () -import TextShow.Classes (TextShow(showb)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Typeable (showbTypeRepPrec) #include "inline.h" diff --git a/src/TextShow/Data/Either.hs b/src/TextShow/Data/Either.hs --- a/src/TextShow/Data/Either.hs +++ b/src/TextShow/Data/Either.hs @@ -13,11 +13,11 @@ /Since: 2/ -} -module TextShow.Data.Either (showbEitherPrecWith2) where +module TextShow.Data.Either (liftShowbEitherPrec2) where import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (showbPrecWith2) +import TextShow.Classes (liftShowbPrec2) import TextShow.TH.Internal (deriveTextShow, deriveTextShow1, deriveTextShow2) #include "inline.h" @@ -25,11 +25,11 @@ -- | Convert a 'Either' value to a 'Builder' with the given show functions -- and precedence. -- --- /Since: 2/ -showbEitherPrecWith2 :: (Int -> a -> Builder) -> (Int -> b -> Builder) +-- /Since: 3/ +liftShowbEitherPrec2 :: (Int -> a -> Builder) -> (Int -> b -> Builder) -> Int -> Either a b -> Builder -showbEitherPrecWith2 = showbPrecWith2 -{-# INLINE showbEitherPrecWith2 #-} +liftShowbEitherPrec2 sp1 sp2 = liftShowbPrec2 sp1 undefined sp2 undefined +{-# INLINE liftShowbEitherPrec2 #-} $(deriveTextShow ''Either) $(deriveTextShow1 ''Either) diff --git a/src/TextShow/Data/Fixed.hs b/src/TextShow/Data/Fixed.hs --- a/src/TextShow/Data/Fixed.hs +++ b/src/TextShow/Data/Fixed.hs @@ -20,16 +20,17 @@ import Prelude () import Prelude.Compat -import TextShow.Classes (TextShow(showb)) +import TextShow.Classes (TextShow(..)) #if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(..)) import Data.Int (Int64) import Data.Monoid.Compat ((<>)) +import Data.Semigroup (mtimesDefault) import Data.Text.Lazy.Builder (singleton) import TextShow.Data.Integral () -import TextShow.Utils (lengthB, mtimesDefault) +import TextShow.Utils (lengthB) #else import Data.Fixed (Fixed, showFixed) import Data.Text.Lazy.Builder (fromString) diff --git a/src/TextShow/Data/Floating.hs b/src/TextShow/Data/Floating.hs --- a/src/TextShow/Data/Floating.hs +++ b/src/TextShow/Data/Floating.hs @@ -37,7 +37,7 @@ import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) -import TextShow.Classes (TextShow(showb, showbPrec), showbParen) +import TextShow.Classes (TextShow(..), showbParen) import TextShow.TH.Internal (deriveTextShow) import TextShow.Utils (i2d) diff --git a/src/TextShow/Data/Functor/Compose.hs b/src/TextShow/Data/Functor/Compose.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Data/Functor/Compose.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: TextShow.Data.Functor.Compose +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Monomorphic 'TextShow' function for 'Compose'. + +/Since: 3/ +-} +module TextShow.Data.Functor.Compose (liftShowbComposePrec) where + +import Data.Functor.Compose (Compose(..)) +import Data.Text.Lazy.Builder (Builder) + +import TextShow.Classes (TextShow(..), TextShow1(..), showbPrec1, showbUnaryWith) + +#include "inline.h" + +-- | Convert a 'Compose' value to a 'Builder' with the given show functions +-- and precedence. +-- +-- /Since: 3/ +liftShowbComposePrec :: (TextShow1 f, TextShow1 g) + => (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> Compose f g a -> Builder +liftShowbComposePrec sp sl p (Compose x) = + showbUnaryWith (liftShowbPrec (liftShowbPrec sp sl) + (liftShowbList sp sl)) + "Compose" p x + +instance (TextShow1 f, TextShow1 g, TextShow a) => TextShow (Compose f g a) where + showbPrec = showbPrec1 + INLINE_INST_FUN(showbPrec) + +instance (TextShow1 f, TextShow1 g) => TextShow1 (Compose f g) where + liftShowbPrec = liftShowbComposePrec + INLINE_INST_FUN(liftShowbPrec) diff --git a/src/TextShow/Data/Functor/Identity.hs b/src/TextShow/Data/Functor/Identity.hs --- a/src/TextShow/Data/Functor/Identity.hs +++ b/src/TextShow/Data/Functor/Identity.hs @@ -13,12 +13,12 @@ /Since: 2/ -} -module TextShow.Data.Functor.Identity (showbIdentityPrecWith) where +module TextShow.Data.Functor.Identity (liftShowbIdentityPrec) where import Data.Functor.Identity (Identity(..)) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showbPrec), TextShow1(..), +import TextShow.Classes (TextShow(..), TextShow1(..), showbPrec1, showbUnaryWith) #include "inline.h" @@ -26,17 +26,17 @@ -- | Convert an 'Identity' value to a 'Builder' with the given show function -- and precedence. -- --- /Since: 2/ -showbIdentityPrecWith :: (Int -> a -> Builder) -> Int -> Identity a -> Builder +-- /Since: 3/ +liftShowbIdentityPrec :: (Int -> a -> Builder) -> Int -> Identity a -> Builder -- This would be equivalent to the derived instance of 'Identity' if the -- 'runIdentity' field were removed. -showbIdentityPrecWith sp p (Identity x) = showbUnaryWith sp "Identity" p x -{-# INLINE showbIdentityPrecWith #-} +liftShowbIdentityPrec sp p (Identity x) = showbUnaryWith sp "Identity" p x +{-# INLINE liftShowbIdentityPrec #-} instance TextShow a => TextShow (Identity a) where showbPrec = showbPrec1 {-# INLINE showbPrec #-} instance TextShow1 Identity where - showbPrecWith = showbIdentityPrecWith - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec sp _ = liftShowbIdentityPrec sp + INLINE_INST_FUN(liftShowbPrec) diff --git a/src/TextShow/Data/Functor/Product.hs b/src/TextShow/Data/Functor/Product.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Data/Functor/Product.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: TextShow.Data.Functor.Product +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Monomorphic 'TextShow' function for 'Product'. + +/Since: 3/ +-} +module TextShow.Data.Functor.Product (liftShowbProductPrec) where + +import Data.Functor.Product (Product(..)) +import Data.Text.Lazy.Builder (Builder) + +import TextShow.Classes (TextShow(..), TextShow1(..), showbPrec1) +import TextShow.TH.Internal (deriveTextShow1) + +#include "inline.h" + +-- | Convert a 'Product' value to a 'Builder' with the given show functions +-- and precedence. +-- +-- /Since: 3/ +liftShowbProductPrec :: (TextShow1 f, TextShow1 g) + => (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> Product f g a -> Builder +liftShowbProductPrec = liftShowbPrec +{-# INLINE liftShowbProductPrec #-} + +instance (TextShow1 f, TextShow1 g, TextShow a) => TextShow (Product f g a) where + showbPrec = showbPrec1 + INLINE_INST_FUN(showbPrec) + +$(deriveTextShow1 ''Product) diff --git a/src/TextShow/Data/Functor/Sum.hs b/src/TextShow/Data/Functor/Sum.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Data/Functor/Sum.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: TextShow.Data.Functor.Sum +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Monomorphic 'TextShow' function for 'Sum'. + +/Since: 3/ +-} +module TextShow.Data.Functor.Sum (liftShowbSumPrec) where + +import Data.Functor.Sum (Sum(..)) +import Data.Text.Lazy.Builder (Builder) + +import TextShow.Classes (TextShow(..), TextShow1(..), showbPrec1) +import TextShow.TH.Internal (deriveTextShow1) + +#include "inline.h" + +-- | Convert a 'Sum' value to a 'Builder' with the given show functions +-- and precedence. +-- +-- /Since: 3/ +liftShowbSumPrec :: (TextShow1 f, TextShow1 g) + => (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> Sum f g a -> Builder +liftShowbSumPrec = liftShowbPrec +{-# INLINE liftShowbSumPrec #-} + +instance (TextShow1 f, TextShow1 g, TextShow a) => TextShow (Sum f g a) where + showbPrec = showbPrec1 + INLINE_INST_FUN(showbPrec) + +$(deriveTextShow1 ''Sum) diff --git a/src/TextShow/Data/Integral.hs b/src/TextShow/Data/Integral.hs --- a/src/TextShow/Data/Integral.hs +++ b/src/TextShow/Data/Integral.hs @@ -50,7 +50,7 @@ import Prelude () import Prelude.Compat -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Utils (toString) #include "inline.h" diff --git a/src/TextShow/Data/List.hs b/src/TextShow/Data/List.hs --- a/src/TextShow/Data/List.hs +++ b/src/TextShow/Data/List.hs @@ -12,7 +12,7 @@ -} module TextShow.Data.List (showbListWith) where -import TextShow.Classes (TextShow(showb, showbList), TextShow1(..), showbListWith) +import TextShow.Classes (TextShow(..), TextShow1(..), showbListWith) import TextShow.Data.Char () import TextShow.Data.Integral () @@ -26,5 +26,5 @@ INLINE_INST_FUN(showb) instance TextShow1 [] where - showbPrecWith sp _ = showbListWith (sp 0) - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec _ sl _ = sl + INLINE_INST_FUN(liftShowbPrec) diff --git a/src/TextShow/Data/List/NonEmpty.hs b/src/TextShow/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Data/List/NonEmpty.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: TextShow.Data.List.NonEmpty +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Monomorphic 'TextShow' function for 'NonEmpty' lists. + +/Since: 3/ +-} +module TextShow.Data.List.NonEmpty (liftShowbNonEmptyPrec) where + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text.Lazy.Builder (Builder) + +import TextShow.Classes (TextShow1(..)) +import TextShow.Data.List () +import TextShow.TH.Internal (deriveTextShow, deriveTextShow1) + +liftShowbNonEmptyPrec :: (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> NonEmpty a -> Builder +liftShowbNonEmptyPrec = liftShowbPrec + +$(deriveTextShow ''NonEmpty) +$(deriveTextShow1 ''NonEmpty) diff --git a/src/TextShow/Data/Maybe.hs b/src/TextShow/Data/Maybe.hs --- a/src/TextShow/Data/Maybe.hs +++ b/src/TextShow/Data/Maybe.hs @@ -13,21 +13,21 @@ /Since: 2/ -} -module TextShow.Data.Maybe (showbMaybePrecWith) where +module TextShow.Data.Maybe (liftShowbMaybePrec) where import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (showbPrecWith) +import TextShow.Classes (liftShowbPrec) import TextShow.TH.Internal (deriveTextShow, deriveTextShow1) #include "inline.h" -- | Convert a 'Maybe' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbMaybePrecWith :: (Int -> a -> Builder) -> Int -> Maybe a -> Builder -showbMaybePrecWith = showbPrecWith -{-# INLINE showbMaybePrecWith #-} +-- /Since: 3/ +liftShowbMaybePrec :: (Int -> a -> Builder) -> Int -> Maybe a -> Builder +liftShowbMaybePrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbMaybePrec #-} $(deriveTextShow ''Maybe) $(deriveTextShow1 ''Maybe) diff --git a/src/TextShow/Data/Monoid.hs b/src/TextShow/Data/Monoid.hs --- a/src/TextShow/Data/Monoid.hs +++ b/src/TextShow/Data/Monoid.hs @@ -19,28 +19,27 @@ module TextShow.Data.Monoid ( showbAllPrec , showbAnyPrec - , showbDualPrecWith - , showbFirstPrecWith - , showbLastPrecWith - , showbProductPrecWith - , showbSumPrecWith + , liftShowbDualPrec + , liftShowbFirstPrec + , liftShowbLastPrec + , liftShowbProductPrec + , liftShowbSumPrec #if MIN_VERSION_base(4,8,0) , showbAltPrec - , showbAltPrecWith + , liftShowbAltPrec #endif ) where import Data.Monoid.Compat (All, Any, Dual, First, Last, Product, Sum) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showbPrec), showbPrecWith) +import TextShow.Classes (TextShow(..), TextShow1(..)) import TextShow.Data.Bool () import TextShow.Data.Maybe () import TextShow.TH.Internal (deriveTextShow, deriveTextShow1) #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt) -import TextShow.Classes (TextShow1) import TextShow.TH.Internal (makeShowbPrec) #endif @@ -62,39 +61,39 @@ -- | Convert a 'Dual' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbDualPrecWith :: (Int -> a -> Builder) -> Int -> Dual a -> Builder -showbDualPrecWith = showbPrecWith -{-# INLINE showbDualPrecWith #-} +-- /Since: 3/ +liftShowbDualPrec :: (Int -> a -> Builder) -> Int -> Dual a -> Builder +liftShowbDualPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbDualPrec #-} -- | Convert a 'First' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbFirstPrecWith :: (Int -> a -> Builder) -> Int -> First a -> Builder -showbFirstPrecWith = showbPrecWith -{-# INLINE showbFirstPrecWith #-} +-- /Since: 3/ +liftShowbFirstPrec :: (Int -> a -> Builder) -> Int -> First a -> Builder +liftShowbFirstPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbFirstPrec #-} -- | Convert a 'Last' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbLastPrecWith :: (Int -> a -> Builder) -> Int -> Last a -> Builder -showbLastPrecWith = showbPrecWith -{-# INLINE showbLastPrecWith #-} +-- /Since: 3/ +liftShowbLastPrec :: (Int -> a -> Builder) -> Int -> Last a -> Builder +liftShowbLastPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbLastPrec #-} -- | Convert a 'Product' value to a 'Builder' with the given show function -- and precedence. -- --- /Since: 2/ -showbProductPrecWith :: (Int -> a -> Builder) -> Int -> Product a -> Builder -showbProductPrecWith = showbPrecWith -{-# INLINE showbProductPrecWith #-} +-- /Since: 3/ +liftShowbProductPrec :: (Int -> a -> Builder) -> Int -> Product a -> Builder +liftShowbProductPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbProductPrec #-} -- | Convert a 'Sum' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbSumPrecWith :: (Int -> a -> Builder) -> Int -> Sum a -> Builder -showbSumPrecWith = showbPrecWith -{-# INLINE showbSumPrecWith #-} +-- /Since: 3/ +liftShowbSumPrec :: (Int -> a -> Builder) -> Int -> Sum a -> Builder +liftShowbSumPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbSumPrec #-} #if MIN_VERSION_base(4,8,0) -- | Convert an 'Alt' value to a 'Builder' with the given precedence. @@ -108,9 +107,11 @@ -- | Convert an 'Alt' value to a 'Builder' with the given show function and precedence. -- This function is only available with @base-4.8.0.0@ or later. -- --- /Since: 2/ -showbAltPrecWith :: TextShow1 f => (Int -> a -> Builder) -> Int -> Alt f a -> Builder -showbAltPrecWith = showbPrecWith +-- /Since: 3/ +liftShowbAltPrec :: TextShow1 f => (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> Alt f a -> Builder +liftShowbAltPrec = liftShowbPrec +{-# INLINE liftShowbAltPrec #-} #endif $(deriveTextShow ''All) diff --git a/src/TextShow/Data/OldTypeable.hs b/src/TextShow/Data/OldTypeable.hs --- a/src/TextShow/Data/OldTypeable.hs +++ b/src/TextShow/Data/OldTypeable.hs @@ -30,7 +30,7 @@ funTc, listTc) import Data.Text.Lazy.Builder (Builder, fromString, singleton) -import TextShow.Classes (TextShow(showb, showbPrec), showbParen, showbSpace) +import TextShow.Classes (TextShow(..), showbParen, showbSpace) import TextShow.Data.Typeable.Utils (showbArgs, showbTuple) import TextShow.Utils (isTupleString) diff --git a/src/TextShow/Data/Ord.hs b/src/TextShow/Data/Ord.hs --- a/src/TextShow/Data/Ord.hs +++ b/src/TextShow/Data/Ord.hs @@ -14,14 +14,14 @@ -} module TextShow.Data.Ord ( showbOrdering - , showbDownPrecWith + , liftShowbDownPrec ) where import Data.Text.Lazy.Builder (Builder) import GHC.Exts (Down) -import TextShow.Classes (showb, showbPrecWith) +import TextShow.Classes (showb, liftShowbPrec) import TextShow.TH.Internal (deriveTextShow, deriveTextShow1) -- | Convert a 'Ordering' to a 'Builder'. @@ -33,10 +33,10 @@ -- | Convert a 'Down' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbDownPrecWith :: (Int -> a -> Builder) -> Int -> Down a -> Builder -showbDownPrecWith = showbPrecWith -{-# INLINE showbDownPrecWith #-} +-- /Since: 3/ +liftShowbDownPrec :: (Int -> a -> Builder) -> Int -> Down a -> Builder +liftShowbDownPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbDownPrec #-} $(deriveTextShow ''Ordering) $(deriveTextShow ''Down) diff --git a/src/TextShow/Data/Proxy.hs b/src/TextShow/Data/Proxy.hs --- a/src/TextShow/Data/Proxy.hs +++ b/src/TextShow/Data/Proxy.hs @@ -25,7 +25,7 @@ import Data.Proxy (Proxy(..)) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.TH.Internal (deriveTextShow1, makeShowbPrec) #include "inline.h" diff --git a/src/TextShow/Data/Ratio.hs b/src/TextShow/Data/Ratio.hs --- a/src/TextShow/Data/Ratio.hs +++ b/src/TextShow/Data/Ratio.hs @@ -20,7 +20,7 @@ import GHC.Real (Ratio(..), ratioPrec, ratioPrec1) -import TextShow.Classes (TextShow(showbPrec), showbParen) +import TextShow.Classes (TextShow(..), showbParen) #if MIN_VERSION_base(4,4,0) import TextShow.Classes (TextShow1(..)) #endif @@ -60,9 +60,9 @@ #if MIN_VERSION_base(4,4,0) instance TextShow1 Ratio where - showbPrecWith sp p (numer :% denom) = showbParen (p > ratioPrec) $ + liftShowbPrec sp _ p (numer :% denom) = showbParen (p > ratioPrec) $ sp ratioPrec1 numer <> " % " <> sp ratioPrec1 denom - INLINE_INST_FUN(showbPrecWith) + INLINE_INST_FUN(liftShowbPrec) #endif diff --git a/src/TextShow/Data/Semigroup.hs b/src/TextShow/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/TextShow/Data/Semigroup.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: TextShow.Data.Semigroup +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Monomorphic 'TextShow' functions for data types in the "Data.Semigroup" module. + +/Since: 3/ +-} +module TextShow.Data.Semigroup ( + liftShowbMinPrec + , liftShowbMaxPrec + , liftShowbFirstPrec + , liftShowbLastPrec + , liftShowbWrappedMonoidPrec + , liftShowbOptionPrec + , liftShowbArgPrec2 + ) where + +import Data.Semigroup (Min, Max, First, Last, WrappedMonoid, Option, Arg) +import Data.Text.Lazy.Builder (Builder) + +import TextShow.Classes (TextShow1(..), TextShow2(..)) +import TextShow.Data.Maybe () +import TextShow.TH.Internal (deriveTextShow, deriveTextShow1, deriveTextShow2) + +-- | Convert a 'Min' value to a 'Builder' with the given show function and precedence. +-- +-- /Since: 3/ +liftShowbMinPrec :: (Int -> a -> Builder) -> Int -> Min a -> Builder +liftShowbMinPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbMinPrec #-} + +-- | Convert a 'Max' value to a 'Builder' with the given show function and precedence. +-- +-- /Since: 3/ +liftShowbMaxPrec :: (Int -> a -> Builder) -> Int -> Max a -> Builder +liftShowbMaxPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbMaxPrec #-} + +-- | Convert a 'First' value to a 'Builder' with the given show function and precedence. +-- +-- /Since: 3/ +liftShowbFirstPrec :: (Int -> a -> Builder) -> Int -> First a -> Builder +liftShowbFirstPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbFirstPrec #-} + +-- | Convert a 'Last' value to a 'Builder' with the given show function and precedence. +-- +-- /Since: 3/ +liftShowbLastPrec :: (Int -> a -> Builder) -> Int -> Last a -> Builder +liftShowbLastPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbLastPrec #-} + +-- | Convert a 'WrappedMonoid' to a 'Builder' with the given show function +-- and precedence. +-- +-- /Since: 3/ +liftShowbWrappedMonoidPrec :: (Int -> m -> Builder) -> Int -> WrappedMonoid m -> Builder +liftShowbWrappedMonoidPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbWrappedMonoidPrec #-} + +-- | Convert an 'Option' value to a 'Builder' with the given show function +-- and precedence. +-- +-- /Since: 3/ +liftShowbOptionPrec :: (Int -> a -> Builder) -> Int -> Option a -> Builder +liftShowbOptionPrec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbOptionPrec #-} + +-- | Convert an 'Arg' value to a 'Builder' with the given show functions and precedence. +-- +-- /Since: 3/ +liftShowbArgPrec2 :: (Int -> a -> Builder) -> (Int -> b -> Builder) + -> Int -> Arg a b -> Builder +liftShowbArgPrec2 sp1 sp2 = liftShowbPrec2 sp1 undefined sp2 undefined +{-# INLINE liftShowbArgPrec2 #-} + +$(deriveTextShow ''Min) +$(deriveTextShow1 ''Min) + +$(deriveTextShow ''Max) +$(deriveTextShow1 ''Max) + +$(deriveTextShow ''First) +$(deriveTextShow1 ''First) + +$(deriveTextShow ''Last) +$(deriveTextShow1 ''Last) + +$(deriveTextShow ''WrappedMonoid) +$(deriveTextShow1 ''WrappedMonoid) + +$(deriveTextShow ''Option) +$(deriveTextShow1 ''Option) + +$(deriveTextShow ''Arg) +$(deriveTextShow1 ''Arg) +$(deriveTextShow2 ''Arg) diff --git a/src/TextShow/Data/Text.hs b/src/TextShow/Data/Text.hs --- a/src/TextShow/Data/Text.hs +++ b/src/TextShow/Data/Text.hs @@ -38,7 +38,7 @@ import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Char (showbString) import TextShow.Data.Integral (showbHex) import TextShow.TH.Internal (deriveTextShow) diff --git a/src/TextShow/Data/Tuple.hs b/src/TextShow/Data/Tuple.hs --- a/src/TextShow/Data/Tuple.hs +++ b/src/TextShow/Data/Tuple.hs @@ -15,25 +15,25 @@ -} module TextShow.Data.Tuple ( showbUnit - , showb2TupleWith2 - , showb3TupleWith2 - , showb4TupleWith2 - , showb5TupleWith2 - , showb6TupleWith2 - , showb7TupleWith2 - , showb8TupleWith2 - , showb9TupleWith2 - , showb10TupleWith2 - , showb11TupleWith2 - , showb12TupleWith2 - , showb13TupleWith2 - , showb14TupleWith2 - , showb15TupleWith2 + , liftShowb2Tuple2 + , liftShowb3Tuple2 + , liftShowb4Tuple2 + , liftShowb5Tuple2 + , liftShowb6Tuple2 + , liftShowb7Tuple2 + , liftShowb8Tuple2 + , liftShowb9Tuple2 + , liftShowb10Tuple2 + , liftShowb11Tuple2 + , liftShowb12Tuple2 + , liftShowb13Tuple2 + , liftShowb14Tuple2 + , liftShowb15Tuple2 ) where import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showb), TextShow2(..)) +import TextShow.Classes (TextShow(..), TextShow2(..)) import TextShow.TH.Internal (deriveTextShow, deriveTextShow1, deriveTextShow2) #include "inline.h" @@ -44,142 +44,140 @@ showbUnit :: () -> Builder -- showbUnit () = "()" showbUnit = showb -{-# INLINE showbUnit #-} -- | Converts a 2-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb2TupleWith2 :: (a -> Builder) -> (b -> Builder) +-- /Since: 3/ +liftShowb2Tuple2 :: (a -> Builder) -> (b -> Builder) -> (a, b) -> Builder -showb2TupleWith2 = showbWith2 -{-# INLINE showb2TupleWith2 #-} +liftShowb2Tuple2 = liftShowb2 +{-# INLINE liftShowb2Tuple2 #-} -- | Converts a 3-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb3TupleWith2 :: TextShow a +-- /Since: 3/ +liftShowb3Tuple2 :: TextShow a => (b -> Builder) -> (c -> Builder) -> (a, b, c) -> Builder -showb3TupleWith2 = showbWith2 -{-# INLINE showb3TupleWith2 #-} +liftShowb3Tuple2 = liftShowb2 +{-# INLINE liftShowb3Tuple2 #-} -- | Converts a 4-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb4TupleWith2 :: (TextShow a, TextShow b) +-- /Since: 3/ +liftShowb4Tuple2 :: (TextShow a, TextShow b) => (c -> Builder) -> (d -> Builder) -> (a, b, c, d) -> Builder -showb4TupleWith2 = showbWith2 -{-# INLINE showb4TupleWith2 #-} +liftShowb4Tuple2 = liftShowb2 +{-# INLINE liftShowb4Tuple2 #-} -- | Converts a 5-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb5TupleWith2 :: (TextShow a, TextShow b, TextShow c) +-- /Since: 3/ +liftShowb5Tuple2 :: (TextShow a, TextShow b, TextShow c) => (d -> Builder) -> (e -> Builder) -> (a, b, c, d, e) -> Builder -showb5TupleWith2 = showbWith2 -{-# INLINE showb5TupleWith2 #-} +liftShowb5Tuple2 = liftShowb2 +{-# INLINE liftShowb5Tuple2 #-} -- | Converts a 6-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb6TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d) +-- /Since: 3/ +liftShowb6Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d) => (e -> Builder) -> (f -> Builder) -> (a, b, c, d, e, f) -> Builder -showb6TupleWith2 = showbWith2 -{-# INLINE showb6TupleWith2 #-} +liftShowb6Tuple2 = liftShowb2 +{-# INLINE liftShowb6Tuple2 #-} -- | Converts a 7-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb7TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e) +-- /Since: 3/ +liftShowb7Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e) => (f -> Builder) -> (g -> Builder) -> (a, b, c, d, e, f, g) -> Builder -showb7TupleWith2 = showbWith2 -{-# INLINE showb7TupleWith2 #-} +liftShowb7Tuple2 = liftShowb2 +{-# INLINE liftShowb7Tuple2 #-} -- | Converts an 8-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb8TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f) +-- /Since: 3/ +liftShowb8Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f) => (g -> Builder) -> (h -> Builder) -> (a, b, c, d, e, f, g, h) -> Builder -showb8TupleWith2 = showbWith2 -{-# INLINE showb8TupleWith2 #-} +liftShowb8Tuple2 = liftShowb2 +{-# INLINE liftShowb8Tuple2 #-} -- | Converts a 9-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb9TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g) +-- /Since: 3/ +liftShowb9Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g) => (h -> Builder) -> (i -> Builder) -> (a, b, c, d, e, f, g, h, i) -> Builder -showb9TupleWith2 = showbWith2 -{-# INLINE showb9TupleWith2 #-} +liftShowb9Tuple2 = liftShowb2 +{-# INLINE liftShowb9Tuple2 #-} -- | Converts a 10-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb10TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h) +-- /Since: 3/ +liftShowb10Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h) => (i -> Builder) -> (j -> Builder) -> (a, b, c, d, e, f, g, h, i, j) -> Builder -showb10TupleWith2 = showbWith2 -{-# INLINE showb10TupleWith2 #-} +liftShowb10Tuple2 = liftShowb2 +{-# INLINE liftShowb10Tuple2 #-} -- | Converts an 11-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb11TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, +-- /Since: 3/ +liftShowb11Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h, TextShow i) => (j -> Builder) -> (k -> Builder) -> (a, b, c, d, e, f, g, h, i, j, k) -> Builder -showb11TupleWith2 = showbWith2 -{-# INLINE showb11TupleWith2 #-} +liftShowb11Tuple2 = liftShowb2 +{-# INLINE liftShowb11Tuple2 #-} -- | Converts a 12-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb12TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, +-- /Since: 3/ +liftShowb12Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h, TextShow i, TextShow j) => (k -> Builder) -> (l -> Builder) -> (a, b, c, d, e, f, g, h, i, j, k, l) -> Builder -showb12TupleWith2 = showbWith2 -{-# INLINE showb12TupleWith2 #-} +liftShowb12Tuple2 = liftShowb2 +{-# INLINE liftShowb12Tuple2 #-} -- | Converts a 13-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb13TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, +-- /Since: 3/ +liftShowb13Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h, TextShow i, TextShow j, TextShow k) => (l -> Builder) -> (m -> Builder) -> (a, b, c, d, e, f, g, h, i, j, k, l, m) -> Builder -showb13TupleWith2 = showbWith2 -{-# INLINE showb13TupleWith2 #-} +liftShowb13Tuple2 = liftShowb2 +{-# INLINE liftShowb13Tuple2 #-} -- | Converts a 14-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb14TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, +-- /Since: 3/ +liftShowb14Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h, TextShow i, TextShow j, TextShow k, TextShow l) => (m -> Builder) -> (n -> Builder) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> Builder -showb14TupleWith2 = showbWith2 -{-# INLINE showb14TupleWith2 #-} +liftShowb14Tuple2 = liftShowb2 +{-# INLINE liftShowb14Tuple2 #-} -- | Converts a 15-tuple into a 'Builder' with the given show functions. -- --- /Since: 2/ -showb15TupleWith2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, +-- /Since: 3/ +liftShowb15Tuple2 :: (TextShow a, TextShow b, TextShow c, TextShow d, TextShow e, TextShow f, TextShow g, TextShow h, TextShow i, TextShow j, TextShow k, TextShow l, TextShow m) => (n -> Builder) -> (o -> Builder) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> Builder -showb15TupleWith2 = showbWith2 -{-# INLINE showb15TupleWith2 #-} +liftShowb15Tuple2 = liftShowb2 +{-# INLINE liftShowb15Tuple2 #-} --- | Like 'showbPrecWith2', except precedence-agnostic. -showbWith2 :: TextShow2 f => (a -> Builder) -> (b -> Builder) -> f a b -> Builder -showbWith2 sp1 sp2 = showbPrecWith2 (const sp1) (const sp2) 0 -{-# INLINE showbWith2 #-} +-- | Like 'liftShowbPrec2', except precedence-agnostic. +liftShowb2 :: TextShow2 f => (a -> Builder) -> (b -> Builder) -> f a b -> Builder +liftShowb2 sp1 sp2 = liftShowbPrec2 (const sp1) undefined (const sp2) undefined 0 -- The Great Pyramids of Template Haskell $(deriveTextShow ''()) diff --git a/src/TextShow/Data/Type/Coercion.hs b/src/TextShow/Data/Type/Coercion.hs --- a/src/TextShow/Data/Type/Coercion.hs +++ b/src/TextShow/Data/Type/Coercion.hs @@ -29,8 +29,8 @@ import Data.Text.Lazy.Builder (Builder) import Data.Type.Coercion (Coercion(..)) -import TextShow.Classes (TextShow(showb, showbPrec), TextShow1(..)) -import TextShow.TH.Internal (deriveTextShow2, makeShowbPrec, makeShowbPrecWith) +import TextShow.Classes (TextShow(..), TextShow1(..)) +import TextShow.TH.Internal (deriveTextShow, deriveTextShow2, makeLiftShowbPrec) -- | Convert a representational equality value to a 'Builder'. -- This function is only available with @base-4.7.0.0@ or later. @@ -40,13 +40,10 @@ showbCoercion = showb {-# INLINE showbCoercion #-} -instance TextShow (Coercion a b) where - showbPrec = $(makeShowbPrec ''Coercion) - {-# INLINE showbPrec #-} +$(deriveTextShow ''Coercion) instance TextShow1 (Coercion a) where - showbPrecWith = $(makeShowbPrecWith ''Coercion) - {-# INLINE showbPrecWith #-} + liftShowbPrec = $(makeLiftShowbPrec ''Coercion) $(deriveTextShow2 ''Coercion) #endif diff --git a/src/TextShow/Data/Type/Equality.hs b/src/TextShow/Data/Type/Equality.hs --- a/src/TextShow/Data/Type/Equality.hs +++ b/src/TextShow/Data/Type/Equality.hs @@ -30,8 +30,8 @@ import Data.Text.Lazy.Builder (Builder) import Data.Type.Equality ((:~:)(..)) -import TextShow.Classes (TextShow(showb, showbPrec), TextShow1(..)) -import TextShow.TH.Internal (deriveTextShow2, makeShowbPrec, makeShowbPrecWith) +import TextShow.Classes (TextShow(..), TextShow1(..)) +import TextShow.TH.Internal (deriveTextShow, deriveTextShow2, makeLiftShowbPrec) -- | Convert a propositional equality value to a 'Builder'. -- This function is only available with @base-4.7.0.0@ or later. @@ -41,13 +41,10 @@ showbPropEquality = showb {-# INLINE showbPropEquality #-} -instance TextShow (a :~: b) where - showbPrec = $(makeShowbPrec ''(:~:)) - {-# INLINE showbPrec #-} +$(deriveTextShow ''(:~:)) instance TextShow1 ((:~:) a) where - showbPrecWith = $(makeShowbPrecWith ''(:~:)) - {-# INLINE showbPrecWith #-} + liftShowbPrec = $(makeLiftShowbPrec ''(:~:)) $(deriveTextShow2 ''(:~:)) #endif diff --git a/src/TextShow/Data/Typeable.hs b/src/TextShow/Data/Typeable.hs --- a/src/TextShow/Data/Typeable.hs +++ b/src/TextShow/Data/Typeable.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + {-| Module: TextShow.Data.Typeable Copyright: (C) 2014-2015 Ryan Scott @@ -13,26 +20,44 @@ /Since: 2/ -} -module TextShow.Data.Typeable (showbTyCon, showbTypeRepPrec) where +module TextShow.Data.Typeable ( + showbTyCon + , showbTypeRepPrec +#if MIN_VERSION_base(4,9,0) + , showbTrName + , showbModule +#endif + ) where import Data.Monoid.Compat ((<>)) import Data.Text.Lazy.Builder (Builder, fromString, singleton) import Data.Typeable (TypeRep, typeRepArgs, typeRepTyCon) #if MIN_VERSION_base(4,4,0) -import Data.Typeable.Internal (TyCon, tyConName) +import Data.Typeable.Internal (tyConName) # if MIN_VERSION_base(4,8,0) import Data.Typeable.Internal (typeRepKinds) # endif # if MIN_VERSION_base(4,9,0) -import Data.Typeable.Internal (tcFun, tcList) +import Data.Typeable.Internal (Proxy(..), Typeable, TypeRep(TypeRep), typeRep) +import GHC.Exts (Levity(..), TYPE) # elif MIN_VERSION_base(4,4,0) import Data.Typeable.Internal (funTc, listTc) # endif #else -import Data.Typeable (TyCon, mkTyCon, tyConString, typeOf) +import Data.Typeable (mkTyCon, tyConString, typeOf) #endif -import TextShow.Classes (TextShow(showb, showbPrec), showbParen, showbSpace) +#if MIN_VERSION_base(4,9,0) +import GHC.Exts (Char(..)) +import GHC.Prim (Addr#, (+#), eqChar#, indexCharOffAddr#) +import GHC.Types (TyCon(..), TrName(..), Module(..), isTrue#) +#elif MIN_VERSION_base(4,4,0) +import Data.Typeable.Internal (TyCon) +#else +import Data.Typeable (TyCon) +#endif + +import TextShow.Classes (TextShow(..), showbParen, showbSpace) import TextShow.Data.List () import TextShow.Data.Typeable.Utils (showbArgs, showbTuple) import TextShow.Utils (isTupleString) @@ -46,7 +71,16 @@ showbTypeRepPrec p tyrep = case tys of [] -> showbTyCon tycon - [x] | tycon == tcList -> singleton '[' <> showb x <> singleton ']' +#if MIN_VERSION_base(4,9,0) + [x@(TypeRep _ argCon _ _)] +#else + [x] +#endif + | tycon == tcList -> singleton '[' <> showb x <> singleton ']' +#if MIN_VERSION_base(4,9,0) + | tycon == tcTYPE && argCon == tc'Lifted -> singleton '*' + | tycon == tcTYPE && argCon == tc'Unlifted -> singleton '#' +#endif [a,r] | tycon == tcFun -> showbParen (p > 8) $ showbPrec 9 a <> " -> " @@ -68,22 +102,40 @@ kinds = typeRepKinds tyrep #endif -#if !(MIN_VERSION_base(4,4,0)) +#if MIN_VERSION_base(4,9,0) +tyConOf :: Typeable a => Proxy a -> TyCon +tyConOf = typeRepTyCon . typeRep + +tcFun :: TyCon +tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) + +tcList :: TyCon +tcList = tyConOf (Proxy :: Proxy []) + +tcTYPE :: TyCon +tcTYPE = tyConOf (Proxy :: Proxy TYPE) + +tc'Lifted :: TyCon +tc'Lifted = tyConOf (Proxy :: Proxy 'Lifted) + +tc'Unlifted :: TyCon +tc'Unlifted = tyConOf (Proxy :: Proxy 'Unlifted) +#elif MIN_VERSION_base(4,4,0) -- | The list 'TyCon'. tcList :: TyCon -tcList = typeRepTyCon $ typeOf [()] +tcList = listTc -- | The function (@->@) 'TyCon'. tcFun :: TyCon -tcFun = mkTyCon "->" -#elif !(MIN_VERSION_base(4,9,0)) +tcFun = funTc +#else -- | The list 'TyCon'. tcList :: TyCon -tcList = listTc +tcList = typeRepTyCon $ typeOf [()] -- | The function (@->@) 'TyCon'. tcFun :: TyCon -tcFun = funTc +tcFun = mkTyCon "->" #endif -- | Does the 'TyCon' represent a tuple type constructor? @@ -95,9 +147,45 @@ -- -- /Since: 2/ showbTyCon :: TyCon -> Builder +#if MIN_VERSION_base(4,9,0) +showbTyCon (TyCon _ _ _ tc_name) = showb tc_name +#else showbTyCon = fromString . tyConString +#endif {-# INLINE showbTyCon #-} +#if MIN_VERSION_base(4,9,0) +-- | Convert a 'TrName' to a 'Builder'. +-- This function is only available with @base-4.9.0.0@ or later. +-- +-- /Since: 3/ +showbTrName :: TrName -> Builder +showbTrName (TrNameS s) = unpackCStringToBuilder# s +showbTrName (TrNameD s) = fromString s + +-- | Convert a 'Module' to a 'Builder'. +-- This function is only available with @base-4.9.0.0@ or later. +-- +-- /Since: 3/ +showbModule :: Module -> Builder +showbModule (Module p m) = showb p <> singleton ':' <> showb m +{-# INLINE showbModule #-} + +unpackCStringToBuilder# :: Addr# -> Builder + -- There's really no point in inlining this, ever, as the loop doesn't + -- specialise in an interesting But it's pretty small, so there's a danger + -- that it'll be inlined at every literal, which is a waste +unpackCStringToBuilder# addr + = unpack 0# + where + unpack nh + | isTrue# (ch `eqChar#` '\0'#) = mempty + | True = singleton (C# ch) <> unpack (nh +# 1#) + where + !ch = indexCharOffAddr# addr nh +{-# NOINLINE unpackCStringToBuilder# #-} +#endif + #if MIN_VERSION_base(4,4,0) -- | Identical to 'tyConName'. Defined to avoid using excessive amounts of pragmas -- with base-4.3 and earlier, which use 'tyConString'. @@ -113,3 +201,13 @@ instance TextShow TyCon where showb = showbTyCon INLINE_INST_FUN(showb) + +#if MIN_VERSION_base(4,9,0) +instance TextShow TrName where + showb = showbTrName + INLINE_INST_FUN(showb) + +instance TextShow Module where + showb = showbModule + INLINE_INST_FUN(showb) +#endif diff --git a/src/TextShow/Data/Typeable/Utils.hs b/src/TextShow/Data/Typeable/Utils.hs --- a/src/TextShow/Data/Typeable/Utils.hs +++ b/src/TextShow/Data/Typeable/Utils.hs @@ -16,7 +16,7 @@ import Prelude () import Prelude.Compat -import TextShow.Classes (TextShow(showbPrec)) +import TextShow.Classes (TextShow(..)) -- | Helper function for showing a list of arguments, each separated by the given -- 'Builder'. diff --git a/src/TextShow/Data/Void.hs b/src/TextShow/Data/Void.hs --- a/src/TextShow/Data/Void.hs +++ b/src/TextShow/Data/Void.hs @@ -18,7 +18,7 @@ import Prelude () -import TextShow.Classes (TextShow(showb)) +import TextShow.Classes (TextShow(..)) -- | Since 'Void' values logically don't exist, attempting to convert one to a -- 'Builder' will never terminate. diff --git a/src/TextShow/Debug/Trace.hs b/src/TextShow/Debug/Trace.hs --- a/src/TextShow/Debug/Trace.hs +++ b/src/TextShow/Debug/Trace.hs @@ -85,7 +85,7 @@ import System.IO.Unsafe (unsafePerformIO) -import TextShow.Classes (TextShow, showt) +import TextShow.Classes (TextShow(..)) import TextShow.Instances () -- $tracing diff --git a/src/TextShow/Foreign/C/Types.hs b/src/TextShow/Foreign/C/Types.hs --- a/src/TextShow/Foreign/C/Types.hs +++ b/src/TextShow/Foreign/C/Types.hs @@ -51,7 +51,7 @@ import Foreign.C.Types -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Floating () import TextShow.Data.Integral () diff --git a/src/TextShow/Foreign/Ptr.hs b/src/TextShow/Foreign/Ptr.hs --- a/src/TextShow/Foreign/Ptr.hs +++ b/src/TextShow/Foreign/Ptr.hs @@ -23,6 +23,7 @@ ) where import Data.Monoid.Compat ((<>)) +import Data.Semigroup (mtimesDefault) import Data.Text.Lazy.Builder (Builder, singleton) import Foreign.ForeignPtr (ForeignPtr) @@ -33,9 +34,9 @@ import GHC.Ptr (Ptr(..)) import GHC.Prim (addr2Int#, int2Word#, unsafeCoerce#) -import TextShow.Classes (TextShow(showb, showbPrec), TextShow1(..)) +import TextShow.Classes (TextShow(..), TextShow1(..)) import TextShow.Data.Integral (showbHex, showbIntPrec, showbWord) -import TextShow.Utils (lengthB, mtimesDefault) +import TextShow.Utils (lengthB) #include "MachDeps.h" #include "inline.h" @@ -77,11 +78,11 @@ {-# INLINE showbForeignPtr #-} instance TextShow (Ptr a) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined INLINE_INST_FUN(showbPrec) instance TextShow1 Ptr where - showbPrecWith _ _ (Ptr a) = padOut . showbHex $ wordToInteger (int2Word# (addr2Int# a)) + liftShowbPrec _ _ _ (Ptr a) = padOut . showbHex $ wordToInteger (int2Word# (addr2Int# a)) where padOut :: Builder -> Builder padOut ls = @@ -90,12 +91,12 @@ <> ls instance TextShow (FunPtr a) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined INLINE_INST_FUN(showbPrec) instance TextShow1 FunPtr where - showbPrecWith _ _ = showb . castFunPtrToPtr - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec _ _ _ = showb . castFunPtrToPtr + INLINE_INST_FUN(liftShowbPrec) instance TextShow IntPtr where showbPrec = showbIntPtrPrec @@ -106,9 +107,9 @@ INLINE_INST_FUN(showb) instance TextShow (ForeignPtr a) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined INLINE_INST_FUN(showbPrec) instance TextShow1 ForeignPtr where - showbPrecWith _ _ = showb . unsafeForeignPtrToPtr - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec _ _ _ = showb . unsafeForeignPtrToPtr + INLINE_INST_FUN(liftShowbPrec) diff --git a/src/TextShow/FromStringTextShow.hs b/src/TextShow/FromStringTextShow.hs --- a/src/TextShow/FromStringTextShow.hs +++ b/src/TextShow/FromStringTextShow.hs @@ -3,7 +3,11 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -11,12 +15,21 @@ {-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE DeriveLift #-} +#endif + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {-| Module: TextShow.FromStringTextShow Copyright: (C) 2014-2015 Ryan Scott @@ -27,31 +40,52 @@ The 'FromStringShow' and 'FromTextShow' data types. -} -module TextShow.FromStringTextShow (FromStringShow(..), FromTextShow(..)) where +module TextShow.FromStringTextShow ( + FromStringShow(..) + , FromTextShow(..) + , FromStringShow1(..) + , FromTextShow1(..) + , FromStringShow2(..) + , FromTextShow2(..) + ) where +#include "generic.h" + +import Data.Bifunctor.TH (deriveBifunctor, deriveBifoldable, + deriveBitraversable) import Data.Data (Data, Typeable) +import Data.Functor.Classes (Show1(..)) -#if __GLASGOW_HASKELL__ < 706 +#if !defined(__LANGUAGE_DERIVE_GENERIC1__) import qualified Generics.Deriving.TH as Generics #endif -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -# if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -# endif +#if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic, Generic1) #endif +import Language.Haskell.TH.Lift + import Prelude () import Prelude.Compat -import Text.Read (Read(..), readListPrecDefault) +import Text.ParserCombinators.ReadPrec (ReadPrec) +import Text.Read (Read(..)) -import TextShow.Classes (TextShow(..), TextShow1(..), +import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..), + showbPrec1, showbPrec2, + showbPrecToShowsPrec, showsPrecToShowbPrec, showbToShows, showsToShowb) +import TextShow.Utils (coerce) -#include "inline.h" +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) +import Text.Show (showListWith) +#else +import Data.Functor.Classes (Show2(..), showsPrec1, showsPrec2) +#endif +------------------------------------------------------------------------------- + -- | The 'TextShow' instance for 'FromStringShow' is based on its @String@ -- 'Show' instance. That is, -- @@ -65,37 +99,56 @@ , Eq , Foldable , Functor -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 706 , Generic -# if __GLASGOW_HASKELL__ >= 706 , Generic1 -# endif #endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif , Ord , Traversable , Typeable ) instance Read a => Read (FromStringShow a) where - readPrec = FromStringShow <$> readPrec - INLINE_INST_FUN(readPrec) - - readListPrec = readListPrecDefault - INLINE_INST_FUN(readListPrec) + readPrec = coerce (readPrec :: ReadPrec a) + readsPrec = coerce (readsPrec :: Int -> ReadS a) + readList = coerce (readList :: ReadS [a]) + readListPrec = coerce (readListPrec :: ReadPrec [a]) instance Show a => TextShow (FromStringShow a) where - showbPrec p = showsToShowb showsPrec p . fromStringShow - INLINE_INST_FUN(showbPrec) + showbPrec p = showsPrecToShowbPrec showsPrec p . fromStringShow + showb = showsToShowb shows . fromStringShow + showbList l = showsToShowb showList (coerce l :: [a]) instance Show a => Show (FromStringShow a) where - showsPrec p = showsPrec p . fromStringShow - INLINE_INST_FUN(showsPrec) + showsPrec = coerce (showsPrec :: Int -> a -> ShowS) + show = coerce (show :: a -> String) + showList = coerce (showList :: [a] -> ShowS) +instance Show1 FromStringShow where +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) + liftShowList _ sl = sl . coerceList + where + coerceList :: [FromStringShow a] -> [a] + coerceList = coerce + liftShowsPrec sp _ p = sp p . fromStringShow +#else + showsPrec1 p = showsPrec p . fromStringShow +#endif + instance TextShow1 FromStringShow where - showbPrecWith sp p = - showsToShowb (showbToShows sp) p . fromStringShow - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec sp' _ p = + showsPrecToShowbPrec (showbPrecToShowsPrec sp') p . fromStringShow + liftShowbList _ sl' = showsToShowb (showbToShows sl') . coerceList + where + coerceList :: [FromStringShow a] -> [a] + coerceList = coerce + +------------------------------------------------------------------------------- + -- | The @String@ 'Show' instance for 'FromTextShow' is based on its -- 'TextShow' instance. That is, -- @@ -109,12 +162,13 @@ , Eq , Foldable , Functor -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 706 , Generic -# if __GLASGOW_HASKELL__ >= 706 , Generic1 -# endif #endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif , Ord , TextShow , Traversable @@ -122,30 +176,421 @@ ) instance Read a => Read (FromTextShow a) where - readPrec = FromTextShow <$> readPrec - INLINE_INST_FUN(readPrec) - - readListPrec = readListPrecDefault - INLINE_INST_FUN(readListPrec) + readPrec = coerce (readPrec :: ReadPrec a) + readsPrec = coerce (readsPrec :: Int -> ReadS a) + readList = coerce (readList :: ReadS [a]) + readListPrec = coerce (readListPrec :: ReadPrec [a]) instance TextShow a => Show (FromTextShow a) where - showsPrec p = showbToShows showbPrec p . fromTextShow - INLINE_INST_FUN(showsPrec) + showsPrec p = showbPrecToShowsPrec showbPrec p . fromTextShow + show (FromTextShow x) = showbToShows showb x "" + showList l = showbToShows showbList (coerce l :: [a]) +instance Show1 FromTextShow where +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) + liftShowList _ sl = showbToShows (showsToShowb sl) . coerceList + where + coerceList :: [FromTextShow a] -> [a] + coerceList = coerce + liftShowsPrec sp _ p + = showbPrecToShowsPrec (showsPrecToShowbPrec sp) p . fromTextShow +#else + showsPrec1 p + = showbPrecToShowsPrec (showsPrecToShowbPrec showsPrec) p . fromTextShow +#endif + instance TextShow1 FromTextShow where - showbPrecWith sp p = sp p . fromTextShow - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec sp' _ p = sp' p . fromTextShow + liftShowbList _ sl' = sl' . coerceList + where + coerceList :: [FromTextShow a] -> [a] + coerceList = coerce + ------------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ < 706 -$(Generics.deriveMeta ''FromStringShow) -$(Generics.deriveRepresentable1 ''FromStringShow) -$(Generics.deriveMeta ''FromTextShow) -$(Generics.deriveRepresentable1 ''FromTextShow) +-- | The 'TextShow1' instance for 'FromStringShow1' is based on its @String@ +-- 'Show1' instance. That is, +-- +-- @ +-- 'liftShowbPrec' sp sl p ('FromStringShow1' x) = +-- 'showsPrecToShowbPrec' ('liftShowsPrec' ('showbPrecToShowsPrec' sp) +-- ('showbToShows' sl)) +-- p x +-- @ +-- +-- /Since: 3/ +newtype FromStringShow1 f a = FromStringShow1 { fromStringShow1 :: f a } + deriving ( Eq +#if __GLASGOW_HASKELL__ >= 706 + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif #endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif + , Ord + ) -#if __GLASGOW_HASKELL__ < 702 -$(Generics.deriveRepresentable0 ''FromStringShow) -$(Generics.deriveRepresentable0 ''FromTextShow) +deriving instance Show1 f => Show1 (FromStringShow1 f) +deriving instance Functor f => Functor (FromStringShow1 f) +deriving instance Foldable f => Foldable (FromStringShow1 f) +deriving instance Traversable f => Traversable (FromStringShow1 f) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable FromStringShow1 +deriving instance ( Data (f a), Typeable f, Typeable a + ) => Data (FromStringShow1 f (a :: *)) +#endif + +instance Read (f a) => Read (FromStringShow1 f a) where + readPrec = coerce (readPrec :: ReadPrec (f a)) + readsPrec = coerce (readsPrec :: Int -> ReadS (f a)) + readList = coerce (readList :: ReadS [f a]) + readListPrec = coerce (readListPrec :: ReadPrec [f a]) + +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +-- | Not available if using @transformers-0.4@ +instance (Show1 f, Show a) => TextShow (FromStringShow1 f a) where + showbPrec = liftShowbPrec (showsPrecToShowbPrec showsPrec) + (showsToShowb showList) + showbList = liftShowbList (showsPrecToShowbPrec showsPrec) + (showsToShowb showList) + +-- | Not available if using @transformers-0.4@ +instance Show1 f => TextShow1 (FromStringShow1 f) where + liftShowbPrec sp sl p = + showsPrecToShowbPrec (liftShowsPrec (showbPrecToShowsPrec sp) + (showbToShows sl)) + p . fromStringShow1 + liftShowbList sp sl = + showsToShowb (liftShowList (showbPrecToShowsPrec sp) + (showbToShows sl)) + . coerceList + where + coerceList :: [FromStringShow1 f a] -> [f a] + coerceList = coerce +#endif + +instance (Show1 f, Show a) => Show (FromStringShow1 f a) where + showsPrec = showsPrec1 + showList = liftShowList showsPrec showList + +------------------------------------------------------------------------------- + +-- | The @String@ 'Show1' instance for 'FromTextShow1' is based on its +-- 'TextShow1' instance. That is, +-- +-- @ +-- 'liftShowsPrec' sp sl p ('FromTextShow1' x) = +-- 'showbPrecToShowsPrec' ('liftShowbPrec' ('showsPrecToShowbPrec' sp) +-- ('showsToShowb' sl)) +-- p x +-- @ +-- +-- /Since: 3/ +newtype FromTextShow1 f a = FromTextShow1 { fromTextShow1 :: f a } + deriving ( Eq +#if __GLASGOW_HASKELL__ >= 706 + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif +#endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif + , Ord + ) + +deriving instance TextShow1 f => TextShow1 (FromTextShow1 f) +deriving instance Functor f => Functor (FromTextShow1 f) +deriving instance Foldable f => Foldable (FromTextShow1 f) +deriving instance Traversable f => Traversable (FromTextShow1 f) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable FromTextShow1 +deriving instance ( Data (f a), Typeable f, Typeable a + ) => Data (FromTextShow1 f (a :: *)) +#endif + +instance Read (f a) => Read (FromTextShow1 f a) where + readPrec = coerce (readPrec :: ReadPrec (f a)) + readsPrec = coerce (readsPrec :: Int -> ReadS (f a)) + readList = coerce (readList :: ReadS [f a]) + readListPrec = coerce (readListPrec :: ReadPrec [f a]) + +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +-- | Not available if using @transformers-0.4@ +instance (TextShow1 f, TextShow a) => Show (FromTextShow1 f a) where + showsPrec = liftShowsPrec (showbPrecToShowsPrec showbPrec) + (showbToShows showbList) + showList = liftShowList (showbPrecToShowsPrec showbPrec) + (showbToShows showbList) +#endif + +instance TextShow1 f => Show1 (FromTextShow1 f) where +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) + liftShowList sp sl = + showbToShows (liftShowbList (showsPrecToShowbPrec sp) + (showsToShowb sl)) + . coerceList + where + coerceList :: [FromTextShow1 f a] -> [f a] + coerceList = coerce + liftShowsPrec sp sl p +#else + showsPrec1 p +#endif + = showbPrecToShowsPrec (liftShowbPrec (showsPrecToShowbPrec sp) + (showsToShowb sl)) + p . fromTextShow1 + +instance (TextShow1 f, TextShow a) => TextShow (FromTextShow1 f a) where + showbPrec = showbPrec1 + showbList = liftShowbList showbPrec showbList + +------------------------------------------------------------------------------- + +-- | The 'TextShow2' instance for 'FromStringShow2' is based on its @String@ +-- 'Show2' instance. That is, +-- +-- @ +-- 'liftShowbPrec2' sp1 sl1 sp2 sl2 p ('FromStringShow2' x) = +-- 'showsPrecToShowbPrec' ('liftShowsPrec2' ('showbPrecToShowsPrec' sp1) +-- ('showbToShows' sl1) +-- ('showbPrecToShowsPrec' sp2) +-- ('showbToShows' sl2)) +-- p x +-- @ +-- +-- /Since: 3/ +newtype FromStringShow2 f a b = FromStringShow2 { fromStringShow2 :: f a b } + deriving ( Eq +#if __GLASGOW_HASKELL__ >= 706 + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif +#endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif + , Ord + ) + +deriving instance Functor (f a) => Functor (FromStringShow2 f a) +deriving instance Foldable (f a) => Foldable (FromStringShow2 f a) +deriving instance Traversable (f a) => Traversable (FromStringShow2 f a) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable FromStringShow2 +deriving instance ( Data (f a b), Typeable f, Typeable a, Typeable b + ) => Data (FromStringShow2 f (a :: *) (b :: *)) +#endif + +instance Read (f a b) => Read (FromStringShow2 f a b) where + readPrec = coerce (readPrec :: ReadPrec (f a b)) + readsPrec = coerce (readsPrec :: Int -> ReadS (f a b)) + readList = coerce (readList :: ReadS [f a b]) + readListPrec = coerce (readListPrec :: ReadPrec [f a b]) + +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +-- TODO: Manually implement this when you can derive Show2 (someday) +-- | Not available if using @transformers-0.4@ +deriving instance Show2 f => Show2 (FromStringShow2 f) + +-- | Not available if using @transformers-0.4@ +instance (Show2 f, Show a, Show b) => TextShow (FromStringShow2 f a b) where + showbPrec = liftShowbPrec (showsPrecToShowbPrec showsPrec) + (showsToShowb showList) + showbList = liftShowbList (showsPrecToShowbPrec showsPrec) + (showsToShowb showList) + +-- | Not available if using @transformers-0.4@ +instance (Show2 f, Show a) => TextShow1 (FromStringShow2 f a) where + liftShowbPrec = liftShowbPrec2 (showsPrecToShowbPrec showsPrec) + (showsToShowb showList) + liftShowbList = liftShowbList2 (showsPrecToShowbPrec showsPrec) + (showsToShowb showList) + +-- | Not available if using @transformers-0.4@ +instance Show2 f => TextShow2 (FromStringShow2 f) where + liftShowbPrec2 sp1 sl1 sp2 sl2 p = + showsPrecToShowbPrec (liftShowsPrec2 (showbPrecToShowsPrec sp1) + (showbToShows sl1) + (showbPrecToShowsPrec sp2) + (showbToShows sl2)) + p . fromStringShow2 + liftShowbList2 sp1 sl1 sp2 sl2 = + showsToShowb (liftShowList2 (showbPrecToShowsPrec sp1) + (showbToShows sl1) + (showbPrecToShowsPrec sp2) + (showbToShows sl2)) + . coerceList + where + coerceList :: [FromStringShow2 f a b] -> [f a b] + coerceList = coerce + +-- | Not available if using @transformers-0.4@ +instance (Show2 f, Show a, Show b) => Show (FromStringShow2 f a b) where + showsPrec = showsPrec2 + showList = liftShowList2 showsPrec showList showsPrec showList + +-- | Not available if using @transformers-0.4@ +instance (Show2 f, Show a) => Show1 (FromStringShow2 f a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + liftShowList = liftShowList2 showsPrec showList +#endif + +------------------------------------------------------------------------------- + +-- | The @String@ 'Show2' instance for 'FromTextShow2' is based on its +-- 'TextShow2' instance. That is, +-- +-- @ +-- liftShowsPrec2 sp1 sl1 sp2 sl2 p ('FromTextShow2' x) = +-- 'showbPrecToShowsPrec' ('liftShowbPrec2' ('showsPrecToShowbPrec' sp1) +-- ('showsToShowb' sl1) +-- ('showsPrecToShowbPrec' sp2) +-- ('showsToShowb' sl2)) +-- p x +-- @ +-- +-- /Since: 3/ +newtype FromTextShow2 f a b = FromTextShow2 { fromTextShow2 :: f a b } + deriving ( Eq +#if __GLASGOW_HASKELL__ >= 706 + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif +#endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif + , Ord + ) + +deriving instance TextShow2 f => TextShow2 (FromTextShow2 f) +deriving instance Functor (f a) => Functor (FromTextShow2 f a) +deriving instance Foldable (f a) => Foldable (FromTextShow2 f a) +deriving instance Traversable (f a) => Traversable (FromTextShow2 f a) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable FromTextShow2 +deriving instance ( Data (f a b), Typeable f, Typeable a, Typeable b + ) => Data (FromTextShow2 f (a :: *) (b :: *)) +#endif + +instance Read (f a b) => Read (FromTextShow2 f a b) where + readPrec = coerce (readPrec :: ReadPrec (f a b)) + readsPrec = coerce (readsPrec :: Int -> ReadS (f a b)) + readList = coerce (readList :: ReadS [f a b]) + readListPrec = coerce (readListPrec :: ReadPrec [f a b]) + +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +-- | Not available if using @transformers-0.4@ +instance (TextShow2 f, TextShow a, TextShow b) => Show (FromTextShow2 f a b) where + showsPrec = liftShowsPrec (showbPrecToShowsPrec showbPrec) + (showbToShows showbList) + showList = liftShowList (showbPrecToShowsPrec showbPrec) + (showbToShows showbList) + +-- | Not available if using @transformers-0.4@ +instance (TextShow2 f, TextShow a) => Show1 (FromTextShow2 f a) where + liftShowsPrec = liftShowsPrec2 (showbPrecToShowsPrec showbPrec) + (showbToShows showbList) + liftShowList = liftShowList2 (showbPrecToShowsPrec showbPrec) + (showbToShows showbList) + +-- | Not available if using @transformers-0.4@ +instance TextShow2 f => Show2 (FromTextShow2 f) where + liftShowsPrec2 sp1 sl1 sp2 sl2 p = + showbPrecToShowsPrec (liftShowbPrec2 (showsPrecToShowbPrec sp1) + (showsToShowb sl1) + (showsPrecToShowbPrec sp2) + (showsToShowb sl2)) + p . fromTextShow2 + liftShowList2 sp1 sl1 sp2 sl2 = + showbToShows (liftShowbList2 (showsPrecToShowbPrec sp1) + (showsToShowb sl1) + (showsPrecToShowbPrec sp2) + (showsToShowb sl2)) + . coerceList + where + coerceList :: [FromTextShow2 f a b] -> [f a b] + coerceList = coerce +#endif + +instance (TextShow2 f, TextShow a, TextShow b) => TextShow (FromTextShow2 f a b) where + showbPrec = showbPrec2 + showbList = liftShowbList2 showbPrec showbList showbPrec showbList + +instance (TextShow2 f, TextShow a) => TextShow1 (FromTextShow2 f a) where + liftShowbPrec = liftShowbPrec2 showbPrec showbList + liftShowbList = liftShowbList2 showbPrec showbList + +------------------------------------------------------------------------------- + +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) +liftShowsPrec :: (Show1 f, Show a) => (Int -> a -> ShowS) -> ([a] -> ShowS) + -> Int -> f a -> ShowS +liftShowsPrec _ _ = showsPrec1 + +liftShowList :: (Show1 f, Show a) => (Int -> a -> ShowS) -> ([a] -> ShowS) + -> [f a] -> ShowS +liftShowList sp' sl' = showListWith (liftShowsPrec sp' sl' 0) + +sp :: Int -> a -> ShowS +sp = undefined + +sl :: [a] -> ShowS +sl = undefined +#endif + +------------------------------------------------------------------------------- + +$(deriveBifunctor ''FromStringShow2) +$(deriveBifunctor ''FromTextShow2) +$(deriveBifoldable ''FromStringShow2) +$(deriveBifoldable ''FromTextShow2) +$(deriveBitraversable ''FromStringShow2) +$(deriveBitraversable ''FromTextShow2) + +#if __GLASGOW_HASKELL__ < 800 +$(deriveLift ''FromStringShow) +$(deriveLift ''FromTextShow) + +instance Lift (f a) => Lift (FromStringShow1 f a) where + lift = $(makeLift ''FromStringShow1) +instance Lift (f a) => Lift (FromTextShow1 f a) where + lift = $(makeLift ''FromTextShow1) + +instance Lift (f a b) => Lift (FromStringShow2 f a b) where + lift = $(makeLift ''FromStringShow2) +instance Lift (f a b) => Lift (FromTextShow2 f a b) where + lift = $(makeLift ''FromTextShow2) +#endif + +#if !defined(__LANGUAGE_DERIVE_GENERIC1__) +$(Generics.deriveMeta ''FromStringShow1) +$(Generics.deriveRepresentable1 ''FromStringShow1) +$(Generics.deriveMeta ''FromTextShow1) +$(Generics.deriveRepresentable1 ''FromTextShow1) +$(Generics.deriveMeta ''FromStringShow2) +$(Generics.deriveRepresentable1 ''FromStringShow2) +$(Generics.deriveMeta ''FromTextShow2) +$(Generics.deriveRepresentable1 ''FromTextShow2) +#endif + +#if __GLASGOW_HASKELL__ < 706 +$(Generics.deriveAll0And1 ''FromStringShow) +$(Generics.deriveAll0And1 ''FromTextShow) +$(Generics.deriveRepresentable0 ''FromStringShow1) +$(Generics.deriveRepresentable0 ''FromStringShow2) +$(Generics.deriveRepresentable0 ''FromTextShow1) +$(Generics.deriveRepresentable0 ''FromTextShow2) #endif diff --git a/src/TextShow/Functions.hs b/src/TextShow/Functions.hs --- a/src/TextShow/Functions.hs +++ b/src/TextShow/Functions.hs @@ -16,7 +16,7 @@ module TextShow.Functions (showbFunction) where import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showb, showbPrec), TextShow1(..), TextShow2(..)) +import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..)) #include "inline.h" @@ -28,13 +28,13 @@ {-# INLINE showbFunction #-} instance TextShow (a -> b) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined INLINE_INST_FUN(showbPrec) instance TextShow1 ((->) a) where - showbPrecWith = showbPrecWith2 undefined - INLINE_INST_FUN(showbPrecWith) + liftShowbPrec = liftShowbPrec2 undefined undefined + INLINE_INST_FUN(liftShowbPrec) instance TextShow2 (->) where - showbPrecWith2 _ _ _ _ = "" - INLINE_INST_FUN(showbPrecWith2) + liftShowbPrec2 _ _ _ _ _ _ = "" + INLINE_INST_FUN(liftShowbPrec2) diff --git a/src/TextShow/GHC/Event.hs b/src/TextShow/GHC/Event.hs --- a/src/TextShow/GHC/Event.hs +++ b/src/TextShow/GHC/Event.hs @@ -42,7 +42,7 @@ import Prelude () import Prelude.Compat -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Integral () import TextShow.System.Posix.Types () import TextShow.TH.Internal (deriveTextShow) diff --git a/src/TextShow/GHC/Fingerprint.hs b/src/TextShow/GHC/Fingerprint.hs --- a/src/TextShow/GHC/Fingerprint.hs +++ b/src/TextShow/GHC/Fingerprint.hs @@ -24,14 +24,15 @@ ) where import Data.Monoid.Compat ((<>)) +import Data.Semigroup (mtimesDefault) import Data.Text.Lazy.Builder (Builder, singleton) import Data.Word (Word64) import GHC.Fingerprint.Type (Fingerprint(..)) -import TextShow.Classes (TextShow(showb)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Integral (showbHex) -import TextShow.Utils (lengthB, mtimesDefault) +import TextShow.Utils (lengthB) -- | Convert a 'Fingerprint' to a 'Builder'. -- This function is only available with @base-4.4.0.0@ or later. diff --git a/src/TextShow/GHC/Generics.hs b/src/TextShow/GHC/Generics.hs --- a/src/TextShow/GHC/Generics.hs +++ b/src/TextShow/GHC/Generics.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} @@ -21,21 +22,27 @@ -} module TextShow.GHC.Generics ( showbU1 - , showbPar1PrecWith + , liftShowbPar1Prec , showbRec1Prec - , showbRec1PrecWith - , showbK1PrecWith + , liftShowbRec1Prec + , liftShowbK1Prec , showbM1Prec - , showbM1PrecWith + , liftShowbM1Prec , showbSumTypePrec - , showbSumTypePrecWith + , liftShowbSumTypePrec , showbProductTypePrec - , showbProductTypePrecWith + , liftShowbProductTypePrec , showbCompFunctorsPrec - , showbCompFunctorsPrecWith + , liftShowbCompFunctorsPrec , showbFixityPrec , showbAssociativity +#if MIN_VERSION_base(4,9,0) + , showbSourceUnpackedness + , showbSourceStrictness + , showbDecidedStrictness +#else , showbArityPrec +#endif , showbUCharPrec , showbUDoublePrec , showbUFloatPrec @@ -47,12 +54,12 @@ import Generics.Deriving.Base -import TextShow.Classes (TextShow(showb, showbPrec), TextShow1(..), TextShow2(..)) +import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..)) import TextShow.Data.Char () import TextShow.Data.Floating () import TextShow.Data.Integral () import TextShow.TH.Internal (deriveTextShow, deriveTextShow1, makeShowbPrec, - makeShowbPrecWith, makeShowbPrecWith2) + makeLiftShowbPrec, makeLiftShowbPrec2) #if !(MIN_VERSION_template_haskell(2,7,0)) import Data.Monoid.Compat ((<>)) @@ -73,10 +80,10 @@ -- | Convert a 'Par1' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbPar1PrecWith :: (Int -> p -> Builder) -> Int -> Par1 p -> Builder -showbPar1PrecWith = showbPrecWith -{-# INLINE showbPar1PrecWith #-} +-- /Since: 3/ +liftShowbPar1Prec :: (Int -> p -> Builder) -> Int -> Par1 p -> Builder +liftShowbPar1Prec sp = liftShowbPrec sp undefined +{-# INLINE liftShowbPar1Prec #-} -- | Convert a 'Rec1' value to a 'Builder' with the given precedence. -- @@ -87,17 +94,18 @@ -- | Convert a 'Rec1' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbRec1PrecWith :: TextShow1 f => (Int -> p -> Builder) -> Int -> Rec1 f p -> Builder -showbRec1PrecWith = showbPrecWith -{-# INLINE showbRec1PrecWith #-} +-- /Since: 3/ +liftShowbRec1Prec :: TextShow1 f => (Int -> p -> Builder) -> ([p] -> Builder) + -> Int -> Rec1 f p -> Builder +liftShowbRec1Prec = liftShowbPrec +{-# INLINE liftShowbRec1Prec #-} -- | Convert a 'K1' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbK1PrecWith :: (Int -> c -> Builder) -> Int -> K1 i c p -> Builder -showbK1PrecWith sp = showbPrecWith2 sp undefined -{-# INLINE showbK1PrecWith #-} +-- /Since: 3/ +liftShowbK1Prec :: (Int -> c -> Builder) -> Int -> K1 i c p -> Builder +liftShowbK1Prec sp = liftShowbPrec2 sp undefined undefined undefined +{-# INLINE liftShowbK1Prec #-} -- | Convert an 'M1' value to a 'Builder' with the given precedence. -- @@ -108,10 +116,11 @@ -- | Convert an 'M1' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbM1PrecWith :: TextShow1 f => (Int -> p -> Builder) -> Int -> M1 i c f p -> Builder -showbM1PrecWith = showbPrecWith -{-# INLINE showbM1PrecWith #-} +-- /Since: 3/ +liftShowbM1Prec :: TextShow1 f => (Int -> p -> Builder) -> ([p] -> Builder) + -> Int -> M1 i c f p -> Builder +liftShowbM1Prec = liftShowbPrec +{-# INLINE liftShowbM1Prec #-} -- | Convert a '(:+:)' value to a 'Builder' with the given precedence. -- @@ -122,10 +131,12 @@ -- | Convert a '(:+:)' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbSumTypePrecWith :: (TextShow1 f, TextShow1 g) => (Int -> p -> Builder) -> Int -> (f :+: g) p -> Builder -showbSumTypePrecWith = showbPrecWith -{-# INLINE showbSumTypePrecWith #-} +-- /Since: 3/ +liftShowbSumTypePrec :: (TextShow1 f, TextShow1 g) + => (Int -> p -> Builder) -> ([p] -> Builder) + -> Int -> (f :+: g) p -> Builder +liftShowbSumTypePrec = liftShowbPrec +{-# INLINE liftShowbSumTypePrec #-} -- | Convert a '(:*:)' value to a 'Builder' with the given precedence. -- @@ -136,10 +147,12 @@ -- | Convert a '(:*:)' value to a 'Builder' with the given show function and precedence. -- --- /Since: 2/ -showbProductTypePrecWith :: (TextShow1 f, TextShow1 g) => (Int -> p -> Builder) -> Int -> (f :*: g) p -> Builder -showbProductTypePrecWith = showbPrecWith -{-# INLINE showbProductTypePrecWith #-} +-- /Since: 3/ +liftShowbProductTypePrec :: (TextShow1 f, TextShow1 g) + => (Int -> p -> Builder) -> ([p] -> Builder) + -> Int -> (f :*: g) p -> Builder +liftShowbProductTypePrec = liftShowbPrec +{-# INLINE liftShowbProductTypePrec #-} -- | Convert a '(:.:)' value to a 'Builder' with the given precedence. -- @@ -149,12 +162,13 @@ {-# INLINE showbCompFunctorsPrec #-} -- | Convert a '(:.:)' value to a 'Builder' with the given show function and precedence. --- This function is only available with @base-4.4.0.0@ or later. -- --- /Since: 2/ -showbCompFunctorsPrecWith :: (TextShow1 f, TextShow1 g) => (Int -> p -> Builder) -> Int -> (f :.: g) p -> Builder -showbCompFunctorsPrecWith = showbPrecWith -{-# INLINE showbCompFunctorsPrecWith #-} +-- /Since: 3/ +liftShowbCompFunctorsPrec :: (TextShow1 f, TextShow1 g) + => (Int -> p -> Builder) -> ([p] -> Builder) + -> Int -> (f :.: g) p -> Builder +liftShowbCompFunctorsPrec = liftShowbPrec +{-# INLINE liftShowbCompFunctorsPrec #-} -- | Convert a 'Fixity' value to a 'Builder' with the given precedence. -- @@ -164,57 +178,83 @@ {-# INLINE showbFixityPrec #-} -- | Convert an 'Associativity' value to a 'Builder'. --- This function is only available with @base-4.4.0.0@ or later. -- -- /Since: 2/ showbAssociativity :: Associativity -> Builder showbAssociativity = showb {-# INLINE showbAssociativity #-} +#if MIN_VERSION_base(4,9,0) +-- | Convert a 'SourceUnpackedness' value to a 'Builder'. +-- This function is only available with @base-4.9.0.0@ or later. +-- +-- /Since: 3/ +showbSourceUnpackedness :: SourceUnpackedness -> Builder +showbSourceUnpackedness = showb +{-# INLINE showbSourceUnpackedness #-} + +-- | Convert a 'SourceStrictness' value to a 'Builder'. +-- This function is only available with @base-4.9.0.0@ or later. +-- +-- /Since: 3/ +showbSourceStrictness :: SourceStrictness -> Builder +showbSourceStrictness = showb +{-# INLINE showbSourceStrictness #-} + +-- | Convert a 'DecidedStrictness' value to a 'Builder'. +-- This function is only available with @base-4.9.0.0@ or later. +-- +-- /Since: 3/ +showbDecidedStrictness :: DecidedStrictness -> Builder +showbDecidedStrictness = showb +{-# INLINE showbDecidedStrictness #-} +#else -- | Convert an 'Arity' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8@ or earlier. -- -- /Since: 2/ showbArityPrec :: Int -> Arity -> Builder showbArityPrec = showbPrec {-# INLINE showbArityPrec #-} +#endif -- | Convert a 'UChar' to a 'Builder' with the given precedence. -- --- /Since: 2.2/ +-- /Since: 2.1.2/ showbUCharPrec :: Int -> UChar p -> Builder showbUCharPrec = showbPrec {-# INLINE showbUCharPrec #-} -- | Convert a 'UDouble' to a 'Builder' with the given precedence. -- --- /Since: 2.2/ +-- /Since: 2.1.2/ showbUDoublePrec :: Int -> UDouble p -> Builder showbUDoublePrec = showbPrec {-# INLINE showbUDoublePrec #-} -- | Convert a 'UFloat' to a 'Builder' with the given precedence. -- --- /Since: 2.2/ +-- /Since: 2.1.2/ showbUFloatPrec :: Int -> UFloat p -> Builder showbUFloatPrec = showbPrec {-# INLINE showbUFloatPrec #-} -- | Convert a 'UInt' to a 'Builder' with the given precedence. -- --- /Since: 2.2/ +-- /Since: 2.1.2/ showbUIntPrec :: Int -> UInt p -> Builder showbUIntPrec = showbPrec {-# INLINE showbUIntPrec #-} -- | Convert a 'UWord' to a 'Builder' with the given precedence. -- --- /Since: 2.2/ +-- /Since: 2.1.2/ showbUWordPrec :: Int -> UWord p -> Builder showbUWordPrec = showbPrec {-# INLINE showbUWordPrec #-} instance TextShow (U1 p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined $(deriveTextShow1 ''U1) $(deriveTextShow ''Par1) @@ -225,16 +265,16 @@ $(deriveTextShow1 ''Rec1) instance TextShow c => TextShow (K1 i c p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow c => TextShow1 (K1 i c) where - showbPrecWith = showbPrecWith2 showbPrec + liftShowbPrec = liftShowbPrec2 showbPrec showbList instance TextShow2 (K1 i) where - showbPrecWith2 = $(makeShowbPrecWith2 ''K1) + liftShowbPrec2 = $(makeLiftShowbPrec2 ''K1) instance TextShow (f p) => TextShow (M1 i c f p) where showbPrec = $(makeShowbPrec ''M1) instance TextShow1 f => TextShow1 (M1 i c f) where - showbPrecWith = $(makeShowbPrecWith ''M1) + liftShowbPrec = $(makeLiftShowbPrec ''M1) instance (TextShow (f p), TextShow (g p)) => TextShow ((f :+: g) p) where showbPrec = $(makeShowbPrec ''(:+:)) @@ -270,41 +310,41 @@ $(deriveTextShow1 'UWord) #else instance TextShow (UChar p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow1 UChar where - showbPrecWith _ p (UChar c) = showbParen (p > appPrec) $ + liftShowbPrec _ _ p (UChar c) = showbParen (p > appPrec) $ fromString "UChar " <> singleton '{' <> fromString "uChar# = " <> showb (C# c) <> singleton '}' instance TextShow (UDouble p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow1 UDouble where - showbPrecWith _ p (UDouble d) = showbParen (p > appPrec) $ + liftShowbPrec _ _ p (UDouble d) = showbParen (p > appPrec) $ fromString "UDouble " <> singleton '{' <> fromString "uDouble# = " <> showb (D# d) <> singleton '}' instance TextShow (UFloat p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow1 UFloat where - showbPrecWith _ p (UFloat f) = showbParen (p > appPrec) $ + liftShowbPrec _ _ p (UFloat f) = showbParen (p > appPrec) $ fromString "UFloat " <> singleton '{' <> fromString "uFloat# = " <> showb (F# f) <> singleton '}' instance TextShow (UInt p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow1 UInt where - showbPrecWith _ p (UInt i) = showbParen (p > appPrec) $ + liftShowbPrec _ _ p (UInt i) = showbParen (p > appPrec) $ fromString "UInt " <> singleton '{' <> fromString "uInt# = " <> showb (I# i) <> singleton '}' instance TextShow (UWord p) where - showbPrec = showbPrecWith undefined + showbPrec = liftShowbPrec undefined undefined instance TextShow1 UWord where - showbPrecWith _ p (UWord w) = showbParen (p > appPrec) $ + liftShowbPrec _ _ p (UWord w) = showbParen (p > appPrec) $ fromString "UWord " <> singleton '{' <> fromString "uWord# = " <> showb (W# w) <> singleton '}' @@ -312,4 +352,10 @@ $(deriveTextShow ''Fixity) $(deriveTextShow ''Associativity) +#if MIN_VERSION_base(4,9,0) +$(deriveTextShow ''SourceUnpackedness) +$(deriveTextShow ''SourceStrictness) +$(deriveTextShow ''DecidedStrictness) +#else $(deriveTextShow ''Arity) +#endif diff --git a/src/TextShow/GHC/RTS/Flags.hs b/src/TextShow/GHC/RTS/Flags.hs --- a/src/TextShow/GHC/RTS/Flags.hs +++ b/src/TextShow/GHC/RTS/Flags.hs @@ -42,10 +42,7 @@ import GHC.RTS.Flags -import TextShow.Classes (TextShow(showbPrec)) -# if MIN_VERSION_base(4,8,2) -import TextShow.Classes (showb) -# endif +import TextShow.Classes (TextShow(..)) import TextShow.Data.Bool () import TextShow.Data.Char () import TextShow.Data.Floating () diff --git a/src/TextShow/GHC/TypeLits.hs b/src/TextShow/GHC/TypeLits.hs --- a/src/TextShow/GHC/TypeLits.hs +++ b/src/TextShow/GHC/TypeLits.hs @@ -42,7 +42,7 @@ #if MIN_VERSION_base(4,6,0) import Data.Text.Lazy.Builder (Builder) -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) # if MIN_VERSION_base(4,7,0) import GHC.TypeLits (SomeNat(..), SomeSymbol(..), natVal, symbolVal) diff --git a/src/TextShow/Generic.hs b/src/TextShow/Generic.hs --- a/src/TextShow/Generic.hs +++ b/src/TextShow/Generic.hs @@ -19,6 +19,10 @@ {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE DeriveLift #-} +#endif + {-| Module: TextShow.Generic Copyright: (C) 2014-2015 Ryan Scott @@ -55,11 +59,14 @@ , genericPrintTL , genericHPrintT , genericHPrintTL - , genericShowbPrecWith + , genericLiftShowbPrec , genericShowbPrec1 -- * The 'GTextShow' and 'GTextShow1' classes , GTextShow(..) + , GTextShowCon(..) , GTextShow1(..) + , GTextShow1Con(..) + , IsNullary(..) , ConType(..) ) where @@ -80,12 +87,14 @@ import GHC.Exts (Char(C#), Double(D#), Float(F#), Int(I#), Word(W#)) import GHC.Show (appPrec, appPrec1) +import Language.Haskell.TH.Lift + import Prelude () import Prelude.Compat import System.IO (Handle) -import TextShow.Classes (TextShow(showbPrec), TextShow1(..), +import TextShow.Classes (TextShow(..), TextShow1(..), showbListWith, showbParen, showbSpace) import TextShow.Instances () import TextShow.Utils (isInfixTypeCon, isTupleString) @@ -110,7 +119,7 @@ showbPrec = 'genericShowbPrec' instance TextShow1 D where - showbPrecWith = 'genericShowbPrecWith' + liftShowbPrec = 'genericLiftShowbPrec' @ -} @@ -186,7 +195,7 @@ -- -- /Since: 2/ genericShowbPrec :: (Generic a, GTextShow (Rep a)) => Int -> a -> Builder -genericShowbPrec p = gShowbPrec Pref p . from +genericShowbPrec p = gShowbPrec p . from -- | A 'Generic' implementation of 'showbList'. -- @@ -218,19 +227,20 @@ genericHPrintTL :: (Generic a, GTextShow (Rep a)) => Handle -> a -> IO () genericHPrintTL h = TL.hPutStrLn h . genericShowtl --- | A 'Generic1' implementation of 'showbPrecWith'. +-- | A 'Generic1' implementation of 'genericLiftShowbPrec'. -- -- /Since: 2/ -genericShowbPrecWith :: (Generic1 f, GTextShow1 (Rep1 f)) - => (Int -> a -> Builder) -> Int -> f a -> Builder -genericShowbPrecWith sp p = gShowbPrecWith Pref sp p . from1 +genericLiftShowbPrec :: (Generic1 f, GTextShow1 (Rep1 f)) + => (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> f a -> Builder +genericLiftShowbPrec sp sl p = gLiftShowbPrec sp sl p . from1 -- | A 'Generic'/'Generic1' implementation of 'showbPrec1'. -- -- /Since: 2/ genericShowbPrec1 :: (Generic a, Generic1 f, GTextShow (Rep a), GTextShow1 (Rep1 f)) => Int -> f a -> Builder -genericShowbPrec1 = genericShowbPrecWith genericShowbPrec +genericShowbPrec1 = genericLiftShowbPrec genericShowbPrec genericShowbList ------------------------------------------------------------------------------- @@ -247,6 +257,9 @@ #if __GLASGOW_HASKELL__ >= 702 , Generic #endif +#if __GLASGOW_HASKELL__ >= 800 + , Lift +#endif ) instance TextShow ConType where @@ -256,66 +269,66 @@ -- | Class of generic representation types ('Rep') that can be converted to -- a 'Builder'. -- --- /Since: 2/ +-- /Since: 3/ class GTextShow f where -- | This is used as the default generic implementation of 'showbPrec'. - gShowbPrec :: ConType -> Int -> f a -> Builder - -- | Whether a representation type has any constructors. - isNullary :: f a -> Bool - isNullary = error "generic showbPrec (isNullary): unnecessary case" -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL gShowbPrec #-} + gShowbPrec :: Int -> f a -> Builder +#if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable GTextShow #endif -instance GTextShow U1 where - gShowbPrec _ _ U1 = mempty - isNullary _ = True +instance GTextShow f => GTextShow (D1 d f) where + gShowbPrec p (M1 x) = gShowbPrec p x -instance TextShow c => GTextShow (K1 i c) where - gShowbPrec _ n (K1 a) = showbPrec n a - isNullary _ = False +instance (GTextShow f, GTextShow g) => GTextShow (f :+: g) where + gShowbPrec p (L1 x) = gShowbPrec p x + gShowbPrec p (R1 x) = gShowbPrec p x -instance (Constructor c, GTextShow f) => GTextShow (C1 c f) where - gShowbPrec = gShowbConstructor gShowbPrec isNullary +instance (Constructor c, GTextShowCon f, IsNullary f) => GTextShow (C1 c f) where + gShowbPrec = gShowbConstructor gShowbPrecCon -instance (Selector s, GTextShow f) => GTextShow (S1 s f) where - gShowbPrec = gShowbSelector gShowbPrec - isNullary (M1 x) = isNullary x +-- | Class of generic representation types ('Rep') for which the 'ConType' +-- has been determined. +class GTextShowCon f where + -- | Convert value of a specific 'ConType' to a 'Builder' with the given + -- precedence. + gShowbPrecCon :: ConType -> Int -> f a -> Builder -instance GTextShow f => GTextShow (D1 d f) where - gShowbPrec t n (M1 x) = gShowbPrec t n x +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable GTextShowCon +#endif -instance (GTextShow f, GTextShow g) => GTextShow (f :+: g) where - gShowbPrec t n (L1 x) = gShowbPrec t n x - gShowbPrec t n (R1 x) = gShowbPrec t n x +instance GTextShowCon V1 where + gShowbPrecCon = error "Void showbPrec" -instance (GTextShow f, GTextShow g) => GTextShow (f :*: g) where - gShowbPrec = gShowbProduct gShowbPrec gShowbPrec - -- If we have a product then it is not a nullary constructor - isNullary _ = False +instance GTextShowCon U1 where + gShowbPrecCon _ _ U1 = mempty -instance GTextShow UChar where - gShowbPrec _ = gShowbUCharPrec - isNullary _ = False +instance TextShow c => GTextShowCon (K1 i c) where + gShowbPrecCon _ p (K1 x) = showbPrec p x -instance GTextShow UDouble where - gShowbPrec _ = gShowbUDoublePrec - isNullary _ = False +instance (Selector s, GTextShowCon f) => GTextShowCon (S1 s f) where + gShowbPrecCon = gShowbSelector gShowbPrecCon -instance GTextShow UFloat where - gShowbPrec _ = gShowbUFloatPrec - isNullary _ = False +instance (GTextShowCon f, GTextShowCon g) => GTextShowCon (f :*: g) where + gShowbPrecCon = gShowbProduct gShowbPrecCon gShowbPrecCon -instance GTextShow UInt where - gShowbPrec _ = gShowbUIntPrec - isNullary _ = False +instance GTextShowCon UChar where + gShowbPrecCon _ = gShowbUCharPrec -instance GTextShow UWord where - gShowbPrec _ = gShowbUWordPrec - isNullary _ = False +instance GTextShowCon UDouble where + gShowbPrecCon _ = gShowbUDoublePrec +instance GTextShowCon UFloat where + gShowbPrecCon _ = gShowbUFloatPrec + +instance GTextShowCon UInt where + gShowbPrecCon _ = gShowbUIntPrec + +instance GTextShowCon UWord where + gShowbPrecCon _ = gShowbUWordPrec + ------------------------------------------------------------------------------- -- | Class of generic representation types ('Rep1') that can be converted to @@ -324,86 +337,133 @@ -- /Since: 2/ class GTextShow1 f where -- | This is used as the default generic implementation of 'showbPrecWith'. - gShowbPrecWith :: ConType -> (Int -> a -> Builder) -> Int -> f a -> Builder - -- | Whether a representation type has any constructors. - isNullary1 :: f a -> Bool - isNullary1 = error "generic showbPrecWith (isNullary1): unnecessary case" -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL gShowbPrecWith #-} + gLiftShowbPrec :: (Int -> a -> Builder) -> ([a] -> Builder) -> Int -> f a -> Builder +#if __GLASGOW_HASKELL__ >= 708 deriving instance Typeable GTextShow1 #endif -instance GTextShow1 U1 where - gShowbPrecWith _ _ _ U1 = mempty - isNullary1 _ = True +instance GTextShow1 f => GTextShow1 (D1 d f) where + gLiftShowbPrec sp sl p (M1 x) = gLiftShowbPrec sp sl p x -instance GTextShow1 Par1 where - gShowbPrecWith _ sp n (Par1 p) = sp n p - isNullary1 _ = False +instance GTextShow1 V1 where + gLiftShowbPrec = error "Void showbPrecWith" -instance TextShow c => GTextShow1 (K1 i c) where - gShowbPrecWith _ _ n (K1 a) = showbPrec n a - isNullary1 _ = False +instance (GTextShow1 f, GTextShow1 g) => GTextShow1 (f :+: g) where + gLiftShowbPrec sp sl p (L1 x) = gLiftShowbPrec sp sl p x + gLiftShowbPrec sp sl p (R1 x) = gLiftShowbPrec sp sl p x -instance TextShow1 f => GTextShow1 (Rec1 f) where - gShowbPrecWith _ sp n (Rec1 r) = showbPrecWith sp n r - isNullary1 _ = False +instance (Constructor c, GTextShow1Con f, IsNullary f) => GTextShow1 (C1 c f) where + gLiftShowbPrec sp sl = + gShowbConstructor (\t' -> gLiftShowbPrecCon t' sp sl) -instance (Constructor c, GTextShow1 f) => GTextShow1 (C1 c f) where - gShowbPrecWith t sp = gShowbConstructor (flip gShowbPrecWith sp) isNullary1 t +-- | Class of generic representation types ('Rep1') for which the 'ConType' +-- has been determined. +class GTextShow1Con f where + -- | Convert a value of a specific 'ConType' to a 'Builder' with the given + -- show function and precedence. + gLiftShowbPrecCon :: ConType -> (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> f a -> Builder -instance (Selector s, GTextShow1 f) => GTextShow1 (S1 s f) where - gShowbPrecWith t sp = gShowbSelector (flip gShowbPrecWith sp) t - isNullary1 (M1 x) = isNullary1 x +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable GTextShow1Con +#endif -instance GTextShow1 f => GTextShow1 (D1 d f) where - gShowbPrecWith t sp n (M1 x) = gShowbPrecWith t sp n x +instance GTextShow1Con U1 where + gLiftShowbPrecCon _ _ _ _ U1 = mempty -instance (GTextShow1 f, GTextShow1 g) => GTextShow1 (f :+: g) where - gShowbPrecWith t sp n (L1 x) = gShowbPrecWith t sp n x - gShowbPrecWith t sp n (R1 x) = gShowbPrecWith t sp n x +instance GTextShow1Con Par1 where + gLiftShowbPrecCon _ sp _ p (Par1 x) = sp p x -instance (GTextShow1 f, GTextShow1 g) => GTextShow1 (f :*: g) where - gShowbPrecWith t sp = gShowbProduct (flip gShowbPrecWith sp) (flip gShowbPrecWith sp) t - -- If we have a product then it is not a nullary constructor - isNullary1 _ = False +instance TextShow c => GTextShow1Con (K1 i c) where + gLiftShowbPrecCon _ _ _ p (K1 x) = showbPrec p x -instance (TextShow1 f, GTextShow1 g) => GTextShow1 (f :.: g) where - gShowbPrecWith t sp n (Comp1 c) = showbPrecWith (gShowbPrecWith t sp) n c - isNullary1 _ = False +instance TextShow1 f => GTextShow1Con (Rec1 f) where + gLiftShowbPrecCon _ sp sl p (Rec1 x) = liftShowbPrec sp sl p x -instance GTextShow1 UChar where - gShowbPrecWith _ _ = gShowbUCharPrec - isNullary1 _ = False +instance (Selector s, GTextShow1Con f) => GTextShow1Con (S1 s f) where + gLiftShowbPrecCon t sp sl = + gShowbSelector (\t' -> gLiftShowbPrecCon t' sp sl) t -instance GTextShow1 UDouble where - gShowbPrecWith _ _ = gShowbUDoublePrec - isNullary1 _ = False +instance (GTextShow1Con f, GTextShow1Con g) => GTextShow1Con (f :*: g) where + gLiftShowbPrecCon t sp sl = + gShowbProduct (\t' -> gLiftShowbPrecCon t' sp sl) + (\t' -> gLiftShowbPrecCon t' sp sl) t -instance GTextShow1 UFloat where - gShowbPrecWith _ _ = gShowbUFloatPrec - isNullary1 _ = False +instance (TextShow1 f, GTextShow1Con g) => GTextShow1Con (f :.: g) where + gLiftShowbPrecCon t sp sl p (Comp1 x) = + liftShowbPrec (gLiftShowbPrecCon t sp sl) + (showbListWith (gLiftShowbPrecCon t sp sl 0)) + p x -instance GTextShow1 UInt where - gShowbPrecWith _ _ = gShowbUIntPrec - isNullary1 _ = False +instance GTextShow1Con UChar where + gLiftShowbPrecCon _ _ _ = gShowbUCharPrec -instance GTextShow1 UWord where - gShowbPrecWith _ _ = gShowbUWordPrec - isNullary1 _ = False +instance GTextShow1Con UDouble where + gLiftShowbPrecCon _ _ _ = gShowbUDoublePrec +instance GTextShow1Con UFloat where + gLiftShowbPrecCon _ _ _ = gShowbUFloatPrec + +instance GTextShow1Con UInt where + gLiftShowbPrecCon _ _ _ = gShowbUIntPrec + +instance GTextShow1Con UWord where + gLiftShowbPrecCon _ _ _ = gShowbUWordPrec + ------------------------------------------------------------------------------- -- Shared code between GTextShow and GTextShow1 ------------------------------------------------------------------------------- -gShowbConstructor :: forall c f p. Constructor c +-- | Class of generic representation types that represent a constructor with +-- zero or more fields. +class IsNullary f where + -- Returns 'True' if the constructor has no fields. + isNullary :: f a -> Bool + +instance IsNullary U1 where + isNullary _ = True + +instance IsNullary Par1 where + isNullary _ = False + +instance IsNullary (K1 i c) where + isNullary _ = False + +instance IsNullary f => IsNullary (S1 s f) where + isNullary (M1 x) = isNullary x + +instance IsNullary (Rec1 f) where + isNullary _ = False + +instance IsNullary (f :*: g) where + isNullary _ = False + +instance IsNullary (f :.: g) where + isNullary _ = False + +instance IsNullary UChar where + isNullary _ = False + +instance IsNullary UDouble where + isNullary _ = False + +instance IsNullary UFloat where + isNullary _ = False + +instance IsNullary UInt where + isNullary _ = False + +instance IsNullary UWord where + isNullary _ = False + +gShowbConstructor :: forall c f p. + (Constructor c, IsNullary f) => (ConType -> Int -> f p -> Builder) - -> (f p -> Bool) - -> ConType -> Int -> C1 c f p -> Builder -gShowbConstructor gs isNull _ n c@(M1 x) = case fixity of - Prefix -> showbParen ( n > appPrec - && not ( isNull x + -> Int -> C1 c f p -> Builder +gShowbConstructor gs p c@(M1 x) = case fixity of + Prefix -> showbParen ( p > appPrec + && not ( isNullary x || conIsTuple c #if __GLASGOW_HASKELL__ >= 711 || conIsRecord c @@ -413,14 +473,12 @@ (if conIsTuple c then mempty else let cn = conName c - in showbParen (isInfixTypeCon cn) $ fromString cn - ) - <> (if isNull x || conIsTuple c + in showbParen (isInfixTypeCon cn) $ fromString cn) + <> (if isNullary x || conIsTuple c then mempty - else singleton ' ' - ) + else singleton ' ') <> showbBraces t (gs t appPrec1 x) - Infix _ m -> showbParen (n > m) . showbBraces t $ gs t (m+1) x + Infix _ m -> showbParen (p > m) $ gs t (m+1) x where fixity :: Fixity fixity = conFixity c @@ -446,8 +504,8 @@ gShowbSelector :: Selector s => (ConType -> Int -> f p -> Builder) -> ConType -> Int -> S1 s f p -> Builder -gShowbSelector gs t n sel@(M1 x) - | selName sel == "" = gs t n x +gShowbSelector gs t p sel@(M1 x) + | selName sel == "" = gs t p x | otherwise = fromString (selName sel) <> " = " <> gs t 0 x gShowbProduct :: (ConType -> Int -> f p -> Builder) @@ -457,12 +515,12 @@ gsa t 0 a <> ", " <> gsb t 0 b -gShowbProduct gsa gsb t@(Inf o) n (a :*: b) = - gsa t n a +gShowbProduct gsa gsb t@(Inf o) p (a :*: b) = + gsa t p a <> showbSpace <> infixOp <> showbSpace - <> gsb t n b + <> gsb t p b where infixOp :: Builder infixOp = if isInfixTypeCon o @@ -472,10 +530,10 @@ gsa t 0 a <> singleton ',' <> gsb t 0 b -gShowbProduct gsa gsb t@Pref n (a :*: b) = - gsa t n a +gShowbProduct gsa gsb t@Pref p (a :*: b) = + gsa t p a <> showbSpace - <> gsb t n b + <> gsb t p b gShowbUCharPrec :: Int -> UChar p -> Builder gShowbUCharPrec p (UChar c) = showbPrec (hashPrec p) (C# c) <> oneHash @@ -508,4 +566,8 @@ #if __GLASGOW_HASKELL__ < 702 $(Generics.deriveAll ''ConType) +#endif + +#if __GLASGOW_HASKELL__ < 800 +$(deriveLift ''ConType) #endif diff --git a/src/TextShow/Instances.hs b/src/TextShow/Instances.hs --- a/src/TextShow/Instances.hs +++ b/src/TextShow/Instances.hs @@ -27,15 +27,20 @@ import TextShow.Data.Either () import TextShow.Data.Fixed () import TextShow.Data.Floating () +import TextShow.Data.Functor.Compose () import TextShow.Data.Functor.Identity () +import TextShow.Data.Functor.Product () +import TextShow.Data.Functor.Sum () import TextShow.Data.Integral () import TextShow.Data.List () +import TextShow.Data.List.NonEmpty () import TextShow.Data.Maybe () import TextShow.Data.Monoid () import TextShow.Data.OldTypeable () import TextShow.Data.Ord () import TextShow.Data.Proxy () import TextShow.Data.Ratio () +import TextShow.Data.Semigroup () import TextShow.Data.Text () import TextShow.Data.Tuple () import TextShow.Data.Type.Coercion () diff --git a/src/TextShow/Numeric/Natural.hs b/src/TextShow/Numeric/Natural.hs --- a/src/TextShow/Numeric/Natural.hs +++ b/src/TextShow/Numeric/Natural.hs @@ -29,7 +29,7 @@ import Numeric.Natural (Natural) #endif -import TextShow.Classes (TextShow(showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Integral (showbIntegerPrec) #include "inline.h" diff --git a/src/TextShow/System/IO.hs b/src/TextShow/System/IO.hs --- a/src/TextShow/System/IO.hs +++ b/src/TextShow/System/IO.hs @@ -42,7 +42,7 @@ import System.IO (BufferMode, IOMode, Newline, NewlineMode, SeekMode) -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Integral (showbIntegerPrec) import TextShow.Data.Maybe () import TextShow.TH.Internal (deriveTextShow) diff --git a/src/TextShow/System/Posix/Types.hs b/src/TextShow/System/Posix/Types.hs --- a/src/TextShow/System/Posix/Types.hs +++ b/src/TextShow/System/Posix/Types.hs @@ -67,7 +67,7 @@ import System.Posix.Types -import TextShow.Classes (TextShow(showb, showbPrec)) +import TextShow.Classes (TextShow(..)) import TextShow.Data.Integral () import TextShow.Foreign.C.Types () diff --git a/src/TextShow/TH/Internal.hs b/src/TextShow/TH/Internal.hs --- a/src/TextShow/TH/Internal.hs +++ b/src/TextShow/TH/Internal.hs @@ -42,1314 +42,1679 @@ , makePrintTL , makeHPrintT , makeHPrintTL - , makeShowbPrecWith - , makeShowbPrec1 - , makeShowbPrecWith2 - , makeShowbPrec2 - ) where - -import Data.Function (on) -import Data.List.Compat -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..), (<|)) -import qualified Data.Map as Map (fromList, findWithDefault) -import Data.Map (Map) -import Data.Monoid.Compat ((<>)) -import qualified Data.Set as Set -import Data.Set (Set) -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.IO as TL (putStrLn, hPutStrLn) - -import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..)) -import GHC.Prim (Char#, Double#, Float#, Int#, Word#) -import GHC.Show (appPrec, appPrec1) - -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr hiding (appPrec) -import Language.Haskell.TH.Syntax - -import Prelude () -import Prelude.Compat - -import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..), - showbListWith, showbParen, showbSpace) -import TextShow.Utils (isInfixTypeCon, isTupleString) - -------------------------------------------------------------------------------- --- User-facing API -------------------------------------------------------------------------------- - -{- $deriveTextShow - -'deriveTextShow' automatically generates a 'TextShow' instance declaration for a data -type, newtype, or data family instance. This emulates what would (hypothetically) -happen if you could attach a @deriving 'TextShow'@ clause to the end of a data -declaration. - -Here are some examples of how to derive 'TextShow' for simple data types: - -@ -{-# LANGUAGE TemplateHaskell #-} -import TextShow.TH - -data Letter = A | B | C -$('deriveTextShow' ''Letter) -- instance TextShow Letter where ... - -newtype Box a = Box a -$('deriveTextShow' ''Box) -- instance TextShow a => TextShow (Box a) where ... -@ - -If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), -'deriveTextShow' can also be used to derive 'TextShow' instances for data family -instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of -a data or newtype instance constructor (NOT a data family name!) to 'deriveTextShow'. -Note that the generated code may require the @-XFlexibleInstances@ extension. -Some examples: - -@ -{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} -import TextShow.TH (deriveTextShow) - -class AssocClass a where - data AssocData a -instance AssocClass Int where - data AssocData Int = AssocDataInt1 Int | AssocDataInt2 Int Int -$('deriveTextShow' 'AssocDataInt1) -- instance TextShow (AssocData Int) where ... --- Alternatively, one could use $(deriveTextShow 'AssocDataInt2) - -data family DataFam a b -newtype instance DataFam () b = DataFamB b -$('deriveTextShow' 'DataFamB) -- instance TextShow b => TextShow (DataFam () b) -@ - -Note that at the moment, there are some limitations: - -* The 'Name' argument to 'deriveTextShow' must not be a type synonym. - -* 'deriveTextShow' makes the assumption that all type variables of kind @*@ require a - 'TextShow' constraint when creating the type context. For example, if you have @data - Phantom a = Phantom@, then @('deriveTextShow' ''Phantom)@ will generate @instance - 'TextShow' a => 'TextShow' (Phantom a) where ...@, even though @'TextShow' a@ is - not required. If you want a proper 'TextShow' instance for @Phantom@, you will need - to use 'makeShowbPrec' (see the documentation of the @make@ functions for more - information). - -* 'deriveTextShow' lacks the ability to properly detect data types with higher-kinded - type parameters (e.g., @data HK f a = HK (f a)@) or with kinds other than @*@ - (e.g., @data List a (empty :: Bool)@). If you wish to derive 'TextShow' - instances for these data types, you will need to use 'makeShowbPrec'. - -* Some data constructors have arguments whose 'TextShow' instance depends on a - typeclass besides 'TextShow'. For example, consider @newtype MyFixed a = MyFixed - (Fixed a)@. @'Fixed' a@ is a 'TextShow' instance only if @a@ is an instance of both - @HasResolution@ and 'TextShow'. Unfortunately, 'deriveTextShow' cannot infer that - 'a' must be an instance of 'HasResolution', so it cannot create a 'TextShow' - instance for @MyFixed@. However, you can use 'makeShowbPrec' to get around this. - --} - --- | Generates a 'TextShow' instance declaration for the given data type or data --- family instance. --- --- /Since: 2/ -deriveTextShow :: Name -> Q [Dec] -deriveTextShow = deriveTextShowClass TextShow - -{- $deriveTextShow1 - -'deriveTextShow1' automatically generates a 'Show1' instance declaration for a data -type, newtype, or data family instance that has at least one type variable. -This emulates what would (hypothetically) happen if you could attach a @deriving -'TextShow1'@ clause to the end of a data declaration. Examples: - -@ -{-# LANGUAGE TemplateHaskell #-} -import TextShow.TH - -data Stream a = Stream a (Stream a) -$('deriveTextShow1' ''Stream) -- instance TextShow1 TextStream where ... - -newtype WrappedFunctor f a = WrapFunctor (f a) -$('deriveTextShow1' ''WrappedFunctor) -- instance TextShow1 f => TextShow1 (WrappedFunctor f) where ... -@ - -The same restrictions that apply to 'deriveTextShow' also apply to 'deriveTextShow1', -with some caveats: - -* With 'deriveTextShow1', the last type variable must be of kind @*@. For other ones, - type variables of kind @*@ are assumed to require a 'TextShow' context, and type - variables of kind @* -> *@ are assumed to require a 'TextShow1' context. For more - complicated scenarios, use 'makeShowbPrecWith'. - -* If using @-XDatatypeContexts@, a datatype constraint cannot mention the last type - variable. For example, @data Ord a => Illegal a = Illegal a@ cannot have a derived - 'TextShow1' instance. - -* If the last type variable is used within a data field of a constructor, it must only - be used in the last argument of the data type constructor. For example, @data Legal a - = Legal (Either Int a)@ can have a derived 'TextShow1' instance, but @data Illegal a - = Illegal (Either a a)@ cannot. - -* Data family instances must be able to eta-reduce the last type variable. In other - words, if you have a instance of the form: - - @ - data family Family a1 ... an t - data instance Family e1 ... e2 v = ... - @ - - Then the following conditions must hold: - - 1. @v@ must be a type variable. - 2. @v@ must not be mentioned in any of @e1@, ..., @e2@. - -* In GHC 7.8, a bug exists that can cause problems when a data family declaration and - one of its data instances use different type variables, e.g., - - @ - data family Foo a b c - data instance Foo Int y z = Foo Int y z - $('deriveTextShow1' 'Foo) - @ - - To avoid this issue, it is recommened that you use the same type variables in the - same positions in which they appeared in the data family declaration: - - @ - data family Foo a b c - data instance Foo Int b c = Foo Int b c - $('deriveTextShow1' 'Foo) - @ - --} - --- | Generates a 'TextShow1' instance declaration for the given data type or data --- family instance. --- --- /Since: 2/ -deriveTextShow1 :: Name -> Q [Dec] -deriveTextShow1 = deriveTextShowClass TextShow1 - -{- $deriveTextShow2 - -'deriveTextShow2' automatically generates a 'TextShow2' instance declaration for a data -type, newtype, or data family instance that has at least two type variables. -This emulates what would (hypothetically) happen if you could attach a @deriving -'TextShow2'@ clause to the end of a data declaration. Examples: - -@ -{-# LANGUAGE TemplateHaskell #-} -import TextShow.TH - -data OneOrNone a b = OneL a | OneR b | None -$('deriveTextShow2' ''OneOrNone) -- instance TextShow2 OneOrNone where ... - -newtype WrappedBifunctor f a b = WrapBifunctor (f a b) -$('deriveTextShow2' ''WrappedBifunctor) -- instance TextShow2 f => TextShow2 (WrappedBifunctor f) where ... -@ - -The same restrictions that apply to 'deriveTextShow' and 'deriveTextShow1' also apply -to 'deriveTextShow2', with some caveats: - -* With 'deriveTextShow2', the last type variables must both be of kind @*@. For other - ones, type variables of kind @*@ are assumed to require a 'TextShow' constraint, type - variables of kind @* -> *@ are assumed to require a 'TextShow1' constraint, and type - variables of kind @* -> * -> *@ are assumed to require a 'TextShow2' constraint. For - more complicated scenarios, use 'makeShowbPrecWith2'. - -* If using @-XDatatypeContexts@, a datatype constraint cannot mention either of the last - two type variables. For example, @data Ord a => Illegal a b = Illegal a b@ cannot - have a derived 'TextShow2' instance. - -* If either of the last two type variables is used within a data field of a constructor, - it must only be used in the last two arguments of the data type constructor. For - example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'TextShow2' - instance, but @data Illegal a b = Illegal (a, b, a, b)@ cannot. - -* Data family instances must be able to eta-reduce the last two type variables. In other - words, if you have a instance of the form: - - @ - data family Family a1 ... an t1 t2 - data instance Family e1 ... e2 v1 v2 = ... - @ - - Then the following conditions must hold: - - 1. @v1@ and @v2@ must be distinct type variables. - 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. - --} - --- | Generates a 'TextShow2' instance declaration for the given data type or data --- family instance. --- --- /Since: 2/ -deriveTextShow2 :: Name -> Q [Dec] -deriveTextShow2 = deriveTextShowClass TextShow2 - -{- $make - -There may be scenarios in which you want to show an arbitrary data type or data -family instance without having to make the type an instance of 'TextShow'. For these -cases, this modules provides several functions (all prefixed with @make@-) that -splice the appropriate lambda expression into your source code. Example: - -This is particularly useful for creating instances for sophisticated data types. For -example, 'deriveTextShow' cannot infer the correct type context for -@newtype HigherKinded f a = HigherKinded (f a)@, since @f@ is of kind @* -> *@. -However, it is still possible to derive a 'TextShow' instance for @HigherKinded@ -without too much trouble using 'makeShowbPrec': - -@ -{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} -import TextShow -import TextShow.TH - -instance TextShow (f a) => TextShow (HigherKinded f a) where - showbPrec = $(makeShowbPrec ''HigherKinded) -@ - --} - --- | Generates a lambda expression which behaves like 'showt' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makeShowt :: Name -> Q Exp -makeShowt name = [| toStrict . $(makeShowtl name) |] - --- | Generates a lambda expression which behaves like 'showtl' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makeShowtl :: Name -> Q Exp -makeShowtl name = [| toLazyText . $(makeShowb name) |] - --- | 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 |] - --- | 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 |] - --- | Generates a lambda expression which behaves like 'showtList' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makeShowtList :: Name -> Q Exp -makeShowtList name = [| toStrict . $(makeShowtlList name) |] - --- | Generates a lambda expression which behaves like 'showtlList' (without --- requiring a 'TextShow' instance). --- --- /Since: 2/ -makeShowtlList :: Name -> Q Exp -makeShowtlList name = [| toLazyText . $(makeShowbList name) |] - --- | Generates a lambda expression which behaves like 'showb' (without requiring a --- 'TextShow' instance). --- --- /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 - --- | Generates a lambda expression which behaves like 'showbPrec' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makeShowbPrec :: Name -> Q Exp -makeShowbPrec = makeShowbPrecClass TextShow - --- | Generates a lambda expression which behaves like 'showbPrecWith' (without --- requiring a 'TextShow1' instance). --- --- /Since: 2/ -makeShowbPrecWith :: Name -> Q Exp -makeShowbPrecWith = makeShowbPrecClass TextShow1 - --- | Generates a lambda expression which behaves like 'showbPrec1' (without --- requiring a 'TextShow1' instance). --- --- /Since: 2/ -makeShowbPrec1 :: Name -> Q Exp -makeShowbPrec1 name = [| $(makeShowbPrecWith name) showbPrec |] - --- | Generates a lambda expression which behaves like 'showbPrecWith2' (without --- requiring a 'TextShow2' instance). --- --- /Since: 2/ -makeShowbPrecWith2 :: Name -> Q Exp -makeShowbPrecWith2 = makeShowbPrecClass TextShow2 - --- | Generates a lambda expression which behaves like 'showbPrecWith2' (without --- requiring a 'TextShow2' instance). --- --- /Since: 2/ -makeShowbPrec2 :: Name -> Q Exp -makeShowbPrec2 name = [| $(makeShowbPrecWith2 name) showbPrec showbPrec |] - --- | Generates a lambda expression which behaves like 'showbList' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makeShowbList :: Name -> Q Exp -makeShowbList name = [| showbListWith $(makeShowb name) |] - --- | Generates a lambda expression which behaves like 'printT' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makePrintT :: Name -> Q Exp -makePrintT name = [| TS.putStrLn . $(makeShowt name) |] - --- | Generates a lambda expression which behaves like 'printTL' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makePrintTL :: Name -> Q Exp -makePrintTL name = [| TL.putStrLn . $(makeShowtl name) |] - --- | Generates a lambda expression which behaves like 'hPrintT' (without requiring a --- 'TextShow' instance). --- --- /Since: 2/ -makeHPrintT :: Name -> Q Exp -makeHPrintT name = [| \h -> TS.hPutStrLn h . $(makeShowt name) |] - --- | Generates a lambda expression which behaves like 'hPrintTL' (without --- requiring a 'TextShow' instance). --- --- /Since: 2/ -makeHPrintTL :: Name -> Q Exp -makeHPrintTL name = [| \h -> TL.hPutStrLn h . $(makeShowtl name) |] - -------------------------------------------------------------------------------- --- Code generation -------------------------------------------------------------------------------- - --- | 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 - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) <$> - instanceD (return instanceCxt) - (return instanceType) - (showbPrecDecs droppedNbs cons) - where - (instanceCxt, instanceType, droppedNbs) = - buildTypeInstance tsClass name' ctxt tvbs mbTys - --- | Generates a declaration defining the primary function corresponding to a --- particular class (showbPrec for TextShow, showbPrecWith for TextShow1, and --- showbPrecWith2 for TextShow2). -showbPrecDecs :: [NameBase] -> [Con] -> [Q Dec] -showbPrecDecs nbs cons = - [ funD classFuncName - [ clause [] - (normalB $ makeTextShowForCons nbs cons) - [] - ] - ] - where - classFuncName :: Name - classFuncName = showbPrecName . toEnum $ length nbs - --- | Generates a lambda expression which behaves like showbPrec (for TextShow), --- showbPrecWith (for TextShow1), or showbPrecWth2 (for TextShow2). -makeShowbPrecClass :: TextShowClass -> Name -> Q Exp -makeShowbPrecClass tsClass name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - let (_, _, !nbs) = buildTypeInstance tsClass name' ctxt tvbs mbTys - in makeTextShowForCons nbs cons - --- | Generates a lambda expression for showbPrec(With)(2) for the given constructors. --- All constructors must be from the same type. -makeTextShowForCons :: [NameBase] -> [Con] -> Q Exp -makeTextShowForCons _ [] = error "Must have at least one data constructor" -makeTextShowForCons nbs cons = do - p <- newName "p" - value <- newName "value" - sps <- newNameList "sp" $ length nbs - let tvis = zip nbs sps - tsClass = toEnum $ length nbs - lamE (map varP $ sps ++ [p, value]) - . appsE - $ [ varE $ showbPrecConstName tsClass - , caseE (varE value) $ map (makeTextShowForCon p tsClass tvis) cons - ] ++ map varE sps - ++ [varE p, varE value] - --- | Generates a lambda expression for showbPrec(With)(2) for a single constructor. -makeTextShowForCon :: Name -> TextShowClass -> [TyVarInfo] -> Con -> Q Match -makeTextShowForCon _ _ _ (NormalC conName []) - = match (conP conName []) - (normalB [| fromString $(stringE (parenInfixConName conName "")) |]) - [] -makeTextShowForCon p tsClass tvis (NormalC conName [(_, argTy)]) = do - arg <- newName "arg" - - let showArg = makeTextShowForArg appPrec1 tsClass conName tvis argTy arg - namedArg = [| fromString $(stringE (parenInfixConName conName " ")) <> $(showArg) |] - - match (conP conName [varP arg]) - (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArg) |]) - [] -makeTextShowForCon p tsClass tvis (NormalC conName ts) = do - args <- newNameList "arg" $ length ts - - if isNonUnitTuple conName - then do - let showArgs = map (\(arg, (_, argTy)) -> makeTextShowForArg 0 tsClass conName tvis argTy arg) - (zip args ts) - parenCommaArgs = [| singleton '(' |] : intersperse [| singleton ',' |] showArgs - mappendArgs = foldr (`infixApp` [| (<>) |]) - [| singleton ')' |] - parenCommaArgs - - match (conP conName $ map varP args) - (normalB mappendArgs) - [] - else do - let showArgs = map (\(arg, (_, argTy)) -> makeTextShowForArg appPrec1 tsClass conName tvis argTy arg) - (zip args ts) - mappendArgs = foldr1 (\v q -> [| $(v) <> showbSpace <> $(q) |]) showArgs - namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |] - - match (conP conName $ map varP args) - (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArgs) |]) - [] -makeTextShowForCon p tsClass tvis (RecC conName []) = makeTextShowForCon p tsClass tvis $ NormalC conName [] -makeTextShowForCon _p tsClass tvis (RecC conName ts) = do - args <- newNameList "arg" $ length ts - - let showArgs = concatMap (\(arg, (argName, _, argTy)) - -> [ [| fromString $(stringE (nameBase argName ++ " = ")) |] - , makeTextShowForArg 0 tsClass conName tvis argTy arg - , [| fromString ", " |] - ] - ) - (zip args ts) - braceCommaArgs = [| singleton '{' |] : take (length showArgs - 1) showArgs - mappendArgs = foldr (`infixApp` [| (<>) |]) - [| singleton '}' |] - braceCommaArgs - namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |] - - match (conP conName $ map varP args) - (normalB -#if __GLASGOW_HASKELL__ >= 711 - namedArgs -#else - [| showbParen ($(varE _p) > $(lift appPrec)) $(namedArgs) |] -#endif - ) - [] -makeTextShowForCon p tsClass tvis (InfixC (_, alTy) conName (_, arTy)) = do - al <- newName "argL" - ar <- newName "argR" - info <- reify conName - -#if __GLASGOW_HASKELL__ >= 711 - conPrec <- case info of - DataConI{} -> do - Fixity prec _ <- reifyFixity conName - return prec -#else - let conPrec = case info of - DataConI _ _ _ (Fixity prec _) -> prec -#endif - _ -> error $ "TextShow.TH.makeTextShowForCon: Unsupported type: " ++ show info - - let opName = nameBase conName - infixOpE = if isInfixTypeCon opName - then [| fromString $(stringE $ " " ++ opName ++ " " ) |] - else [| fromString $(stringE $ " `" ++ opName ++ "` ") |] - - match (infixP (varP al) conName (varP ar)) - (normalB $ appE [| showbParen ($(varE p) > conPrec) |] - [| $(makeTextShowForArg (conPrec + 1) tsClass conName tvis alTy al) - <> $(infixOpE) - <> $(makeTextShowForArg (conPrec + 1) tsClass conName tvis arTy ar) - |] - ) - [] -makeTextShowForCon p tsClass tvis (ForallC tvbs _ con) = makeTextShowForCon p tsClass (removeForalled tvbs tvis) con - --- | Generates a lambda expression for showbPrec(With)(2) for an argument of a --- constructor. -makeTextShowForArg :: Int - -> TextShowClass - -> Name - -> [TyVarInfo] - -> Type - -> Name - -> Q Exp -makeTextShowForArg p tsClass conName tvis ty tyExpName = do - ty' <- expandSyn ty - makeTextShowForArg' p tsClass conName tvis ty' tyExpName - --- | Generates a lambda expression for showbPrec(With)(2) for an argument of a --- constructor, after expanding all type synonyms. -makeTextShowForArg' :: Int - -> TextShowClass - -> Name - -> [TyVarInfo] - -> 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. - showE - where - tyVarE :: Q Exp - tyVarE = varE tyExpName - - 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 - - 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 -#endif -makeTextShowForArg' p tsClass conName tvis ty tyExpName = - [| $(makeTextShowForType tsClass conName tvis ty) p $(varE tyExpName) |] - --- | Generates a lambda expression for showbPrec(With)(2) for a specific type. --- The generated expression depends on the number of type variables. --- --- 1. If the type is of kind * (T), apply showbPrec. --- 2. If the type is of kind * -> * (T a), apply showbPrecWith $(makeTextShowForType a) --- 3. If the type is of kind * -> * -> * (T a b), apply --- showbPrecWith2 $(makeTextShowForType a) $(makeTextShowForType b) -makeTextShowForType :: TextShowClass - -> Name - -> [TyVarInfo] - -> Type - -> Q Exp -makeTextShowForType _ _ tvis (VarT tyName) = - case lookup (NameBase tyName) tvis of - Just spExp -> varE spExp - Nothing -> [| showbPrec |] -makeTextShowForType tsClass conName tvis (SigT ty _) = makeTextShowForType tsClass conName tvis ty -makeTextShowForType tsClass conName tvis (ForallT tvbs _ ty) = makeTextShowForType tsClass conName (removeForalled tvbs tvis) ty -makeTextShowForType tsClass conName tvis ty = do - let tyArgs :: [Type] - tyCon :| tyArgs = unapplyTy ty - - numLastArgs :: Int - numLastArgs = min (fromEnum tsClass) (length tyArgs) - - lhsArgs, rhsArgs :: [Type] - (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - - tyVarNameBases :: [NameBase] - tyVarNameBases = map fst tvis - - itf <- isTyFamily tyCon - if any (`mentionsNameBase` tyVarNameBases) lhsArgs - || itf && any (`mentionsNameBase` tyVarNameBases) tyArgs - then outOfPlaceTyVarError conName tyVarNameBases - else appsE $ [ varE . showbPrecName $ toEnum numLastArgs] - ++ map (makeTextShowForType tsClass conName tvis) rhsArgs - -------------------------------------------------------------------------------- --- Template Haskell reifying and AST manipulation -------------------------------------------------------------------------------- - --- | Extracts a plain type constructor's information. --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing - _ -> error $ ns ++ "Unsupported type: " ++ show dec -#if MIN_VERSION_template_haskell(2,7,0) -# if MIN_VERSION_template_haskell(2,11,0) - DataConI _ _ parentName -> do -# else - DataConI _ _ parentName _ -> do -# endif - parentInfo <- reify parentName - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> error $ ns ++ - "Could not find data or newtype instance constructor." - _ -> error $ ns ++ "Data constructor " ++ show name ++ - " is not from a data family instance constructor." -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI DataFamilyD{} _ -> -# else - FamilyI (FamilyD DataFam _ _ _) _ -> -# endif - error $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> error $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "TextShow.TH.withType: " - --- | Deduces the instance context, instance head, and eta-reduced type variables --- for an instance. -buildTypeInstance :: TextShowClass - -- ^ TextShow, TextShow1, or TextShow2 - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type - -> (Cxt, Type, [NameBase]) --- Plain data type/newtype case -buildTypeInstance tsClass tyConName dataCxt tvbs Nothing - | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables - = derivingKindError tsClass tyConName - | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context - = datatypeContextError tyConName instanceType - | otherwise = (instanceCxt, instanceType, droppedNbs) - where - instanceCxt :: Cxt - instanceCxt = map (applyShowConstraint) - $ filter (needsConstraint tsClass . tvbKind) remaining - - instanceType :: Type - instanceType = AppT (ConT $ textShowClassName tsClass) - . applyTyCon tyConName - $ map (VarT . tvbName) remaining - - remainingLength :: Int - remainingLength = length tvbs - fromEnum tsClass - - remaining, dropped :: [TyVarBndr] - (remaining, dropped) = splitAt remainingLength tvbs - - droppedKinds :: [Kind] - droppedKinds = map tvbKind dropped - - droppedNbs :: [NameBase] - droppedNbs = map (NameBase . tvbName) dropped --- Data family instance case -buildTypeInstance tsClass parentName dataCxt tvbs (Just instTysAndKinds) - | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables - = derivingKindError tsClass parentName - | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context - = datatypeContextError parentName instanceType - | canEtaReduce remaining dropped -- If it is safe to drop the type variables - = (instanceCxt, instanceType, droppedNbs) - | otherwise = etaReductionError instanceType - where - instanceCxt :: Cxt - instanceCxt = map (applyShowConstraint) - $ filter (needsConstraint tsClass . tvbKind) lhsTvbs - - -- We need to make sure that type variables in the instance head which have - -- TextShow constrains aren't poly-kinded, e.g., - -- - -- @ - -- instance TextShow a => TextShow (Foo (a :: k)) where - -- @ - -- - -- To do this, we remove every kind ascription (i.e., strip off every 'SigT'). - instanceType :: Type - instanceType = AppT (ConT $ textShowClassName tsClass) - . applyTyCon parentName - $ map unSigT remaining - - remainingLength :: Int - remainingLength = length tvbs - fromEnum tsClass - - remaining, dropped :: [Type] - (remaining, dropped) = splitAt remainingLength rhsTypes - - droppedKinds :: [Kind] - droppedKinds = map tvbKind . snd $ splitAt remainingLength tvbs - - droppedNbs :: [NameBase] - droppedNbs = map varTToNameBase dropped - - -- We need to mindful of an old GHC bug which causes kind variables appear in - -- @instTysAndKinds@ (as the name suggests) if (1) @PolyKinds@ is enabled, and - -- (2) either GHC 7.6 or 7.8 is being used (for more info, see - -- https://ghc.haskell.org/trac/ghc/ticket/9692). - -- - -- Since Template Haskell doesn't seem to have a mechanism for detecting which - -- language extensions are enabled, we do the next-best thing by counting - -- the number of distinct kind variables in the data family declaration, and - -- then dropping that number of entries from @instTysAndKinds@ - instTypes :: [Type] - instTypes = -#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0)) - instTysAndKinds -#else - drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs) - instTysAndKinds -#endif - - lhsTvbs :: [TyVarBndr] - lhsTvbs = map (uncurry replaceTyVarName) - . filter (isTyVar . snd) - . take remainingLength - $ zip tvbs rhsTypes - - -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable - -- in @instTypes@ are provided (as a result of this extremely annoying bug: - -- https://ghc.haskell.org/trac/ghc/ticket/9692). This is pretty inconvenient, - -- as it makes it impossible to come up with the correct 'TextShow1' or 'TextShow2' - -- instances in some cases. For example, consider the following code: - -- - -- @ - -- data family Foo a b c - -- data instance Foo Int y z = Foo Int y z - -- $(deriveTextShow2 'Foo) - -- @ - -- - -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of - -- either of type variables in the data instance (@y@ and @z@). As a result, we - -- won't know which fields of the 'Foo' constructor to apply the show functions, - -- which will result in an incorrect instance. Urgh. - -- - -- A workaround is to ensure that you use the exact same type variables, in the - -- exact same order, in the data family declaration and any data or newtype - -- instances: - -- - -- @ - -- data family Foo a b c - -- data instance Foo Int b c = Foo Int b c - -- $(deriveTextShow2 'Foo) - -- @ - -- - -- Thankfully, other versions of GHC don't seem to have this bug. - rhsTypes :: [Type] - rhsTypes = -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - instTypes ++ map tvbToType - (drop (length instTypes) - tvbs) -#else - instTypes -#endif - --- | Given a TyVarBndr, apply a TextShow(1)(2) constraint to it, depending --- on its kind. -applyShowConstraint :: TyVarBndr -> Pred -applyShowConstraint (PlainTV name) = applyClass ''TextShow name -applyShowConstraint (KindedTV name kind) = applyClass className name - where - className :: Name - className = textShowClassName . toEnum $ numKindArrows kind - --- | Can a kind signature inhabit a TextShow(1)(2) constraint? --- --- TextShow: k --- TextShow1: k1 -> k2 --- TextShow2: k1 -> k2 -> k3 -needsConstraint :: TextShowClass -> Kind -> Bool -needsConstraint tsClass kind = - fromEnum tsClass >= numKindArrows kind - && canRealizeKindStarChain kind - -------------------------------------------------------------------------------- --- Error messages -------------------------------------------------------------------------------- - --- | Either the given data type doesn't have enough type variables, or one of --- the type variables to be eta-reduced cannot realize kind *. -derivingKindError :: TextShowClass -> Name -> a -derivingKindError tsClass tyConName = error - . showString "Cannot derive well-kinded instance of form ‘" - . showString className - . showChar ' ' - . showParen True - ( showString (nameBase tyConName) - . showString " ..." - ) - . showString "‘\n\tClass " - . showString className - . showString " expects an argument of kind " - . showString (pprint . createKindChain $ fromEnum tsClass) - $ "" - where - className :: String - className = nameBase $ textShowClassName tsClass - --- | One of the last type variables cannot be eta-reduced (see the canEtaReduce --- function for the criteria it would have to meet). -etaReductionError :: Type -> a -etaReductionError instanceType = error $ - "Cannot eta-reduce to an instance of form \n\tinstance (...) => " - ++ pprint instanceType - --- | The data type has a DatatypeContext which mentions one of the eta-reduced --- type variables. -datatypeContextError :: Name -> Type -> a -datatypeContextError dataName instanceType = error - . showString "Can't make a derived instance of ‘" - . showString (pprint instanceType) - . showString "‘:\n\tData type ‘" - . showString (nameBase dataName) - . showString "‘ must not have a class context involving the last type argument(s)" - $ "" - --- | The data type mentions one of the n eta-reduced type variables in a place other --- than the last nth positions of a data type in a constructor's field. -outOfPlaceTyVarError :: Name -> [NameBase] -> a -outOfPlaceTyVarError conName tyVarNames = error - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must use the type variable(s) " - . shows tyVarNames - . showString " only in the last argument(s) of a data type" - $ "" - -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived TextShow(1)(2) --- instance to work. -dataConIError :: a -dataConIError = error - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive TextShow for a" - . showString "\n\ttype family, use GHC >= 7.4 instead.)" - $ "" -#endif - -------------------------------------------------------------------------------- --- Expanding type synonyms -------------------------------------------------------------------------------- - --- | Expands all type synonyms in a type. Written by Dan Rosén in the --- @genifunctors@ package (licensed under BSD3). -expandSyn :: Type -> Q Type -expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t -expandSyn t@AppT{} = expandSynApp t [] -expandSyn t@ConT{} = expandSynApp t [] -expandSyn (SigT t _) = expandSyn t -- Ignore kind synonyms -expandSyn t = return t - -expandSynApp :: Type -> [Type] -> Q Type -expandSynApp (AppT t1 t2) ts = do - t2' <- expandSyn t2 - expandSynApp t1 (t2':ts) -expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts -expandSynApp t@(ConT n) ts = do - info <- reify n - case info of - TyConI (TySynD _ tvs rhs) -> - let (ts', ts'') = splitAt (length tvs) ts - subs = mkSubst tvs ts' - rhs' = subst subs rhs - in expandSynApp rhs' ts'' - _ -> return $ foldl' AppT t ts -expandSynApp t ts = do - t' <- expandSyn t - return $ foldl' AppT t' ts - -type Subst = Map Name Type - -mkSubst :: [TyVarBndr] -> [Type] -> Subst -mkSubst vs ts = - let vs' = map un vs - un (PlainTV v) = v - un (KindedTV v _) = v - in Map.fromList $ zip vs' ts - -subst :: Subst -> Type -> Type -subst subs (ForallT v c t) = ForallT v c $ subst subs t -subst subs t@(VarT n) = Map.findWithDefault t n subs -subst subs (AppT t1 t2) = AppT (subst subs t1) (subst subs t2) -subst subs (SigT t k) = SigT (subst subs t) k -subst _ t = t - -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- - --- | A representation of which TextShow variant is being derived. -data TextShowClass = TextShow | TextShow1 | TextShow2 - deriving (Enum, Eq, Ord) - -showbPrecConstName :: TextShowClass -> Name -showbPrecConstName TextShow = 'showbPrecConst -showbPrecConstName TextShow1 = 'showbPrecWithConst -showbPrecConstName TextShow2 = 'showbPrecWith2Const - -textShowClassName :: TextShowClass -> Name -textShowClassName TextShow = ''TextShow -textShowClassName TextShow1 = ''TextShow1 -textShowClassName TextShow2 = ''TextShow2 - -showbPrecName :: TextShowClass -> Name -showbPrecName TextShow = 'showbPrec -showbPrecName TextShow1 = 'showbPrecWith -showbPrecName TextShow2 = 'showbPrecWith2 - --- | 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 --- the expression wouldn't depend on the precedence). For example, if you had @data --- Nullary = Nullary@ and attempted to run @$(makeShowbPrec ''Nullary) Nullary@, simply --- ignoring the precedence argument would cause the type signature of @$(makeShowbPrec --- ''Nullary)@ to be @a -> Nullary -> Builder@, not @Int -> Nullary -> Builder@. -showbPrecConst :: Builder -> Int -> a -> Builder -showbPrecConst = const . const -{-# INLINE showbPrecConst #-} - -showbPrecWithConst :: Builder -> (Int -> a -> Builder) -> Int -> f a -> Builder -showbPrecWithConst = const . const . const -{-# INLINE showbPrecWithConst #-} - -showbPrecWith2Const :: Builder -> (Int -> a -> Builder) -> (Int -> b -> Builder) - -> Int -> f a b -> Builder -showbPrecWith2Const = const . const . const . const -{-# INLINE showbPrecWith2Const #-} - -------------------------------------------------------------------------------- --- NameBase -------------------------------------------------------------------------------- - --- | A wrapper around Name which only uses the 'nameBase' (not the entire Name) --- to compare for equality. For example, if you had two Names a_123 and a_456, --- they are not equal as Names, but they are equal as NameBases. --- --- This is useful when inspecting type variables, since a type variable in an --- instance context may have a distinct Name from a type variable within an --- actual constructor declaration, but we'd want to treat them as the same --- if they have the same 'nameBase' (since that's what the programmer uses to --- begin with). -newtype NameBase = NameBase { getName :: Name } - -getNameBase :: NameBase -> String -getNameBase = nameBase . getName - -instance Eq NameBase where - (==) = (==) `on` getNameBase - -instance Ord NameBase where - compare = compare `on` getNameBase - -instance Show NameBase where - showsPrec p = showsPrec p . getNameBase - --- | A NameBase paired with the name of its show function. For example, in a --- TextShow2 declaration, a list of TyVarInfos might look like [(a, 'sp1), (b, 'sp2)]. -type TyVarInfo = (NameBase, Name) - -------------------------------------------------------------------------------- --- Assorted utilities -------------------------------------------------------------------------------- - --- | Generate a list of fresh names with a common prefix, and numbered suffixes. -newNameList :: String -> Int -> Q [Name] -newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] - --- | Remove any occurrences of a forall-ed type variable from a list of @TyVarInfo@s. -removeForalled :: [TyVarBndr] -> [TyVarInfo] -> [TyVarInfo] -removeForalled tvbs = filter (not . foralled tvbs) - where - foralled :: [TyVarBndr] -> TyVarInfo -> Bool - foralled tvbs' tvi = fst tvi `elem` map (NameBase . tvbName) tvbs' - --- | Checks if a 'Name' represents a tuple type constructor (other than '()') -isNonUnitTuple :: Name -> Bool -isNonUnitTuple = isTupleString . nameBase - --- | Parenthesize an infix constructor name if it is being applied as a prefix --- function (e.g., data Amp a = (:&) a a) -parenInfixConName :: Name -> ShowS -parenInfixConName conName = - let conNameBase = nameBase conName - in showParen (isInfixTypeCon conNameBase) $ showString conNameBase - --- | Extracts the name from a TyVarBndr. -tvbName :: TyVarBndr -> Name -tvbName (PlainTV name) = name -tvbName (KindedTV name _) = name - --- | Extracts the kind from a TyVarBndr. -tvbKind :: TyVarBndr -> Kind -tvbKind (PlainTV _) = starK -tvbKind (KindedTV _ k) = k - --- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name). -replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr -replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t -replaceTyVarName (PlainTV _) (VarT n) = PlainTV n -replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k -replaceTyVarName tvb _ = tvb - --- | Applies a typeclass constraint to a type. -applyClass :: Name -> Name -> Pred -#if MIN_VERSION_template_haskell(2,10,0) -applyClass con t = AppT (ConT con) (VarT t) -#else -applyClass con t = ClassP con [VarT t] -#endif - --- | Checks to see if the last types in a data family instance can be safely eta- --- reduced (i.e., dropped), given the other types. This checks for three conditions: --- --- (1) All of the dropped types are type variables --- (2) All of the dropped types are distinct --- (3) None of the remaining types mention any of the dropped types -canEtaReduce :: [Type] -> [Type] -> Bool -canEtaReduce remaining dropped = - all isTyVar dropped - && allDistinct nbs -- Make sure not to pass something of type [Type], since Type - -- didn't have an Ord instance until template-haskell-2.10.0.0 - && not (any (`mentionsNameBase` nbs) remaining) - where - nbs :: [NameBase] - nbs = map varTToNameBase dropped - --- | Extract the Name from a type variable. -varTToName :: Type -> Name -varTToName (VarT n) = n -varTToName (SigT t _) = varTToName t -varTToName _ = error "Not a type variable!" - --- | Extract the NameBase from a type variable. -varTToNameBase :: Type -> NameBase -varTToNameBase = NameBase . varTToName - --- | Peel off a kind signature from a Type (if it has one). -unSigT :: Type -> Type -unSigT (SigT t _) = t -unSigT t = t - --- | Is the given type a variable? -isTyVar :: Type -> Bool -isTyVar (VarT _) = True -isTyVar (SigT t _) = isTyVar t -isTyVar _ = False - --- | Is the given type a type family constructor (and not a data family constructor)? -isTyFamily :: Type -> Q Bool -isTyFamily (ConT n) = do - info <- reify n - return $ case info of -#if MIN_VERSION_template_haskell(2,11,0) - FamilyI OpenTypeFamilyD{} _ -> True -#elif MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD TypeFam _ _ _) _ -> True -#else - TyConI (FamilyD TypeFam _ _ _) -> True -#endif -#if MIN_VERSION_template_haskell(2,9,0) - FamilyI ClosedTypeFamilyD{} _ -> True -#endif - _ -> False -isTyFamily _ = return False - --- | Are all of the items in a list (which have an ordering) distinct? --- --- This uses Set (as opposed to nub) for better asymptotic time complexity. -allDistinct :: Ord a => [a] -> Bool -allDistinct = allDistinct' Set.empty - where - allDistinct' :: Ord a => Set a -> [a] -> Bool - allDistinct' uniqs (x:xs) - | x `Set.member` uniqs = False - | otherwise = allDistinct' (Set.insert x uniqs) xs - allDistinct' _ _ = True - --- | Does the given type mention any of the NameBases in the list? -mentionsNameBase :: Type -> [NameBase] -> Bool -mentionsNameBase = go Set.empty - where - go :: Set NameBase -> Type -> [NameBase] -> Bool - go foralls (ForallT tvbs _ t) nbs = - go (foralls `Set.union` Set.fromList (map (NameBase . tvbName) tvbs)) t nbs - go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs - go foralls (SigT t _) nbs = go foralls t nbs - go foralls (VarT n) nbs = varNb `elem` nbs && not (varNb `Set.member` foralls) - where - varNb = NameBase n - go _ _ _ = False - --- | Does an instance predicate mention any of the NameBases in the list? -predMentionsNameBase :: Pred -> [NameBase] -> Bool -#if MIN_VERSION_template_haskell(2,10,0) -predMentionsNameBase = mentionsNameBase -#else -predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys -predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs -#endif - --- | The number of arrows that compose the spine of a kind signature --- (e.g., (* -> *) -> k -> * has two arrows on its spine). -numKindArrows :: Kind -> Int -numKindArrows k = length (uncurryKind k) - 1 - --- | Construct a type via curried application. -applyTy :: Type -> [Type] -> Type -applyTy = foldl' AppT - --- | Fully applies a type constructor to its type variables. -applyTyCon :: Name -> [Type] -> Type -applyTyCon = applyTy . ConT - --- | Split an applied type into its individual components. For example, this: --- --- @ --- Either Int Char --- @ --- --- would split to this: --- --- @ --- [Either, Int, Char] --- @ -unapplyTy :: Type -> NonEmpty Type -unapplyTy = NE.reverse . go - where - go :: Type -> NonEmpty Type - go (AppT t1 t2) = t2 <| go t1 - go (SigT t _) = go t - go t = t :| [] - --- | Split a type signature by the arrows on its spine. For example, this: --- --- @ --- (Int -> String) -> Char -> () --- @ --- --- would split to this: --- --- @ --- [Int -> String, Char, ()] --- @ -uncurryTy :: Type -> NonEmpty Type -uncurryTy (AppT (AppT ArrowT t1) t2) = t1 <| uncurryTy t2 -uncurryTy (SigT t _) = uncurryTy t -uncurryTy t = t :| [] - --- | Like uncurryType, except on a kind level. -uncurryKind :: Kind -> NonEmpty Kind -#if MIN_VERSION_template_haskell(2,8,0) -uncurryKind = uncurryTy -#else -uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2 -uncurryKind k = k :| [] -#endif - -wellKinded :: [Kind] -> Bool -wellKinded = all canRealizeKindStar - --- | Of form k1 -> k2 -> ... -> kn, where k is either a single kind variable or *. -canRealizeKindStarChain :: Kind -> Bool -canRealizeKindStarChain = all canRealizeKindStar . uncurryKind - -canRealizeKindStar :: Kind -> Bool -canRealizeKindStar k = case uncurryKind k of - k' :| [] -> case k' of -#if MIN_VERSION_template_haskell(2,8,0) - StarT -> True - (VarT _) -> True -- Kind k can be instantiated with * -#else - StarK -> True -#endif - _ -> False - _ -> False - -createKindChain :: Int -> Kind -createKindChain = go starK - where - go :: Kind -> Int -> Kind - go k !0 = k -#if MIN_VERSION_template_haskell(2,8,0) - go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) -#else - go k !n = go (ArrowK StarK k) (n - 1) -#endif - -# if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710 -distinctKindVars :: Kind -> Set Name -distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2 -distinctKindVars (SigT k _) = distinctKindVars k -distinctKindVars (VarT k) = Set.singleton k -distinctKindVars _ = Set.empty -#endif - -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -tvbToType :: TyVarBndr -> Type -tvbToType (PlainTV n) = VarT n -tvbToType (KindedTV n k) = SigT (VarT n) k -#endif - -#if MIN_VERSION_template_haskell(2,7,0) --- | Extracts the name of a constructor. -constructorName :: Con -> Name -constructorName (NormalC name _ ) = name -constructorName (RecC name _ ) = name -constructorName (InfixC _ name _ ) = name -constructorName (ForallC _ _ con) = constructorName con -#endif + , makeLiftShowbPrec + , makeShowbPrec1 + , makeLiftShowbPrec2 + , makeShowbPrec2 + ) where + +import Control.Monad (liftM, unless, when) +#if MIN_VERSION_template_haskell(2,11,0) +import Control.Monad ((<=<)) +#endif +import Data.Foldable.Compat +import Data.List.Compat +import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt) +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import qualified Data.Map as Map (fromList, findWithDefault, keys, lookup, singleton) +import Data.Map (Map) +import Data.Maybe +import Data.Monoid.Compat ((<>)) +import qualified Data.Set as Set +import Data.Set (Set) +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.IO as TL (putStrLn, hPutStrLn) + +import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..)) +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Lexeme (startsConSym) +#endif +import GHC.Prim (Char#, Double#, Float#, Int#, Word#) +import GHC.Show (appPrec, appPrec1) + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr hiding (appPrec) +import Language.Haskell.TH.Syntax + +import Prelude () +import Prelude.Compat + +import TextShow.Classes (TextShow(..), TextShow1(..), TextShow2(..), + showbListWith, showbParen, showbSpace) +import TextShow.Utils (isInfixTypeCon, isTupleString) + +------------------------------------------------------------------------------- +-- User-facing API +------------------------------------------------------------------------------- + +{- $deriveTextShow + +'deriveTextShow' automatically generates a 'TextShow' instance declaration for a data +type, newtype, or data family instance. This emulates what would (hypothetically) +happen if you could attach a @deriving 'TextShow'@ clause to the end of a data +declaration. + +Here are some examples of how to derive 'TextShow' for simple data types: + +@ +{-# LANGUAGE TemplateHaskell #-} +import TextShow.TH + +data Letter = A | B | C +$('deriveTextShow' ''Letter) -- instance TextShow Letter where ... + +newtype Box a = Box a +$('deriveTextShow' ''Box) -- instance TextShow a => TextShow (Box a) where ... +@ + +If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), +'deriveTextShow' can also be used to derive 'TextShow' instances for data family +instances (which requires the @-XTypeFamilies@ extension). To do so, pass the name of +a data or newtype instance constructor (NOT a data family name!) to 'deriveTextShow'. +Note that the generated code may require the @-XFlexibleInstances@ extension. +Some examples: + +@ +{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} +import TextShow.TH (deriveTextShow) + +class AssocClass a where + data AssocData a +instance AssocClass Int where + data AssocData Int = AssocDataInt1 Int | AssocDataInt2 Int Int +$('deriveTextShow' 'AssocDataInt1) -- instance TextShow (AssocData Int) where ... +-- Alternatively, one could use $(deriveTextShow 'AssocDataInt2) + +data family DataFam a b +newtype instance DataFam () b = DataFamB b +$('deriveTextShow' 'DataFamB) -- instance TextShow b => TextShow (DataFam () b) +@ + +Note that at the moment, there are some limitations: + +* The 'Name' argument to 'deriveTextShow' must not be a type synonym. + +* 'deriveTextShow' makes the assumption that all type variables of kind @*@ require a + 'TextShow' constraint when creating the type context. For example, if you have @data + Phantom a = Phantom@, then @('deriveTextShow' ''Phantom)@ will generate @instance + 'TextShow' a => 'TextShow' (Phantom a) where ...@, even though @'TextShow' a@ is + not required. If you want a proper 'TextShow' instance for @Phantom@, you will need + to use 'makeShowbPrec' (see the documentation of the @make@ functions for more + information). + +* 'deriveTextShow' lacks the ability to properly detect data types with higher-kinded + type parameters (e.g., @data HK f a = HK (f a)@) or with kinds other than @*@ + (e.g., @data List a (empty :: Bool)@). If you wish to derive 'TextShow' + instances for these data types, you will need to use 'makeShowbPrec'. + +* Some data constructors have arguments whose 'TextShow' instance depends on a + typeclass besides 'TextShow'. For example, consider @newtype MyFixed a = MyFixed + (Fixed a)@. @'Fixed' a@ is a 'TextShow' instance only if @a@ is an instance of both + @HasResolution@ and 'TextShow'. Unfortunately, 'deriveTextShow' cannot infer that + 'a' must be an instance of 'HasResolution', so it cannot create a 'TextShow' + instance for @MyFixed@. However, you can use 'makeShowbPrec' to get around this. + +-} + +-- | Generates a 'TextShow' instance declaration for the given data type or data +-- family instance. +-- +-- /Since: 2/ +deriveTextShow :: Name -> Q [Dec] +deriveTextShow = deriveTextShowClass TextShow + +{- $deriveTextShow1 + +'deriveTextShow1' automatically generates a 'Show1' instance declaration for a data +type, newtype, or data family instance that has at least one type variable. +This emulates what would (hypothetically) happen if you could attach a @deriving +'TextShow1'@ clause to the end of a data declaration. Examples: + +@ +{-# LANGUAGE TemplateHaskell #-} +import TextShow.TH + +data Stream a = Stream a (Stream a) +$('deriveTextShow1' ''Stream) -- instance TextShow1 TextStream where ... + +newtype WrappedFunctor f a = WrapFunctor (f a) +$('deriveTextShow1' ''WrappedFunctor) -- instance TextShow1 f => TextShow1 (WrappedFunctor f) where ... +@ + +The same restrictions that apply to 'deriveTextShow' also apply to 'deriveTextShow1', +with some caveats: + +* With 'deriveTextShow1', the last type variable must be of kind @*@. For other ones, + type variables of kind @*@ are assumed to require a 'TextShow' context, and type + variables of kind @* -> *@ are assumed to require a 'TextShow1' context. For more + complicated scenarios, use 'makeLiftShowbPrec'. + +* If using @-XDatatypeContexts@, a datatype constraint cannot mention the last type + variable. For example, @data Ord a => Illegal a = Illegal a@ cannot have a derived + 'TextShow1' instance. + +* If the last type variable is used within a data field of a constructor, it must only + be used in the last argument of the data type constructor. For example, @data Legal a + = Legal (Either Int a)@ can have a derived 'TextShow1' instance, but @data Illegal a + = Illegal (Either a a)@ cannot. + +* Data family instances must be able to eta-reduce the last type variable. In other + words, if you have a instance of the form: + + @ + data family Family a1 ... an t + data instance Family e1 ... e2 v = ... + @ + + Then the following conditions must hold: + + 1. @v@ must be a type variable. + 2. @v@ must not be mentioned in any of @e1@, ..., @e2@. + +-} + +-- | Generates a 'TextShow1' instance declaration for the given data type or data +-- family instance. +-- +-- /Since: 2/ +deriveTextShow1 :: Name -> Q [Dec] +deriveTextShow1 = deriveTextShowClass TextShow1 + +{- $deriveTextShow2 + +'deriveTextShow2' automatically generates a 'TextShow2' instance declaration for a data +type, newtype, or data family instance that has at least two type variables. +This emulates what would (hypothetically) happen if you could attach a @deriving +'TextShow2'@ clause to the end of a data declaration. Examples: + +@ +{-# LANGUAGE TemplateHaskell #-} +import TextShow.TH + +data OneOrNone a b = OneL a | OneR b | None +$('deriveTextShow2' ''OneOrNone) -- instance TextShow2 OneOrNone where ... + +newtype WrappedBifunctor f a b = WrapBifunctor (f a b) +$('deriveTextShow2' ''WrappedBifunctor) -- instance TextShow2 f => TextShow2 (WrappedBifunctor f) where ... +@ + +The same restrictions that apply to 'deriveTextShow' and 'deriveTextShow1' also apply +to 'deriveTextShow2', with some caveats: + +* With 'deriveTextShow2', the last type variables must both be of kind @*@. For other + ones, type variables of kind @*@ are assumed to require a 'TextShow' constraint, type + variables of kind @* -> *@ are assumed to require a 'TextShow1' constraint, and type + variables of kind @* -> * -> *@ are assumed to require a 'TextShow2' constraint. For + more complicated scenarios, use 'makeLiftShowbPrec2'. + +* If using @-XDatatypeContexts@, a datatype constraint cannot mention either of the last + two type variables. For example, @data Ord a => Illegal a b = Illegal a b@ cannot + have a derived 'TextShow2' instance. + +* If either of the last two type variables is used within a data field of a constructor, + it must only be used in the last two arguments of the data type constructor. For + example, @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'TextShow2' + instance, but @data Illegal a b = Illegal (a, b, a, b)@ cannot. + +* Data family instances must be able to eta-reduce the last two type variables. In other + words, if you have a instance of the form: + + @ + data family Family a1 ... an t1 t2 + data instance Family e1 ... e2 v1 v2 = ... + @ + + Then the following conditions must hold: + + 1. @v1@ and @v2@ must be distinct type variables. + 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. + +-} + +-- | Generates a 'TextShow2' instance declaration for the given data type or data +-- family instance. +-- +-- /Since: 2/ +deriveTextShow2 :: Name -> Q [Dec] +deriveTextShow2 = deriveTextShowClass TextShow2 + +{- $make + +There may be scenarios in which you want to show an arbitrary data type or data +family instance without having to make the type an instance of 'TextShow'. For these +cases, this modules provides several functions (all prefixed with @make@-) that +splice the appropriate lambda expression into your source code. Example: + +This is particularly useful for creating instances for sophisticated data types. For +example, 'deriveTextShow' cannot infer the correct type context for +@newtype HigherKinded f a = HigherKinded (f a)@, since @f@ is of kind @* -> *@. +However, it is still possible to derive a 'TextShow' instance for @HigherKinded@ +without too much trouble using 'makeShowbPrec': + +@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +import TextShow +import TextShow.TH + +instance TextShow (f a) => TextShow (HigherKinded f a) where + showbPrec = $(makeShowbPrec ''HigherKinded) +@ + +-} + +-- | Generates a lambda expression which behaves like 'showt' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makeShowt :: Name -> Q Exp +makeShowt name = [| toStrict . $(makeShowtl name) |] + +-- | Generates a lambda expression which behaves like 'showtl' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makeShowtl :: Name -> Q Exp +makeShowtl name = [| toLazyText . $(makeShowb name) |] + +-- | 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 |] + +-- | 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 |] + +-- | Generates a lambda expression which behaves like 'showtList' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makeShowtList :: Name -> Q Exp +makeShowtList name = [| toStrict . $(makeShowtlList name) |] + +-- | Generates a lambda expression which behaves like 'showtlList' (without +-- requiring a 'TextShow' instance). +-- +-- /Since: 2/ +makeShowtlList :: Name -> Q Exp +makeShowtlList name = [| toLazyText . $(makeShowbList name) |] + +-- | Generates a lambda expression which behaves like 'showb' (without requiring a +-- 'TextShow' instance). +-- +-- /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 + +-- | Generates a lambda expression which behaves like 'showbPrec' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makeShowbPrec :: Name -> Q Exp +makeShowbPrec = makeShowbPrecClass TextShow + +-- | Generates a lambda expression which behaves like 'liftShowbPrec' (without +-- requiring a 'TextShow1' instance). +-- +-- /Since: 3/ +makeLiftShowbPrec :: Name -> Q Exp +makeLiftShowbPrec = makeShowbPrecClass TextShow1 + +-- | Generates a lambda expression which behaves like 'showbPrec1' (without +-- requiring a 'TextShow1' instance). +-- +-- /Since: 2/ +makeShowbPrec1 :: Name -> Q Exp +makeShowbPrec1 name = [| $(makeLiftShowbPrec name) showbPrec showbList |] + +-- | Generates a lambda expression which behaves like 'liftShowbPrec2' (without +-- requiring a 'TextShow2' instance). +-- +-- /Since: 3/ +makeLiftShowbPrec2 :: Name -> Q Exp +makeLiftShowbPrec2 = makeShowbPrecClass TextShow2 + +-- | Generates a lambda expression which behaves like 'showbPrec2' (without +-- requiring a 'TextShow2' instance). +-- +-- /Since: 2/ +makeShowbPrec2 :: Name -> Q Exp +makeShowbPrec2 name = [| $(makeLiftShowbPrec2 name) showbPrec showbList showbPrec showbList |] + +-- | Generates a lambda expression which behaves like 'showbList' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makeShowbList :: Name -> Q Exp +makeShowbList name = [| showbListWith $(makeShowb name) |] + +-- | Generates a lambda expression which behaves like 'printT' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makePrintT :: Name -> Q Exp +makePrintT name = [| TS.putStrLn . $(makeShowt name) |] + +-- | Generates a lambda expression which behaves like 'printTL' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makePrintTL :: Name -> Q Exp +makePrintTL name = [| TL.putStrLn . $(makeShowtl name) |] + +-- | Generates a lambda expression which behaves like 'hPrintT' (without requiring a +-- 'TextShow' instance). +-- +-- /Since: 2/ +makeHPrintT :: Name -> Q Exp +makeHPrintT name = [| \h -> TS.hPutStrLn h . $(makeShowt name) |] + +-- | Generates a lambda expression which behaves like 'hPrintTL' (without +-- requiring a 'TextShow' instance). +-- +-- /Since: 2/ +makeHPrintTL :: Name -> Q Exp +makeHPrintTL name = [| \h -> TL.hPutStrLn h . $(makeShowtl name) |] + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | 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 + where + fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] + fromCons name' ctxt tvbs cons mbTys = (:[]) <$> do + (instanceCxt, instanceType) + <- buildTypeInstance tsClass name' ctxt tvbs mbTys + instanceD (return instanceCxt) + (return instanceType) + (showbPrecDecs tsClass 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) + [] + ] + ] + +-- | 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 + where + fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp + fromCons name' ctxt tvbs cons mbTys = + -- We force buildTypeInstance here since it performs some checks for whether + -- 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 + +-- | 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 + 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 + lamE (map varP $ spsAndSls ++ [p, value]) + . appsE + $ [ varE $ showbPrecConstName tsClass + , 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 + m <- match + (conP conName []) + (normalB [| fromString $(stringE (parenInfixConName conName "")) |]) + [] + return [m] +makeTextShowForCon p tsClass 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) |] + + m <- match + (conP conName [varP arg]) + (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArg) |]) + [] + return [m] +makeTextShowForCon p tsClass 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 + + 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) |] + + match (conP conName $ map varP args) + (normalB [| showbParen ($(varE p) > $(lift appPrec)) $(namedArgs) |]) + [] + return [m] +makeTextShowForCon p tsClass spls (RecC conName []) = + makeTextShowForCon p tsClass spls $ NormalC conName [] +makeTextShowForCon _p tsClass 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 ", " |] + ] + ) + (zip3 ts argTys args) + braceCommaArgs = [| singleton '{' |] : take (length showArgs - 1) showArgs + mappendArgs = foldr (`infixApp` [| (<>) |]) + [| singleton '}' |] + braceCommaArgs + namedArgs = [| fromString $(stringE (parenInfixConName conName " ")) <> $(mappendArgs) |] + + m <- match + (conP conName $ map varP args) + (normalB +#if __GLASGOW_HASKELL__ >= 711 + namedArgs +#else + [| showbParen ($(varE _p) > $(lift appPrec)) $(namedArgs) |] +#endif + ) + [] + return [m] +makeTextShowForCon p tsClass spls (InfixC _ conName _) = do + ([alTy, arTy], tvMap) <- reifyConTys tsClass spls conName + al <- newName "argL" + ar <- newName "argR" + info <- reify conName + +#if __GLASGOW_HASKELL__ >= 711 + conPrec <- case info of + DataConI{} -> do + fi <- fromMaybe defaultFixity <$> reifyFixity conName + case fi of + Fixity prec _ -> return prec +#else + let conPrec = case info of + DataConI _ _ _ (Fixity prec _) -> prec +#endif + _ -> error $ "TextShow.TH.makeTextShowForCon: Unsupported type: " ++ show info + + let opName = nameBase conName + infixOpE = if isInfixTypeCon opName + then [| fromString $(stringE $ " " ++ opName ++ " " ) |] + else [| fromString $(stringE $ " `" ++ 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) + |] + ) + [] + return [m] +makeTextShowForCon p tsClass spls (ForallC _ _ con) = + makeTextShowForCon p tsClass spls con +#if MIN_VERSION_template_haskell(2,11,0) +makeTextShowForCon p tsClass spls (GadtC conNames ts _) = + let con :: Name -> Q Con + con conName = do + mbFi <- reifyFixity conName + return $ if startsConSym (head $ nameBase conName) + && length ts == 2 + && isJust mbFi + 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 +#endif + +-- | Generates a lambda expression for howbPrec/liftShowbPrec/etc. for an +-- argument of a constructor. +makeTextShowForArg :: Int + -> TextShowClass + -> 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. + showE + where + tyVarE :: Q Exp + tyVarE = varE tyExpName + + 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 + + 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 +#endif +makeTextShowForArg p tsClass conName tvMap ty tyExpName = + [| $(makeTextShowForType tsClass 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. +-- +-- 1. If the type is of kind * (T), apply showbPrec. +-- 2. If the type is of kind * -> * (T a), apply liftShowbPrec $(makeTextShowForType a) +-- 3. If the type is of kind * -> * -> * (T a b), apply +-- liftShowbPrec2 $(makeTextShowForType a) $(makeTextShowForType b) +makeTextShowForType :: TextShowClass + -> 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 + let tyCon :: Type + tyArgs :: [Type] + tyCon :| tyArgs = unapplyTy ty + + numLastArgs :: Int + numLastArgs = min (fromEnum tsClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + + itf <- isTyFamily tyCon + if any (`mentionsName` tyVarNames) lhsArgs + || itf && any (`mentionsName` tyVarNames) tyArgs + then outOfPlaceTyVarError tsClass conName + else appsE $ [ varE . showbPrecOrListName sl $ toEnum numLastArgs] + ++ zipWith (makeTextShowForType tsClass conName tvMap) + (cycle [False,True]) + (interleave rhsArgs rhsArgs) + +------------------------------------------------------------------------------- +-- Template Haskell reifying and AST manipulation +------------------------------------------------------------------------------- + +-- | Extracts a plain type constructor's information. +-- | Boilerplate for top level splices. +-- +-- The given Name must meet one of two criteria: +-- +-- 1. It must be the name of a type constructor of a plain data type or newtype. +-- 2. It must be the name of a data family instance or newtype instance constructor. +-- +-- Any other value will result in an exception. +withType :: Name + -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) + -> Q a +withType name f = do + info <- reify name + case info of + TyConI dec -> + case dec of + DataD ctxt _ tvbs +#if MIN_VERSION_template_haskell(2,11,0) + _ +#endif + cons _ -> f name ctxt tvbs cons Nothing + NewtypeD ctxt _ tvbs +#if MIN_VERSION_template_haskell(2,11,0) + _ +#endif + con _ -> f name ctxt tvbs [con] Nothing + _ -> error $ ns ++ "Unsupported type: " ++ show dec +#if MIN_VERSION_template_haskell(2,7,0) +# if MIN_VERSION_template_haskell(2,11,0) + DataConI _ _ parentName -> do +# else + DataConI _ _ parentName _ -> do +# endif + parentInfo <- reify parentName + case parentInfo of +# if MIN_VERSION_template_haskell(2,11,0) + FamilyI (DataFamilyD _ tvbs _) decs -> +# else + FamilyI (FamilyD DataFam _ tvbs _) decs -> +# endif + let instDec = flip find decs $ \dec -> case dec of + DataInstD _ _ _ +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + cons _ -> any ((name ==) . constructorName) cons + NewtypeInstD _ _ _ +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + con _ -> name == constructorName con + _ -> error $ ns ++ "Must be a data or newtype instance." + in case instDec of + Just (DataInstD ctxt _ instTys +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + cons _) + -> f parentName ctxt tvbs cons $ Just instTys + Just (NewtypeInstD ctxt _ instTys +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + con _) + -> f parentName ctxt tvbs [con] $ Just instTys + _ -> error $ ns ++ + "Could not find data or newtype instance constructor." + _ -> error $ ns ++ "Data constructor " ++ show name ++ + " is not from a data family instance constructor." +# if MIN_VERSION_template_haskell(2,11,0) + FamilyI DataFamilyD{} _ -> +# else + FamilyI (FamilyD DataFam _ _ _) _ -> +# endif + error $ ns ++ + "Cannot use a data family name. Use a data family instance constructor instead." + _ -> error $ ns ++ "The name must be of a plain data type constructor, " + ++ "or a data family instance constructor." +#else + DataConI{} -> dataConIError + _ -> error $ ns ++ "The name must be of a plain type constructor." +#endif + where + ns :: String + ns = "TextShow.TH.withType: " + +-- | Deduces the instance context and head for an instance. +buildTypeInstance :: TextShowClass + -- ^ TextShow, TextShow1, or TextShow2 + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [TyVarBndr] + -- ^ The type variables from the data type/data family declaration + -> Maybe [Type] + -- ^ 'Just' the types used to instantiate a data family instance, + -- or 'Nothing' if it's a plain data type + -> Q (Cxt, Type) +-- Plain data type/newtype case +buildTypeInstance tsClass tyConName dataCxt tvbs Nothing = + let varTys :: [Type] + varTys = map tvbToType tvbs + in buildTypeInstanceFromTys tsClass tyConName dataCxt varTys False +-- Data family instance case +-- +-- The CPP is present to work around a couple of annoying old GHC bugs. +-- See Note [Polykinded data families in Template Haskell] +buildTypeInstance tsClass parentName dataCxt tvbs (Just instTysAndKinds) = do +#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) + let instTys :: [Type] + instTys = zipWith stealKindForType tvbs instTysAndKinds +#else + let kindVarNames :: [Name] + kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs + + numKindVars :: Int + numKindVars = length kindVarNames + + givenKinds, givenKinds' :: [Kind] + givenTys :: [Type] + (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds + givenKinds' = map sanitizeStars givenKinds + + -- A GHC 7.6-specific bug requires us to replace all occurrences of + -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. + -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. + sanitizeStars :: Kind -> Kind + sanitizeStars = go + where + go :: Kind -> Kind + go (AppT t1 t2) = AppT (go t1) (go t2) + go (SigT t k) = SigT (go t) (go k) + go (ConT n) | n == starKindName = StarT + go t = t + + -- It's quite awkward to import * from GHC.Prim, so we'll just + -- hack our way around it. + starKindName :: Name + starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" + + -- If we run this code with GHC 7.8, we might have to generate extra type + -- variables to compensate for any type variables that Template Haskell + -- eta-reduced away. + -- See Note [Polykinded data families in Template Haskell] + xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) + + let xTys :: [Type] + xTys = map VarT xTypeNames + -- ^ Because these type variables were eta-reduced away, we can only + -- determine their kind by using stealKindForType. Therefore, we mark + -- them as VarT to ensure they will be given an explicit kind annotation + -- (and so the kind inference machinery has the right information). + + substNamesWithKinds :: [(Name, Kind)] -> Type -> Type + substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks + + -- The types from the data family instance might not have explicit kind + -- annotations, which the kind machinery needs to work correctly. To + -- compensate, we use stealKindForType to explicitly annotate any + -- types without kind annotations. + instTys :: [Type] + instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) + -- ^ Note that due to a GHC 7.8-specific bug + -- (see Note [Polykinded data families in Template Haskell]), + -- there may be more kind variable names than there are kinds + -- to substitute. But this is OK! If a kind is eta-reduced, it + -- means that is was not instantiated to something more specific, + -- so we need not substitute it. Using stealKindForType will + -- grab the correct kind. + $ zipWith stealKindForType tvbs (givenTys ++ xTys) +#endif + buildTypeInstanceFromTys tsClass parentName dataCxt instTys True + +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] +buildTypeInstanceFromTys :: TextShowClass + -- ^ TextShow, TextShow1, or TextShow2 + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [Type] + -- ^ The types to instantiate the instance with + -> Bool + -- ^ True if it's a data family, False otherwise + -> Q (Cxt, Type) +buildTypeInstanceFromTys tsClass tyConName dataCxt varTysOrig isDataFamily = do + -- Make sure to expand through type/kind synonyms! Otherwise, the + -- eta-reduction check might get tripped up over type variables in a + -- synonym that are actually dropped. + -- (See GHC Trac #11416 for a scenario where this actually happened.) + varTysExp <- mapM expandSyn varTysOrig + + let remainingLength :: Int + remainingLength = length varTysOrig - fromEnum tsClass + + droppedTysExp :: [Type] + droppedTysExp = drop remainingLength varTysExp + + droppedStarKindStati :: [StarKindStatus] + droppedStarKindStati = map canRealizeKindStar droppedTysExp + + -- Check there are enough types to drop and that all of them are either of + -- kind * or kind k (for some kind variable k). If not, throw an error. + when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ + derivingKindError tsClass tyConName + + let droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati + + -- Substitute kind * for any dropped kind variables + varTysExpSubst :: [Type] + varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp + + remainingTysExpSubst, droppedTysExpSubst :: [Type] + (remainingTysExpSubst, droppedTysExpSubst) = + splitAt remainingLength varTysExpSubst + + -- All of the type variables mentioned in the dropped types + -- (post-synonym expansion) + droppedTyVarNames :: [Name] + droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + + -- If any of the dropped types were polykinded, ensure that there are of kind + -- * after substituting * for the dropped kind variables. If not, throw an error. + unless (all hasKindStar droppedTysExpSubst) $ + derivingKindError tsClass tyConName + + let preds :: [Maybe Pred] + kvNames :: [[Name]] + kvNames' :: [Name] + -- Derive instance constraints (and any kind variables which are specialized + -- to * in those constraints) + (preds, kvNames) = unzip $ map (deriveConstraint tsClass) remainingTysExpSubst + kvNames' = concat kvNames + + -- Substitute the kind variables specialized in the constraints with * + remainingTysExpSubst' :: [Type] + remainingTysExpSubst' = + map (substNamesWithKindStar kvNames') remainingTysExpSubst + + -- We now substitute all of the specialized-to-* kind variable names with + -- *, but in the original types, not the synonym-expanded types. The reason + -- we do this is a superficial one: we want the derived instance to resemble + -- the datatype written in source code as closely as possible. For example, + -- for the following data family instance: + -- + -- data family Fam a + -- newtype instance Fam String = Fam String + -- + -- We'd want to generate the instance: + -- + -- instance C (Fam String) + -- + -- Not: + -- + -- instance C (Fam [Char]) + remainingTysOrigSubst :: [Type] + remainingTysOrigSubst = + map (substNamesWithKindStar (union droppedKindVarNames kvNames')) + $ take remainingLength varTysOrig + + remainingTysOrigSubst' :: [Type] + -- See Note [Kind signatures in derived instances] for an explanation + -- of the isDataFamily check. + remainingTysOrigSubst' = + if isDataFamily + then remainingTysOrigSubst + else map unSigT remainingTysOrigSubst + + instanceCxt :: Cxt + instanceCxt = catMaybes preds + + instanceType :: Type + instanceType = AppT (ConT $ textShowClassName tsClass) + $ applyTyCon tyConName remainingTysOrigSubst' + + -- If the datatype context mentions any of the dropped type variables, + -- we can't derive an instance, so throw an error. + when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ + datatypeContextError tyConName instanceType + -- Also ensure the dropped types can be safely eta-reduced. Otherwise, + -- throw an error. + unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ + etaReductionError instanceType + return (instanceCxt, instanceType) + +-- | Attempt to derive a constraint on a Type. If successful, return +-- Just the constraint and any kind variable names constrained to *. +-- Otherwise, return Nothing and the empty list. +-- +-- See Note [Type inference in derived instances] for the heuristics used to +-- come up with constraints. +deriveConstraint :: TextShowClass -> Type -> (Maybe Pred, [Name]) +deriveConstraint tsClass t + | not (isTyVar t) = (Nothing, []) + | hasKindStar t = (Just (applyClass ''TextShow tName), []) + | otherwise = case hasKindVarChain 1 t of + Just ns | tsClass >= TextShow1 + -> (Just (applyClass ''TextShow1 tName), ns) + _ -> case hasKindVarChain 2 t of + Just ns | tsClass == TextShow2 + -> (Just (applyClass ''TextShow2 tName), ns) + _ -> (Nothing, []) + where + tName :: Name + tName = varTToName t + +{- +Note [Polykinded data families in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In order to come up with the correct instance context and head for an instance, e.g., + + instance C a => C (Data a) where ... + +We need to know the exact types and kinds used to instantiate the instance. For +plain old datatypes, this is simple: every type must be a type variable, and +Template Haskell reliably tells us the type variables and their kinds. + +Doing the same for data families proves to be much harder for three reasons: + +1. On any version of Template Haskell, it may not tell you what an instantiated + type's kind is. For instance, in the following data family instance: + + data family Fam (f :: * -> *) (a :: *) + data instance Fam f a + + Then if we use TH's reify function, it would tell us the TyVarBndrs of the + data family declaration are: + + [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] + + and the instantiated types of the data family instance are: + + [VarT f1,VarT a1] + + We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we + have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the + kind is in case an instantiated type isn't a SigT, so we use the stealKindForType + function to ensure all of the instantiated types are SigTs before passing them + to buildTypeInstanceFromTys. +2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of + the specified kinds of a data family instance efore any of the instantiated + types. Fortunately, this is easy to deal with: you simply count the number of + distinct kind variables in the data family declaration, take that many elements + from the front of the Types list of the data family instance, substitute the + kind variables with their respective instantiated kinds (which you took earlier), + and proceed as normal. +3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template + Haskell might not even list all of the Types of a data family instance, since + they are eta-reduced away! And yes, kinds can be eta-reduced too. + + The simplest workaround is to count how many instantiated types are missing from + the list and generate extra type variables to use in their place. Luckily, we + needn't worry much if its kind was eta-reduced away, since using stealKindForType + will get it back. + +Note [Kind signatures in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to put explicit kind signatures into the derived instances, e.g., + + instance C a => C (Data (f :: * -> *)) where ... + +But it is preferable to avoid this if possible. If we come up with an incorrect +kind signature (which is entirely possible, since our type inferencer is pretty +unsophisticated - see Note [Type inference in derived instances]), then GHC will +flat-out reject the instance, which is quite unfortunate. + +Plain old datatypes have the advantage that you can avoid using any kind signatures +at all in their instances. This is because a datatype declaration uses all type +variables, so the types that we use in a derived instance uniquely determine their +kinds. As long as we plug in the right types, the kind inferencer can do the rest +of the work. For this reason, we use unSigT to remove all kind signatures before +splicing in the instance context and head. + +Data family instances are trickier, since a data family can have two instances that +are distinguished by kind alone, e.g., + + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) + +If we dropped the kind signatures for C (Fam a), then GHC will have no way of +knowing which instance we are talking about. To avoid this scenario, we always +include explicit kind signatures in data family instances. There is a chance that +the inferred kind signatures will be incorrect, but if so, we can always fall back +on the make- functions. + +Note [Type inference in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Type inference is can be tricky to get right, and we want to avoid recreating the +entirety of GHC's type inferencer in Template Haskell. For this reason, we will +probably never come up with derived instance contexts that are as accurate as +GHC's. But that doesn't mean we can't do anything! There are a couple of simple +things we can do to make instance contexts that work for 80% of use cases: + +1. If one of the last type parameters is polykinded, then its kind will be + specialized to * in the derived instance. We note what kind variable the type + parameter had and substitute it with * in the other types as well. For example, + imagine you had + + data Data (a :: k) (b :: k) + + Then you'd want to derived instance to be: + + instance C (Data (a :: *)) + + Not: + + instance C (Data (a :: k)) + +2. We naïvely come up with instance constraints using the following criteria: + + (i) If there's a type parameter n of kind *, generate a TextShow n constraint. + (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind + variables), then generate a TextShow1 n constraint, and if k1/k2 are kind + variables, then substitute k1/k2 with * elsewhere in the types. We must + consider the case where they are kind variables because you might have a + scenario like this: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) + + Which would have a derived TextShow1 instance of: + + instance (TextShow1 f, TextShow1 g) => TextShow1 (Compose f g) where ... + (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are + * or kind variables), then generate a TextShow2 constraint and perform + kind substitution as in the other cases. +-} + +------------------------------------------------------------------------------- +-- Error messages +------------------------------------------------------------------------------- + +-- | Either the given data type doesn't have enough type variables, or one of +-- the type variables to be eta-reduced cannot realize kind *. +derivingKindError :: TextShowClass -> Name -> a +derivingKindError tsClass tyConName = error + . showString "Cannot derive well-kinded instance of form ‘" + . showString className + . showChar ' ' + . showParen True + ( showString (nameBase tyConName) + . showString " ..." + ) + . showString "‘\n\tClass " + . showString className + . showString " expects an argument of kind " + . showString (pprint . createKindChain $ fromEnum tsClass) + $ "" + where + className :: String + className = nameBase $ textShowClassName tsClass + +-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce +-- function for the criteria it would have to meet). +etaReductionError :: Type -> a +etaReductionError instanceType = error $ + "Cannot eta-reduce to an instance of form \n\tinstance (...) => " + ++ pprint instanceType + +-- | The data type has a DatatypeContext which mentions one of the eta-reduced +-- type variables. +datatypeContextError :: Name -> Type -> a +datatypeContextError dataName instanceType = error + . showString "Can't make a derived instance of ‘" + . showString (pprint instanceType) + . showString "‘:\n\tData type ‘" + . showString (nameBase dataName) + . showString "‘ must not have a class context involving the last type argument(s)" + $ "" + +-- | The data type mentions one of the n eta-reduced type variables in a place other +-- than the last nth positions of a data type in a constructor's field. +outOfPlaceTyVarError :: TextShowClass -> Name -> a +outOfPlaceTyVarError tsClass conName = error + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must only use its last " + . shows n + . showString " type variable(s) within the last " + . shows n + . showString " argument(s) of a data type" + $ "" + where + n :: Int + n = fromEnum tsClass + +#if !(MIN_VERSION_template_haskell(2,7,0)) +-- | Template Haskell didn't list all of a data family's instances upon reification +-- until template-haskell-2.7.0.0, which is necessary for a derived TextShow(1)(2) +-- instance to work. +dataConIError :: a +dataConIError = error + . showString "Cannot use a data constructor." + . showString "\n\t(Note: if you are trying to derive TextShow for a" + . showString "\n\ttype family, use GHC >= 7.4 instead.)" + $ "" +#endif + +------------------------------------------------------------------------------- +-- Expanding type synonyms +------------------------------------------------------------------------------- + +-- | Expands all type synonyms in a type. Written by Dan Rosén in the +-- @genifunctors@ package (licensed under BSD3). +expandSyn :: Type -> Q Type +expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t +expandSyn t@AppT{} = expandSynApp t [] +expandSyn t@ConT{} = expandSynApp t [] +expandSyn (SigT t k) = do t' <- expandSyn t + k' <- expandSynKind k + return (SigT t' k') +expandSyn t = return t + +expandSynKind :: Kind -> Q Kind +#if MIN_VERSION_template_haskell(2,8,0) +expandSynKind = expandSyn +#else +expandSynKind = return -- There are no kind synonyms to deal with +#endif + +expandSynApp :: Type -> [Type] -> Q Type +expandSynApp (AppT t1 t2) ts = do + t2' <- expandSyn t2 + expandSynApp t1 (t2':ts) +expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts +expandSynApp t@(ConT n) ts = do + info <- reify n + case info of + TyConI (TySynD _ tvs rhs) -> + let (ts', ts'') = splitAt (length tvs) ts + subs = mkSubst tvs ts' + rhs' = substType subs rhs + in expandSynApp rhs' ts'' + _ -> return $ foldl' AppT t ts +expandSynApp t ts = do + t' <- expandSyn t + return $ foldl' AppT t' ts + +type TypeSubst = Map Name Type +type KindSubst = Map Name Kind + +mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst +mkSubst vs ts = + let vs' = map un vs + un (PlainTV v) = v + un (KindedTV v _) = v + in Map.fromList $ zip vs' ts + +substType :: TypeSubst -> Type -> Type +substType subs (ForallT v c t) = ForallT v c $ substType subs t +substType subs t@(VarT n) = Map.findWithDefault t n subs +substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2) +substType subs (SigT t k) = SigT (substType subs t) +#if MIN_VERSION_template_haskell(2,8,0) + (substType subs k) +#else + k +#endif +substType _ t = t + +substKind :: KindSubst -> Type -> Type +#if MIN_VERSION_template_haskell(2,8,0) +substKind = substType +#else +substKind _ = id -- There are no kind variables! +#endif + +substNameWithKind :: Name -> Kind -> Type -> Type +substNameWithKind n k = substKind (Map.singleton n k) + +substNamesWithKindStar :: [Name] -> Type -> Type +substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which TextShow variant is being derived. +data TextShowClass = TextShow | TextShow1 | TextShow2 + deriving (Enum, Eq, Ord) + +showbPrecConstName :: TextShowClass -> Name +showbPrecConstName TextShow = 'showbPrecConst +showbPrecConstName TextShow1 = 'liftShowbPrecConst +showbPrecConstName TextShow2 = 'liftShowbPrec2Const + +textShowClassName :: TextShowClass -> Name +textShowClassName TextShow = ''TextShow +textShowClassName TextShow1 = ''TextShow1 +textShowClassName TextShow2 = ''TextShow2 + +showbPrecName :: TextShowClass -> Name +showbPrecName TextShow = 'showbPrec +showbPrecName TextShow1 = 'liftShowbPrec +showbPrecName TextShow2 = 'liftShowbPrec2 + +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 + +-- | 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 +-- the expression wouldn't depend on the precedence). For example, if you had @data +-- Nullary = Nullary@ and attempted to run @$(makeShowbPrec ''Nullary) Nullary@, simply +-- ignoring the precedence argument would cause the type signature of @$(makeShowbPrec +-- ''Nullary)@ to be @a -> Nullary -> Builder@, not @Int -> Nullary -> Builder@. +showbPrecConst :: Builder + -> Int -> a -> Builder +showbPrecConst b _ _ = b + +liftShowbPrecConst :: Builder + -> (Int -> a -> Builder) -> ([a] -> Builder) + -> Int -> f a -> Builder +liftShowbPrecConst b _ _ _ _ = b + +liftShowbPrec2Const :: Builder + -> (Int -> a -> Builder) -> ([a] -> Builder) + -> (Int -> b -> Builder) -> ([b] -> Builder) + -> Int -> f a b -> Builder +liftShowbPrec2Const b _ _ _ _ _ _ = b + +------------------------------------------------------------------------------- +-- StarKindStatus +------------------------------------------------------------------------------- + +-- | Whether a type is not of kind *, is of kind *, or is a kind variable. +data StarKindStatus = NotKindStar + | KindStar + | IsKindVar Name + deriving Eq + +-- | Does a Type have kind * or k (for some kind variable k)? +canRealizeKindStar :: Type -> StarKindStatus +canRealizeKindStar t + | hasKindStar t = KindStar + | otherwise = case t of +#if MIN_VERSION_template_haskell(2,8,0) + SigT _ (VarT k) -> IsKindVar k +#endif + _ -> NotKindStar + +-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. +-- Otherwise, returns 'Nothing'. +starKindStatusToName :: StarKindStatus -> Maybe Name +starKindStatusToName (IsKindVar n) = Just n +starKindStatusToName _ = Nothing + +-- | Concat together all of the StarKindStatuses that are IsKindVar and extract +-- the kind variables' Names out. +catKindVarNames :: [StarKindStatus] -> [Name] +catKindVarNames = mapMaybe starKindStatusToName + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +-- | Returns True if a Type has kind *. +hasKindStar :: Type -> Bool +hasKindStar VarT{} = True +#if MIN_VERSION_template_haskell(2,8,0) +hasKindStar (SigT _ StarT) = True +#else +hasKindStar (SigT _ StarK) = True +#endif +hasKindStar _ = False + +-- Returns True is a kind is equal to *, or if it is a kind variable. +isStarOrVar :: Kind -> Bool +#if MIN_VERSION_template_haskell(2,8,0) +isStarOrVar StarT = True +isStarOrVar VarT{} = True +#else +isStarOrVar StarK = True +#endif +isStarOrVar _ = False + +-- Generate a list of fresh names with a common prefix, and numbered suffixes. +newNameList :: String -> Int -> Q [Name] +newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] + +-- | Gets all of the type/kind variable names mentioned somewhere in a Type. +tyVarNamesOfType :: Type -> [Name] +tyVarNamesOfType = go + where + go :: Type -> [Name] + go (AppT t1 t2) = go t1 ++ go t2 + go (SigT t _k) = go t +#if MIN_VERSION_template_haskell(2,8,0) + ++ go _k +#endif + go (VarT n) = [n] + go _ = [] + +-- | Gets all of the type/kind variable names mentioned somewhere in a Kind. +tyVarNamesOfKind :: Kind -> [Name] +#if MIN_VERSION_template_haskell(2,8,0) +tyVarNamesOfKind = tyVarNamesOfType +#else +tyVarNamesOfKind _ = [] -- There are no kind variables +#endif + +-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form +-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or +-- kind variables. +hasKindVarChain :: Int -> Type -> Maybe [Name] +hasKindVarChain kindArrows t = + let uk = uncurryKind (tyKind t) + in if (length uk - 1 == kindArrows) && all isStarOrVar uk + then Just (concatMap tyVarNamesOfKind uk) + else Nothing + +-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. +tyKind :: Type -> Kind +tyKind (SigT _ k) = k +tyKind _ = starK + +-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. +stealKindForType :: TyVarBndr -> Type -> Type +stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) +stealKindForType _ t = t + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +-- | A mapping of type variable Names to their show function Names. For example, in a +-- TextShow2 declaration, a TyVarMap might look like (a ~> sp1, b ~> sp2), where +-- a and b are the last two type variables of the datatype, and sp1 and sp2 are the two +-- functions which show their respective type variables. +type TyVarMap = Map Name (Name, Name) + +-- | Checks if a 'Name' represents a tuple type constructor (other than '()') +isNonUnitTuple :: Name -> Bool +isNonUnitTuple = isTupleString . nameBase + +-- | Parenthesize an infix constructor name if it is being applied as a prefix +-- function (e.g., data Amp a = (:&) a a) +parenInfixConName :: Name -> ShowS +parenInfixConName conName = + let conNameBase = nameBase conName + in showParen (isInfixTypeCon conNameBase) $ showString conNameBase + +-- | Extracts the kind from a TyVarBndr. +tvbKind :: TyVarBndr -> Kind +tvbKind (PlainTV _) = starK +tvbKind (KindedTV _ k) = k + +-- | Convert a TyVarBndr to a Type. +tvbToType :: TyVarBndr -> Type +tvbToType (PlainTV n) = VarT n +tvbToType (KindedTV n k) = SigT (VarT n) k + +-- | Applies a typeclass constraint to a type. +applyClass :: Name -> Name -> Pred +#if MIN_VERSION_template_haskell(2,10,0) +applyClass con t = AppT (ConT con) (VarT t) +#else +applyClass con t = ClassP con [VarT t] +#endif + +-- | Checks to see if the last types in a data family instance can be safely eta- +-- reduced (i.e., dropped), given the other types. This checks for three conditions: +-- +-- (1) All of the dropped types are type variables +-- (2) All of the dropped types are distinct +-- (3) None of the remaining types mention any of the dropped types +canEtaReduce :: [Type] -> [Type] -> Bool +canEtaReduce remaining dropped = + all isTyVar dropped + && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type + -- didn't have an Ord instance until template-haskell-2.10.0.0 + && not (any (`mentionsName` droppedNames) remaining) + where + droppedNames :: [Name] + droppedNames = map varTToName dropped + +-- | Extract Just the Name from a type variable. If the argument Type is not a +-- type variable, return Nothing. +varTToName_maybe :: Type -> Maybe Name +varTToName_maybe (VarT n) = Just n +varTToName_maybe (SigT t _) = varTToName_maybe t +varTToName_maybe _ = Nothing + +-- | Extract the Name from a type variable. If the argument Type is not a +-- type variable, throw an error. +varTToName :: Type -> Name +varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe + +-- | Peel off a kind signature from a Type (if it has one). +unSigT :: Type -> Type +unSigT (SigT t _) = t +unSigT t = t + +-- | Is the given type a variable? +isTyVar :: Type -> Bool +isTyVar (VarT _) = True +isTyVar (SigT t _) = isTyVar t +isTyVar _ = False + +-- | Is the given type a type family constructor (and not a data family constructor)? +isTyFamily :: Type -> Q Bool +isTyFamily (ConT n) = do + info <- reify n + return $ case info of +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI OpenTypeFamilyD{} _ -> True +#elif MIN_VERSION_template_haskell(2,7,0) + FamilyI (FamilyD TypeFam _ _ _) _ -> True +#else + TyConI (FamilyD TypeFam _ _ _) -> True +#endif +#if MIN_VERSION_template_haskell(2,9,0) + FamilyI ClosedTypeFamilyD{} _ -> True +#endif + _ -> False +isTyFamily _ = return False + +-- | Are all of the items in a list (which have an ordering) distinct? +-- +-- This uses Set (as opposed to nub) for better asymptotic time complexity. +allDistinct :: Ord a => [a] -> Bool +allDistinct = allDistinct' Set.empty + where + allDistinct' :: Ord a => Set a -> [a] -> Bool + allDistinct' uniqs (x:xs) + | x `Set.member` uniqs = False + | otherwise = allDistinct' (Set.insert x uniqs) xs + allDistinct' _ _ = True + +-- | Does the given type mention any of the Names in the list? +mentionsName :: Type -> [Name] -> Bool +mentionsName = go + where + go :: Type -> [Name] -> Bool + go (AppT t1 t2) names = go t1 names || go t2 names + go (SigT t _k) names = go t names +#if MIN_VERSION_template_haskell(2,8,0) + || go _k names +#endif + go (VarT n) names = n `elem` names + go _ _ = False + +-- | Does an instance predicate mention any of the Names in the list? +predMentionsName :: Pred -> [Name] -> Bool +#if MIN_VERSION_template_haskell(2,10,0) +predMentionsName = mentionsName +#else +predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys +predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names +#endif + +-- | Construct a type via curried application. +applyTy :: Type -> [Type] -> Type +applyTy = foldl' AppT + +-- | Fully applies a type constructor to its type variables. +applyTyCon :: Name -> [Type] -> Type +applyTyCon = applyTy . ConT + +-- | Split an applied type into its individual components. For example, this: +-- +-- @ +-- Either Int Char +-- @ +-- +-- would split to this: +-- +-- @ +-- [Either, Int, Char] +-- @ +unapplyTy :: Type -> NonEmpty Type +unapplyTy = NE.reverse . go + where + go :: Type -> NonEmpty Type + go (AppT t1 t2) = t2 <| go t1 + go (SigT t _) = go t + go (ForallT _ _ t) = go t + go t = t :| [] + +-- | Split a type signature by the arrows on its spine. For example, this: +-- +-- @ +-- (Int -> String) -> Char -> () +-- @ +-- +-- would split to this: +-- +-- @ +-- [Int -> String, Char, ()] +-- @ +uncurryTy :: Type -> NonEmpty Type +uncurryTy (AppT (AppT ArrowT t1) t2) = t1 <| uncurryTy t2 +uncurryTy (SigT t _) = uncurryTy t +uncurryTy (ForallT _ _ t) = uncurryTy t +uncurryTy t = t :| [] + +-- | Like uncurryType, except on a kind level. +uncurryKind :: Kind -> NonEmpty Kind +#if MIN_VERSION_template_haskell(2,8,0) +uncurryKind = uncurryTy +#else +uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2 +uncurryKind k = k :| [] +#endif + +createKindChain :: Int -> Kind +createKindChain = go starK + where + go :: Kind -> Int -> Kind + go k !0 = k +#if MIN_VERSION_template_haskell(2,8,0) + go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) +#else + go k !n = go (ArrowK StarK k) (n - 1) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- | Extracts the name of a constructor. +constructorName :: Con -> Name +constructorName (NormalC name _ ) = name +constructorName (RecC name _ ) = name +constructorName (InfixC _ name _ ) = name +constructorName (ForallC _ _ con) = constructorName con +# if MIN_VERSION_template_haskell(2,11,0) +constructorName (GadtC names _ _) = head names +constructorName (RecGadtC names _ _) = head names +# endif +#endif + +interleave :: [a] -> [a] -> [a] +interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s +interleave _ _ = [] + +-- Determines the types of a constructor's arguments as well as the last type +-- parameters (mapped to their show functions), expanding through any type synonyms. +-- The type parameters are determined on a constructor-by-constructor basis since +-- they may be refined to be particular types in a GADT. +reifyConTys :: TextShowClass + -> [(Name, Name)] + -> Name + -> Q ([Type], TyVarMap) +reifyConTys tsClass spls conName = do + info <- reify conName + uncTy <- case info of + DataConI _ ty _ +#if !(MIN_VERSION_template_haskell(2,11,0)) + _ +#endif + -> fmap uncurryTy (expandSyn ty) + _ -> error "Must be a data constructor" + let (argTys, [resTy]) = NE.splitAt (length uncTy - 1) uncTy + unapResTy = unapplyTy resTy + -- If one of the last type variables is refined to a particular type + -- (i.e., not truly polymorphic), we mark it with Nothing and filter + -- it out later, since we only apply show functions to arguments of + -- a type that it (1) one of the last type variables, and (2) + -- of a truly polymorphic type. + mbTvNames = map varTToName_maybe $ + NE.drop (NE.length unapResTy - fromEnum tsClass) unapResTy + -- We use Map.fromList to ensure that if there are any duplicate type + -- variables (as can happen in a GADT), the rightmost type variable gets + -- associated with the show function. + -- + -- See Note [Matching functions with GADT type variables] + tvMap = Map.fromList + . catMaybes -- Drop refined types + $ zipWith (\mbTvName sp -> + fmap (\tvName -> (tvName, sp)) mbTvName) + mbTvNames spls + return (argTys, tvMap) + +{- +Note [Matching functions with GADT type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When deriving TextShow2, there is a tricky corner case to consider: + + data Both a b where + BothCon :: x -> x -> Both x x + +Which show functions should be applied to which arguments of BothCon? We have a +choice, since both the function of type (Int -> a -> Builder) and of type +(Int -> b -> Builder) can be applied to either argument. In such a scenario, the +second show function takes precedence over the first show function, so the +derived TextShow2 instance would be: + + instance TextShow Both where + liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = + showbParen (p > appPrec) $ + "BothCon " <> sp2 appPrec1 x1 <> showbSpace <> sp2 appPrec1 x2 + +This is not an arbitrary choice, as this definition ensures that +liftShowsPrec2 showsPrec = liftShowsPrec for a derived TextShow1 instance for +Both. +-} diff --git a/src/TextShow/Utils.hs b/src/TextShow/Utils.hs --- a/src/TextShow/Utils.hs +++ b/src/TextShow/Utils.hs @@ -12,33 +12,43 @@ Miscellaneous utility functions. -} module TextShow.Utils ( - i2d + coerce + , i2d , isInfixTypeCon , isTupleString , lengthB - , mtimesDefault , toString , toText , unlinesB , unwordsB ) where -import Data.Int (Int64) -import Data.Text (Text) -import Data.Monoid.Compat ((<>)) -#if MIN_VERSION_semigroups(0,17,0) -import Data.Semigroup (mtimesDefault) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Monoid.Compat ((<>)) +import Data.Text.Lazy (length, toStrict, unpack) +import Data.Text.Lazy.Builder (Builder, singleton, toLazyText) + +import GHC.Exts (Char(C#), Int(I#)) +import GHC.Prim ((+#), chr#, ord#) + +import Prelude () +import Prelude.Compat hiding (length) + +#if __GLASGOW_HASKELL__ >= 708 +import qualified Data.Coerce as C (Coercible, coerce) #else -import Data.Semigroup (timesN) +import Unsafe.Coerce (unsafeCoerce) #endif -import Data.Text.Lazy (length, toStrict, unpack) -import Data.Text.Lazy.Builder (Builder, singleton, toLazyText) -import GHC.Exts (Char(C#), Int(I#)) -import GHC.Prim ((+#), chr#, ord#) - -import Prelude () -import Prelude.Compat hiding (length) +-- On GHC 7.8+, this is 'Data.Coerce.coerce'. Otherwise, it's 'unsafeCoerce'. +#if __GLASGOW_HASKELL__ >= 708 +coerce :: C.Coercible a b => a -> b +coerce = C.coerce +#else +coerce :: a -> b +coerce = unsafeCoerce +#endif -- | Unsafe conversion for decimal digits. i2d :: Int -> Char @@ -64,15 +74,6 @@ lengthB :: Builder -> Int64 lengthB = length . toLazyText {-# INLINE lengthB #-} - -#if !(MIN_VERSION_semigroups(0,17,0)) --- | Repeat a value @n@ times. --- --- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times -mtimesDefault :: (Integral b, Monoid a) => b -> a -> a -mtimesDefault = timesN . fromIntegral -{-# INLINE mtimesDefault #-} -#endif -- | Convert a 'Builder' to a 'String' (without surrounding it with double quotes, -- as 'show' would). diff --git a/tests/Derived/DataFamilies.hs b/tests/Derived/DataFamilies.hs --- a/tests/Derived/DataFamilies.hs +++ b/tests/Derived/DataFamilies.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -9,6 +10,10 @@ {-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -- Starting with GHC 7.10, NullaryTypeClasses was deprecated in favor of -- MultiParamTypeClasses, which is already enabled @@ -27,6 +32,9 @@ -} module Derived.DataFamilies ( NotAllShow(..) +#if __GLASGOW_HASKELL__ >= 706 + , KindDistinguished(..) +#endif #if __GLASGOW_HASKELL__ >= 708 , NullaryClass(..) , NullaryData(..) @@ -35,6 +43,8 @@ #include "generic.h" +import Data.Functor.Classes (Show1(..)) + #if !defined(__LANGUAGE_DERIVE_GENERIC1__) import qualified Generics.Deriving.TH as Generics #endif @@ -45,7 +55,6 @@ import GHC.Generics (Generic1) # endif #endif -import GHC.Show (appPrec, appPrec1, showSpace) import Prelude () import Prelude.Compat @@ -56,16 +65,14 @@ import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) #endif -import TransformersCompat (Show1(..), Show2(..)) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..)) +import GHC.Show (appPrec, appPrec1, showSpace) +#endif ------------------------------------------------------------------------------- -data family NotAllShow -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b c d :: * -#else - w x y z :: * -#endif +data family NotAllShow (w :: *) (x :: *) (y :: *) (z :: *) :: * data instance NotAllShow () () () d = NASNoShow data instance NotAllShow Int b c d = NASShow1 c b @@ -84,16 +91,21 @@ , NASShow2 <$> arbitrary ] +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance (Show b, Show c) => Show1 (NotAllShow Int b c) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +#else +instance (Show b, Show c) => Show1 (NotAllShow Int b c) where + liftShowsPrec = liftShowsPrec2 showsPrec showList instance Show b => Show2 (NotAllShow Int b) where - showsPrecWith2 sp1 _ p (NASShow1 c b) = showParen (p > appPrec) $ + liftShowsPrec2 sp1 _ _ _ p (NASShow1 c b) = showParen (p > appPrec) $ showString "NASShow1 " . sp1 appPrec1 c . showSpace . showsPrec appPrec1 b - showsPrecWith2 _ sp2 p (NASShow2 d) = showParen (p > appPrec) $ + liftShowsPrec2 _ _ sp2 _ p (NASShow2 d) = showParen (p > appPrec) $ showString "NASShow2 " . sp2 appPrec1 d +#endif #if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'NASShow1) @@ -107,6 +119,86 @@ # if __GLASGOW_HASKELL__ < 706 $(Generics.deriveRepresentable0 'NASShow1) +# endif +#endif + +------------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 706 +data family KindDistinguished (x :: k) (y :: *) (z :: *) :: * + +newtype instance KindDistinguished (a :: *) b c = KindDistinguished1 b + deriving ( Arbitrary + , Show + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif + ) + +newtype instance KindDistinguished (a :: * -> *) b c = KindDistinguished2 b + deriving ( Arbitrary + , Show + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif + ) + +newtype instance KindDistinguished Either b c = KindDistinguished3 b + deriving ( Arbitrary + , Show + , Generic +# if defined(__LANGUAGE_DERIVE_GENERIC1__) + , Generic1 +# endif + ) + +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) +instance Show b => Show1 (KindDistinguished (a :: *) b) where + showsPrec1 = showsPrec +instance Show b => Show1 (KindDistinguished (a :: * -> *) b) where + showsPrec1 = showsPrec +instance Show b => Show1 (KindDistinguished (Either :: * -> * -> *) b) where + showsPrec1 = showsPrec +#else +instance Show b => Show1 (KindDistinguished (a :: *) b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show b => Show1 (KindDistinguished (a :: * -> *) b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show b => Show1 (KindDistinguished (Either :: * -> * -> *) b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Show2 (KindDistinguished (a :: *)) where + liftShowsPrec2 sp1 _ _ _ p (KindDistinguished1 b) = showParen (p > appPrec) $ + showString "KindDistinguished1 " + . sp1 appPrec1 b +instance Show2 (KindDistinguished (a :: * -> *)) where + liftShowsPrec2 sp1 _ _ _ p (KindDistinguished2 b) = showParen (p > appPrec) $ + showString "KindDistinguished2 " + . sp1 appPrec1 b +instance Show2 (KindDistinguished (Either :: * -> * -> *)) where + liftShowsPrec2 sp1 _ _ _ p (KindDistinguished3 b) = showParen (p > appPrec) $ + showString "KindDistinguished3 " + . sp1 appPrec1 b +#endif + +$(deriveTextShow 'KindDistinguished1) +$(deriveTextShow1 'KindDistinguished1) +$(deriveTextShow2 'KindDistinguished1) + +$(deriveTextShow 'KindDistinguished2) +$(deriveTextShow1 'KindDistinguished2) +$(deriveTextShow2 'KindDistinguished2) + +$(deriveTextShow 'KindDistinguished3) +$(deriveTextShow1 'KindDistinguished3) +$(deriveTextShow2 'KindDistinguished3) + +# if !defined(__LANGUAGE_DERIVE_GENERIC1__) +$(Generics.deriveAll1 'KindDistinguished1) +$(Generics.deriveAll1 'KindDistinguished2) +$(Generics.deriveAll1 'KindDistinguished3) # endif #endif diff --git a/tests/Derived/DatatypeContexts.hs b/tests/Derived/DatatypeContexts.hs --- a/tests/Derived/DatatypeContexts.hs +++ b/tests/Derived/DatatypeContexts.hs @@ -16,7 +16,7 @@ -} module Derived.DatatypeContexts (TyCon(..), TyFamily(..)) where -import GHC.Show (appPrec, appPrec1, showSpace) +import Data.Functor.Classes (Show1(..)) import Prelude () import Prelude.Compat @@ -24,9 +24,12 @@ import Test.QuickCheck (Arbitrary(..)) import TextShow (TextShow(..), TextShow1(..), TextShow2(..)) -import TextShow.TH (makeShowbPrec, makeShowbPrecWith, makeShowbPrecWith2) +import TextShow.TH (makeShowbPrec, makeLiftShowbPrec, makeLiftShowbPrec2) -import TransformersCompat (Show1(..), Show2(..)) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..)) +import GHC.Show (appPrec, appPrec1, showSpace) +#endif ------------------------------------------------------------------------------- @@ -35,12 +38,7 @@ ------------------------------------------------------------------------------- -data family TyFamily -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b c :: * -#else - x y z :: * -#endif +data family TyFamily x y z :: * data instance Ord a => TyFamily a b c = TyFamily a b c deriving Show @@ -55,16 +53,22 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance (Ord a, Show a, Show b) => Show1 (TyCon a b) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where + showsPrec1 = showsPrec +#else +instance (Ord a, Show a, Show b) => Show1 (TyCon a b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + instance (Ord a, Show a) => Show2 (TyCon a) where - showsPrecWith2 sp1 sp2 p (TyCon a b c) = + liftShowsPrec2 sp1 _ sp2 _ p (TyCon a b c) = showsThree sp1 sp2 "TyCon" p a b c - -instance (Ord a, Show a, Show b) => Show1 (TyFamily a b) where - showsPrecWith = showsPrecWith2 showsPrec instance (Ord a, Show a) => Show2 (TyFamily a) where - showsPrecWith2 sp1 sp2 p (TyFamily a b c) = + liftShowsPrec2 sp1 _ sp2 _ p (TyFamily a b c) = showsThree sp1 sp2 "TyFamily" p a b c showsThree :: Show a @@ -75,6 +79,7 @@ . showsPrec appPrec1 a . showSpace . sp1 appPrec1 b . showSpace . sp2 appPrec1 c +#endif ------------------------------------------------------------------------------- @@ -83,15 +88,15 @@ 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 - showbPrecWith = $(makeShowbPrecWith ''TyCon) + liftShowbPrec = $(makeLiftShowbPrec ''TyCon) instance (Ord a, TextShow a) => TextShow2 (TyCon a) where - showbPrecWith2 = $(makeShowbPrecWith2 ''TyCon) + liftShowbPrec2 = $(makeLiftShowbPrec2 ''TyCon) #if MIN_VERSION_template_haskell(2,7,0) 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 - showbPrecWith = $(makeShowbPrecWith 'TyFamily) + liftShowbPrec = $(makeLiftShowbPrec 'TyFamily) instance (Ord a, TextShow a) => TextShow2 (TyFamily a) where - showbPrecWith2 = $(makeShowbPrecWith2 'TyFamily) + liftShowbPrec2 = $(makeLiftShowbPrec2 'TyFamily) #endif diff --git a/tests/Derived/ExistentialQuantification.hs b/tests/Derived/ExistentialQuantification.hs --- a/tests/Derived/ExistentialQuantification.hs +++ b/tests/Derived/ExistentialQuantification.hs @@ -17,7 +17,7 @@ -} module Derived.ExistentialQuantification (TyCon(..), TyFamily(..)) where -import GHC.Show (appPrec, appPrec1, showSpace) +import Data.Functor.Classes (Show1(..)) import Prelude () import Prelude.Compat @@ -27,7 +27,10 @@ import TextShow (TextShow) import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) -import TransformersCompat (Show1(..), Show2(..), showsBinaryWith) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..), showsBinaryWith) +import GHC.Show (appPrec, appPrec1, showSpace) +#endif ------------------------------------------------------------------------------- @@ -40,8 +43,9 @@ => e -> f -> g -> h -> TyCon e f g h - TyConTypeRefinement :: Int -> z - -> TyCon Int z Int z + TyConTypeRefinement1, + TyConTypeRefinement2 :: Int -> z + -> TyCon Int Int z z TyConForalls :: forall p q r s t u. (Arbitrary p, Show p, TextShow p, @@ -51,12 +55,7 @@ ------------------------------------------------------------------------------- -data family TyFamily -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b c d :: * -#else - w x y z :: * -#endif +data family TyFamily w x y z :: * data instance TyFamily a b c d where TyFamilyClassConstraints :: (Ord m, Ord n, Ord o, Ord p) @@ -67,8 +66,9 @@ => e -> f -> g -> h -> TyFamily e f g h - TyFamilyTypeRefinement :: Int -> z - -> TyFamily Int z Int z + TyFamilyTypeRefinement1, + TyFamilyTypeRefinement2 :: Int -> z + -> TyFamily Int Int z z TyFamilyForalls :: forall p q r s t u. (Arbitrary p, Show p, TextShow p, @@ -81,7 +81,8 @@ instance (a ~ Int, b ~ Int, c ~ Int, d ~ Int) => Arbitrary (TyCon a b c d) where arbitrary = oneof [ TyConClassConstraints <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary , TyConEqualityConstraints <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - , TyConTypeRefinement <$> arbitrary <*> arbitrary + , TyConTypeRefinement1 <$> arbitrary <*> arbitrary + , TyConTypeRefinement2 <$> arbitrary <*> arbitrary , TyConForalls <$> (arbitrary :: Gen Int) <*> (arbitrary :: Gen Int) <*> arbitrary <*> arbitrary ] @@ -89,7 +90,8 @@ instance (a ~ Int, b ~ Int, c ~ Int, d ~ Int) => Arbitrary (TyFamily a b c d) where arbitrary = oneof [ TyFamilyClassConstraints <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary , TyFamilyEqualityConstraints <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - , TyFamilyTypeRefinement <$> arbitrary <*> arbitrary + , TyFamilyTypeRefinement1 <$> arbitrary <*> arbitrary + , TyFamilyTypeRefinement2 <$> arbitrary <*> arbitrary , TyFamilyForalls <$> (arbitrary :: Gen Int) <*> (arbitrary :: Gen Int) <*> arbitrary <*> arbitrary ] @@ -97,29 +99,40 @@ ------------------------------------------------------------------------------- deriving instance (Show a, Show b, Show c, Show d) => Show (TyCon a b c d) +deriving instance (Show a, Show b, Show c, Show d) => Show (TyFamily a b c d) + +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance (Show a, Show b, Show c) => Show1 (TyCon a b c) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +instance (Show a, Show b, Show c) => Show1 (TyFamily a b c) where + showsPrec1 = showsPrec +#else +instance (Show a, Show b, Show c) => Show1 (TyCon a b c) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Show a, Show b, Show c) => Show1 (TyFamily a b c) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + instance (Show a, Show b) => Show2 (TyCon a b) where - showsPrecWith2 sp1 sp2 p (TyConClassConstraints a b c d) = + liftShowsPrec2 sp1 _ sp2 _ p (TyConClassConstraints a b c d) = showsFour sp1 sp2 "TyConClassConstraints" p a b c d - showsPrecWith2 sp1 sp2 p (TyConEqualityConstraints a b c d) = + liftShowsPrec2 sp1 _ sp2 _ p (TyConEqualityConstraints a b c d) = showsFour sp1 sp2 "TyConEqualityConstraints" p a b c d - showsPrecWith2 _ sp2 p (TyConTypeRefinement i d) = - showsBinaryWith showsPrec sp2 "TyConTypeRefinement" p i d - showsPrecWith2 sp1 sp2 p (TyConForalls p' q d c) = + liftShowsPrec2 _ _ sp2 _ p (TyConTypeRefinement1 i d) = + showsBinaryWith showsPrec sp2 "TyConTypeRefinement1" p i d + liftShowsPrec2 _ _ sp2 _ p (TyConTypeRefinement2 i d) = + showsBinaryWith showsPrec sp2 "TyConTypeRefinement2" p i d + liftShowsPrec2 sp1 _ sp2 _ p (TyConForalls p' q d c) = showsFour sp2 sp1 "TyConForalls" p p' q d c - -deriving instance (Show a, Show b, Show c, Show d) => Show (TyFamily a b c d) -instance (Show a, Show b, Show c) => Show1 (TyFamily a b c) where - showsPrecWith = showsPrecWith2 showsPrec instance (Show a, Show b) => Show2 (TyFamily a b) where - showsPrecWith2 sp1 sp2 p (TyFamilyClassConstraints a b c d) = + liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyClassConstraints a b c d) = showsFour sp1 sp2 "TyFamilyClassConstraints" p a b c d - showsPrecWith2 sp1 sp2 p (TyFamilyEqualityConstraints a b c d) = + liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyEqualityConstraints a b c d) = showsFour sp1 sp2 "TyFamilyEqualityConstraints" p a b c d - showsPrecWith2 _ sp2 p (TyFamilyTypeRefinement i d) = - showsBinaryWith showsPrec sp2 "TyFamilyTypeRefinement" p i d - showsPrecWith2 sp1 sp2 p (TyFamilyForalls p' q d c) = + 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) @@ -131,6 +144,7 @@ . showsPrec appPrec1 b . showSpace . sp1 appPrec1 c . showSpace . sp2 appPrec1 d +#endif ------------------------------------------------------------------------------- @@ -140,6 +154,6 @@ #if MIN_VERSION_template_haskell(2,7,0) $(deriveTextShow 'TyFamilyClassConstraints) -$(deriveTextShow1 'TyFamilyEqualityConstraints) -$(deriveTextShow2 'TyFamilyTypeRefinement) +$(deriveTextShow1 'TyFamilyTypeRefinement1) +$(deriveTextShow2 'TyFamilyTypeRefinement2) #endif diff --git a/tests/Derived/Infix.hs b/tests/Derived/Infix.hs --- a/tests/Derived/Infix.hs +++ b/tests/Derived/Infix.hs @@ -27,6 +27,8 @@ #include "generic.h" +import Data.Functor.Classes (Show1(..)) + #if !defined(__LANGUAGE_DERIVE_GENERIC1__) import qualified Generics.Deriving.TH as Generics #endif @@ -37,7 +39,6 @@ import GHC.Generics (Generic1) # endif #endif -import GHC.Show (appPrec, appPrec1, showSpace) import Prelude () import Prelude.Compat @@ -46,16 +47,21 @@ import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) -import TransformersCompat (Show1(..), Show2(..), showsBinaryWith) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..), showsBinaryWith) +import GHC.Show (appPrec, appPrec1, showSpace) +#endif ------------------------------------------------------------------------------- infixl 3 :!: infix 4 :@: infixr 5 `TyConPlain` +infixr 6 `TyConFakeInfix` data TyConPlain a b = (:!:) a b | a :@: b | a `TyConPlain` b + | TyConFakeInfix a b deriving ( Show #if __GLASGOW_HASKELL__ >= 702 , Generic @@ -82,19 +88,16 @@ ------------------------------------------------------------------------------- -data family TyFamilyPlain -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b :: * -#else - y z :: * -#endif +data family TyFamilyPlain y z :: * infixl 3 :#: infix 4 :$: infixr 5 `TyFamilyPlain` +infixr 6 `TyFamilyFakeInfix` data instance TyFamilyPlain a b = (:#:) a b | a :$: b | a `TyFamilyPlain` b + | TyFamilyFakeInfix a b deriving ( Show #if __GLASGOW_HASKELL__ >= 706 , Generic @@ -106,12 +109,7 @@ ------------------------------------------------------------------------------- -data family TyFamilyGADT -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b :: * -#else - y z :: * -#endif +data family TyFamilyGADT y z :: * infixr 1 :*, :***, :**** data instance TyFamilyGADT a b where @@ -154,48 +152,60 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance Show a => Show1 (TyConPlain a) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +instance Show a => Show1 (TyConGADT a) where + showsPrec1 = showsPrec +instance Show a => Show1 (TyFamilyPlain a) where + showsPrec1 = showsPrec +instance Show a => Show1 (TyFamilyGADT a) where + showsPrec1 = showsPrec +#else +instance Show a => Show1 (TyConPlain a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyConGADT a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyFamilyPlain a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyFamilyGADT a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + instance Show2 TyConPlain where - showsPrecWith2 sp1 sp2 p (a :!: b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :!: b) = showsBinaryWith sp1 sp2 "(:!:)" p a b - showsPrecWith2 sp1 sp2 p (a :@: b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :@: b) = showsInfix sp1 sp2 ":@:" p 4 a b - showsPrecWith2 sp1 sp2 p (TyConPlain a b) = + liftShowsPrec2 sp1 _ sp2 _ p (TyConPlain a b) = showsInfix sp1 sp2 "`TyConPlain`" p 5 a b - -instance Show a => Show1 (TyConGADT a) where - showsPrecWith = showsPrecWith2 showsPrec + liftShowsPrec2 sp1 _ sp2 _ p (TyConFakeInfix a b) = + showsBinaryWith sp1 sp2 "TyConFakeInfix" p a b instance Show2 TyConGADT where - showsPrecWith2 sp1 sp2 p (a :. b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :. b) = showsInfix sp1 sp2 ":." p 1 a b - showsPrecWith2 sp1 sp2 p (a :.. b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :.. b) = showsBinaryWith sp1 sp2 "(:..)" p a b - showsPrecWith2 sp1 sp2 p ((:...) a b i) = + liftShowsPrec2 sp1 _ sp2 _ p ((:...) a b i) = showsTernaryWith sp1 sp2 "(:...)" p a b i - showsPrecWith2 sp1 sp2 p (a :.... b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :.... b) = showsBinaryWith sp1 sp2 "(:....)" p a b - -instance Show a => Show1 (TyFamilyPlain a) where - showsPrecWith = showsPrecWith2 showsPrec instance Show2 TyFamilyPlain where - showsPrecWith2 sp1 sp2 p (a :#: b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :#: b) = showsBinaryWith sp1 sp2 "(:#:)" p a b - showsPrecWith2 sp1 sp2 p (a :$: b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :$: b) = showsInfix sp1 sp2 ":$:" p 4 a b - showsPrecWith2 sp1 sp2 p (TyFamilyPlain a b) = + liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyPlain a b) = showsInfix sp1 sp2 "`TyFamilyPlain`" p 5 a b - -instance Show a => Show1 (TyFamilyGADT a) where - showsPrecWith = showsPrecWith2 showsPrec + liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyFakeInfix a b) = + showsBinaryWith sp1 sp2 "TyFamilyFakeInfix" p a b instance Show2 TyFamilyGADT where - showsPrecWith2 sp1 sp2 p (a :* b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :* b) = showsInfix sp1 sp2 ":*" p 1 a b - showsPrecWith2 sp1 sp2 p (a :** b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :** b) = showsBinaryWith sp1 sp2 "(:**)" p a b - showsPrecWith2 sp1 sp2 p ((:***) a b i) = + liftShowsPrec2 sp1 _ sp2 _ p ((:***) a b i) = showsTernaryWith sp1 sp2 "(:***)" p a b i - showsPrecWith2 sp1 sp2 p (a :**** b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :**** b) = showsBinaryWith sp1 sp2 "(:****)" p a b showsInfix :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) @@ -212,6 +222,7 @@ . sp1 appPrec1 a . showSpace . sp2 appPrec1 b . showSpace . showsPrec appPrec1 i +#endif ------------------------------------------------------------------------------- diff --git a/tests/Derived/MagicHash.hs b/tests/Derived/MagicHash.hs --- a/tests/Derived/MagicHash.hs +++ b/tests/Derived/MagicHash.hs @@ -19,6 +19,8 @@ -} module Derived.MagicHash (TyCon#(..), TyFamily#(..)) where +import Data.Functor.Classes (Show1(..)) + #if __GLASGOW_HASKELL__ < 711 import qualified Generics.Deriving.TH as Generics #endif @@ -27,10 +29,6 @@ #if __GLASGOW_HASKELL__ >= 711 import GHC.Generics (Generic, Generic1) #endif -import GHC.Show (showSpace) -#if __GLASGOW_HASKELL__ < 711 -import GHC.Show (appPrec) -#endif import Prelude () import Prelude.Compat @@ -39,7 +37,13 @@ import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) -import TransformersCompat (Show1(..), Show2(..)) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..)) +import GHC.Show (showSpace) +# if __GLASGOW_HASKELL__ < 711 +import GHC.Show (appPrec) +# endif +#endif ------------------------------------------------------------------------------- @@ -60,12 +64,7 @@ ------------------------------------------------------------------------------- -data family TyFamily# -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b :: * -#else - y z :: * -#endif +data family TyFamily# y z :: * data instance TyFamily# a b = TyFamily# { tfA :: a @@ -108,17 +107,23 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance Show a => Show1 (TyCon# a) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +instance Show a => Show1 (TyFamily# a) where + showsPrec1 = showsPrec +#else +instance Show a => Show1 (TyCon# a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyFamily# a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + instance Show2 TyCon# where - showsPrecWith2 sp1 sp2 p (TyCon# a b i f d c w) = + liftShowsPrec2 sp1 _ sp2 _ p (TyCon# a b i f d c w) = showsHash sp1 sp2 "TyCon#" "tcA" "tcB" "tcInt#" "tcFloat#" "tcDouble#" "tcChar#" "tcWord#" p a b i f d c w - -instance Show a => Show1 (TyFamily# a) where - showsPrecWith = showsPrecWith2 showsPrec instance Show2 TyFamily# where - showsPrecWith2 sp1 sp2 p (TyFamily# a b i f d c w) = + 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 @@ -127,9 +132,9 @@ -> 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 = -#if __GLASGOW_HASKELL__ < 711 +# if __GLASGOW_HASKELL__ < 711 showParen (_p > appPrec) $ -#endif +# endif showString con . showSpace . showChar '{' . showString rec1 . equals . sp1 0 a . comma @@ -146,12 +151,13 @@ equals = showString " = " oneHash, twoHash :: ShowS -#if __GLASGOW_HASKELL__ >= 711 +# if __GLASGOW_HASKELL__ >= 711 oneHash = showChar '#' twoHash = showString "##" -#else +# else oneHash = id twoHash = id +# endif #endif ------------------------------------------------------------------------------- diff --git a/tests/Derived/PolyKinds.hs b/tests/Derived/PolyKinds.hs --- a/tests/Derived/PolyKinds.hs +++ b/tests/Derived/PolyKinds.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} @@ -12,9 +13,12 @@ #endif #if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module: Derived.PolyKinds Copyright: (C) 2014-2015 Ryan Scott @@ -36,20 +40,25 @@ #include "generic.h" +import Data.Functor.Classes (Show1(..)) + import Generics.Deriving.Base -#if !defined(__LANGUAGE_DERIVE_GENERIC1__) +#if !defined(__LANGUAGE_DERIVE_GENERIC1__) || MIN_VERSION_template_haskell(2,7,0) import qualified Generics.Deriving.TH as Generics #endif -import GHC.Show (appPrec, appPrec1, showSpace) - import Test.QuickCheck (Arbitrary) import TextShow (TextShow(..), TextShow1(..), TextShow2(..)) import TextShow.TH (deriveTextShow2, makeShowbPrec, - makeShowbPrecWith, makeShowbPrecWith2) + makeLiftShowbPrec, makeLiftShowbPrec2) -import TransformersCompat (Show1(..), Show2(..), showsUnaryWith) +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) +import Data.Functor.Classes (showsUnary1) +#else +import Data.Functor.Classes (Show2(..), showsUnaryWith) +import GHC.Show (appPrec, appPrec1, showSpace) +#endif ------------------------------------------------------------------------------- @@ -73,7 +82,8 @@ ------------------------------------------------------------------------------- -newtype TyConProxy a b = TyConProxy () +newtype TyConProxy a b where + TyConProxy :: () -> TyConProxy a b deriving ( Arbitrary , Show #if __GLASGOW_HASKELL__ >= 702 @@ -100,15 +110,7 @@ ------------------------------------------------------------------------------- data family TyFamilyCompose -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - (f :: k1 -> k2 -> *) - (g :: k3 -> k4 -> k1) - (h :: k3 -> k4 -> k2) - (j :: k5 -> k3) - (k :: k5 -> k4) - (a :: k5) - (b :: k5) -#elif __GLASGOW_HASKELL__ >= 706 +#if __GLASGOW_HASKELL__ >= 706 (t :: k1 -> k2 -> *) (u :: k3 -> k4 -> k1) (v :: k3 -> k4 -> k2) @@ -136,49 +138,32 @@ deriving instance Arbitrary (f (g (j a) (k a)) (h (j a) (k b))) => Arbitrary (TyFamilyCompose f g h j k a b) -#if defined(__LANGUAGE_DERIVE_GENERIC1__) -deriving instance ( Functor (f (g (j a) (k a))) - , Functor (h (j a)) - ) => Generic1 (TyFamilyCompose f g h j k a) -#endif - deriving instance Show (f (g (j a) (k a)) (h (j a) (k b))) => Show (TyFamilyCompose f g h j k a b) ------------------------------------------------------------------------------- data family TyFamilyProxy -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - (a :: k1) (b :: k2) -#elif __GLASGOW_HASKELL__ >= 706 +#if __GLASGOW_HASKELL__ >= 706 (x :: k1) (y :: k2) #else (x :: *) (y :: *) #endif :: * -newtype instance TyFamilyProxy a b = TyFamilyProxy () +newtype instance TyFamilyProxy a b where + TyFamilyProxy :: () -> TyFamilyProxy a b deriving ( Arbitrary , Show #if __GLASGOW_HASKELL__ >= 706 , Generic -# if defined(__LANGUAGE_DERIVE_GENERIC1__) - , Generic1 -# endif #endif ) ------------------------------------------------------------------------------- data family TyFamilyReallyHighKinds -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - (f :: k1 -> k2 -> k3 -> k4 -> k5 -> *) - (a :: k1) - (b :: k2) - (c :: k3) - (d :: k4) - (e :: k5) -#elif __GLASGOW_HASKELL__ >= 706 +#if __GLASGOW_HASKELL__ >= 706 (g :: k1 -> k2 -> k3 -> k4 -> k5 -> *) (v :: k1) (w :: k2) @@ -201,76 +186,132 @@ , Show #if __GLASGOW_HASKELL__ >= 706 , Generic -# if defined(__LANGUAGE_DERIVE_GENERIC1__) - , Generic1 -# endif #endif ) ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) +-- | Kludge to get type with the same instances as @g a@ +newtype Apply g a = Apply (g a) + +instance (Show1 g, Show a) => Show (Apply g a) where + showsPrec d (Apply x) = showsPrec1 d x + +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 (TyConCompose f g h j k a) where + showsPrec1 p (TyConCompose x) = + showsUnary1 "TyConCompose" p $ fmap (Apply . fmap Apply) x +instance Show1 (TyConProxy (a :: *)) where + showsPrec1 = showsPrec +instance Show1 (f a b c d) => Show1 (TyConReallyHighKinds f a b c d) where + showsPrec1 p (TyConReallyHighKinds x) = + showsUnary1 "TyConReallyHighKinds" p x +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 + showsPrec1 p (TyFamilyCompose x) = + showsUnary1 "TyFamilyCompose" p $ fmap (Apply . fmap Apply) x +instance Show1 (TyFamilyProxy (a :: *)) where + showsPrec1 = showsPrec +instance Show1 (f a b c d) => Show1 (TyFamilyReallyHighKinds f a b c d) where + showsPrec1 p (TyFamilyReallyHighKinds x) = + showsUnary1 "TyFamilyReallyHighKinds" p x + +-- TODO: Move this to base-orphans someday +instance (Show a, Show b, Show c, Show d) => Show1 ((,,,,) a b c d) where + showsPrec1 = showsPrec +#else instance (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) => Show1 (TyConCompose f g h j k a) where - showsPrecWith sp p (TyConCompose x) = - showsPrecCompose sp "TyConCompose" p x + liftShowsPrec sp sl p (TyConCompose x) = + showsPrecCompose sp sl "TyConCompose" p x +instance Show1 (TyConProxy (a :: *)) where + liftShowsPrec = liftShowsPrec2 undefined undefined +instance Show1 (f a b c d) => Show1 (TyConReallyHighKinds f a b c d) where + liftShowsPrec sp sl p (TyConReallyHighKinds x) = + showsUnaryWith (liftShowsPrec sp sl) "TyConReallyHighKinds" p x +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 (TyConCompose f g h j k) where - showsPrecWith2 sp1 sp2 p (TyConCompose x) = - showsPrecCompose2 sp1 sp2 "TyConCompose" p x - -instance Show1 (TyConProxy (a :: *)) where - showsPrecWith = showsPrecWith2 undefined + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyConCompose x) = + showsPrecCompose2 sp1 sl1 sp2 sl2 "TyConCompose" p x instance Show2 TyConProxy where - showsPrecWith2 _ _ p (TyConProxy x) = showParen (p > appPrec) $ + liftShowsPrec2 _ _ _ _ p (TyConProxy x) = showParen (p > appPrec) $ showString "TyConProxy " . showsPrec appPrec1 x - -instance Show1 (f a b c d) => Show1 (TyConReallyHighKinds f a b c d) where - showsPrecWith sp p (TyConReallyHighKinds x) = - showsUnaryWith (showsPrecWith sp) "TyConReallyHighKinds" p x instance Show2 (f a b c) => Show2 (TyConReallyHighKinds f a b c) where - showsPrecWith2 sp1 sp2 p (TyConReallyHighKinds x) = - showsUnaryWith (showsPrecWith2 sp1 sp2) "TyConReallyHighKinds" p x - -instance (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) => - Show1 (TyFamilyCompose f g h j k a) where - showsPrecWith sp p (TyFamilyCompose x) = - showsPrecCompose sp "TyFamilyCompose" p x + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyConReallyHighKinds x) = + showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "TyConReallyHighKinds" p x instance (Show2 f, Show2 g, Show2 h, Show1 j, Show1 k) => Show2 (TyFamilyCompose f g h j k) where - showsPrecWith2 sp1 sp2 p (TyFamilyCompose x) = - showsPrecCompose2 sp1 sp2 "TyFamilyCompose" p x - -instance Show1 (TyFamilyProxy (a :: *)) where - showsPrecWith = showsPrecWith2 undefined + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamilyCompose x) = + showsPrecCompose2 sp1 sl1 sp2 sl2 "TyFamilyCompose" p x instance Show2 TyFamilyProxy where - showsPrecWith2 _ _ p (TyFamilyProxy x) = showParen (p > appPrec) $ + liftShowsPrec2 _ _ _ _ p (TyFamilyProxy x) = showParen (p > appPrec) $ showString "TyFamilyProxy " . showsPrec appPrec1 x - -instance Show1 (f a b c d) => Show1 (TyFamilyReallyHighKinds f a b c d) where - showsPrecWith sp p (TyFamilyReallyHighKinds x) = - showsUnaryWith (showsPrecWith sp) "TyFamilyReallyHighKinds" p x instance Show2 (f a b c) => Show2 (TyFamilyReallyHighKinds f a b c) where - showsPrecWith2 sp1 sp2 p (TyFamilyReallyHighKinds x) = - showsUnaryWith (showsPrecWith2 sp1 sp2) "TyFamilyReallyHighKinds" p x + 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) -> String - -> Int -> f (g (j a) (k a)) (h (j a) (k b)) -> ShowS -showsPrecCompose sp name p x = showParen (p > appPrec) $ + => (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 - . showsPrecWith (showsPrecWith (showsPrecWith sp)) appPrec1 x + . 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) -> (Int -> b -> ShowS) + => (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 sp2 name p x = showParen (p > appPrec) $ +showsPrecCompose2 sp1 sl1 sp2 sl2 name p x = showParen (p > appPrec) $ showString name . showSpace - . showsPrecWith2 (showsPrecWith2 (showsPrecWith sp1) (showsPrecWith sp1)) - (showsPrecWith2 (showsPrecWith sp1) (showsPrecWith sp2)) + . 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 +-- TODO: Move these to base-orphans someday +instance (Show a, Show b, Show c, Show d) => Show1 ((,,,,) a b c d) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance (Show a, Show b, Show c) => Show2 ((,,,,) a b c) where + liftShowsPrec2 sp1 _ sp2 _ _ (a, b, c, d, e) = + showChar '(' . shows a . showChar ',' + . shows b . showChar ',' + . shows c . showChar ',' + . sp1 0 d . showChar ',' + . sp2 0 e . showChar ')' +#endif + ------------------------------------------------------------------------------- $(return []) @@ -280,21 +321,21 @@ showbPrec = $(makeShowbPrec ''TyConCompose) instance (TextShow1 (f (g (j a) (k a))), TextShow1 (h (j a)), TextShow1 k) => TextShow1 (TyConCompose f g h j k a) where - showbPrecWith = $(makeShowbPrecWith ''TyConCompose) + liftShowbPrec = $(makeLiftShowbPrec ''TyConCompose) $(deriveTextShow2 ''TyConCompose) instance TextShow (TyConProxy a b) where showbPrec = $(makeShowbPrec ''TyConProxy) instance TextShow1 (TyConProxy a) where - showbPrecWith = $(makeShowbPrecWith ''TyConProxy) + liftShowbPrec = $(makeLiftShowbPrec ''TyConProxy) $(deriveTextShow2 ''TyConProxy) instance TextShow (f a b c d e) => TextShow (TyConReallyHighKinds f a b c d e) where showbPrec = $(makeShowbPrec ''TyConReallyHighKinds) instance TextShow1 (f a b c d) => TextShow1 (TyConReallyHighKinds f a b c d) where - showbPrecWith = $(makeShowbPrecWith ''TyConReallyHighKinds) + liftShowbPrec = $(makeLiftShowbPrec ''TyConReallyHighKinds) instance TextShow2 (f a b c) => TextShow2 (TyConReallyHighKinds f a b c) where - showbPrecWith2 = $(makeShowbPrecWith2 ''TyConReallyHighKinds) + liftShowbPrec2 = $(makeLiftShowbPrec2 ''TyConReallyHighKinds) #if MIN_VERSION_template_haskell(2,7,0) instance TextShow (f (g (j a) (k a)) (h (j a) (k b))) => @@ -302,21 +343,21 @@ showbPrec = $(makeShowbPrec 'TyFamilyCompose) instance (TextShow1 (f (g (j a) (k a))), TextShow1 (h (j a)), TextShow1 k) => TextShow1 (TyFamilyCompose f g h j k a) where - showbPrecWith = $(makeShowbPrecWith 'TyFamilyCompose) + liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyCompose) $(deriveTextShow2 'TyFamilyCompose) instance TextShow (TyFamilyProxy a b) where showbPrec = $(makeShowbPrec 'TyFamilyProxy) instance TextShow1 (TyFamilyProxy a) where - showbPrecWith = $(makeShowbPrecWith 'TyFamilyProxy) + liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyProxy) $(deriveTextShow2 'TyFamilyProxy) instance TextShow (f a b c d e) => TextShow (TyFamilyReallyHighKinds f a b c d e) where showbPrec = $(makeShowbPrec 'TyFamilyReallyHighKinds) instance TextShow1 (f a b c d) => TextShow1 (TyFamilyReallyHighKinds f a b c d) where - showbPrecWith = $(makeShowbPrecWith 'TyFamilyReallyHighKinds) + liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyReallyHighKinds) instance TextShow2 (f a b c) => TextShow2 (TyFamilyReallyHighKinds f a b c) where - showbPrecWith2 = $(makeShowbPrecWith2 'TyFamilyReallyHighKinds) + liftShowbPrec2 = $(makeLiftShowbPrec2 'TyFamilyReallyHighKinds) #endif #if !defined(__LANGUAGE_DERIVE_GENERIC1__) @@ -343,7 +384,7 @@ #endif #if MIN_VERSION_template_haskell(2,7,0) -# if !defined(__LANGUAGE_DERIVE_GENERIC1__) +-- TODO: Reinstate CPP bounds once Trac #11357 is fixed $(Generics.deriveMeta 'TyFamilyCompose) $(Generics.deriveRep1 'TyFamilyCompose) @@ -358,7 +399,6 @@ $(Generics.deriveRepresentable1 'TyFamilyProxy) $(Generics.deriveMeta 'TyFamilyReallyHighKinds) $(Generics.deriveRepresentable1 'TyFamilyReallyHighKinds) -# endif # if __GLASGOW_HASKELL__ < 706 $(Generics.deriveRepresentable0 'TyFamilyCompose) diff --git a/tests/Derived/RankNTypes.hs b/tests/Derived/RankNTypes.hs --- a/tests/Derived/RankNTypes.hs +++ b/tests/Derived/RankNTypes.hs @@ -20,16 +20,20 @@ -} module Derived.RankNTypes (TyCon(..), TyFamily(..)) where +import Data.Functor.Classes (Show1(..)) + import Prelude () import Prelude.Compat import Test.QuickCheck (Arbitrary(..)) -import TextShow (Show(..), Show1(..), Show2(..)) +import TextShow (TextShow(..), TextShow1(..), TextShow2(..)) import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2, - makeShowbPrec, makeShowbPrecWith, makeShowbPrecWith2) + makeShowbPrec, makeLiftShowbPrec, makeLiftShowbPrec2) -import TransformersCompat (Show1(..), Show2(..), showsUnaryWith, showsBinaryWith) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..), showsUnaryWith, showsBinaryWith) +#endif ------------------------------------------------------------------------------- @@ -40,12 +44,7 @@ ------------------------------------------------------------------------------- -data family TyFamily -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b :: * -#else - x y :: * -#endif +data family TyFamily x y :: * data instance TyFamily a b = TyFamily (forall a. Tagged2 a Int b) (forall b. Tagged2 b a a) @@ -75,55 +74,61 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance Show a => Show1 (TyCon a) where - showsPrecWith = showsPrecWith2 showsPrec -instance Show2 TyCon where - showsPrecWith2 sp1 sp2 p (TyCon b a) = - showsForall sp1 sp2 "TyCon" p b a - + showsPrec1 = showsPrec instance Show a => Show1 (TyFamily a) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +#else +instance Show1 (Tagged2 s t) where + liftShowsPrec = liftShowsPrec2 undefined undefined +instance Show a => Show1 (TyCon a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyFamily a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Show2 (Tagged2 s) where + liftShowsPrec2 _ _ sp _ p (Tagged2 b) = showsUnaryWith sp "Tagged2" p b +instance Show2 TyCon where + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyCon b a) = + showsForall sp1 sl1 sp2 sl2 "TyCon" p b a instance Show2 TyFamily where - showsPrecWith2 sp1 sp2 p (TyFamily b a) = - showsForall sp1 sp2 "TyFamily" p b a + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamily b a) = + showsForall sp1 sl1 sp2 sl2 "TyFamily" p b a -showsForall :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) +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 sp2 name p b a = - showsBinaryWith (showsPrecWith2 showsPrec sp2) - (showsPrecWith2 sp1 sp1) +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 ------------------------------------------------------------------------------- -$(deriveShow ''TyCon) -$(deriveShow1 ''TyCon) -$(deriveShow2 ''TyCon) +$(deriveTextShow ''TyCon) +$(deriveTextShow1 ''TyCon) +$(deriveTextShow2 ''TyCon) #if MIN_VERSION_template_haskell(2,7,0) -$(deriveShow 'TyFamily) -$(deriveShow1 'TyFamily) -$(deriveShow2 'TyFamily) +$(deriveTextShow 'TyFamily) +$(deriveTextShow1 'TyFamily) +$(deriveTextShow2 'TyFamily) #endif ------------------------------------------------------------------------------- $(return []) -instance TextShow1 (Tagged2 s t) where - showsPrecWith sp p (Tagged2 b) = showsUnaryWith sp "Tagged2" p b - -instance TextShow2 (Tagged2 s) where - showsPrecWith2 _ = showsPrecWith - instance TextShow c => TextShow (Tagged2 s t c) where showbPrec = $(makeShowbPrec ''Tagged2) instance TextShow1 (Tagged2 s t) where - showbPrecWith = $(makeShowbPrecWith ''Tagged2) + liftShowbPrec = $(makeLiftShowbPrec ''Tagged2) instance TextShow2 (Tagged2 s) where - showbPrecWith2 = $(makeShowbPrecWith2 ''Tagged2) + liftShowbPrec2 = $(makeLiftShowbPrec2 ''Tagged2) diff --git a/tests/Derived/Records.hs b/tests/Derived/Records.hs --- a/tests/Derived/Records.hs +++ b/tests/Derived/Records.hs @@ -20,6 +20,8 @@ #include "generic.h" +import Data.Functor.Classes (Show1(..)) + #if !defined(__LANGUAGE_DERIVE_GENERIC1__) import qualified Generics.Deriving.TH as Generics #endif @@ -30,10 +32,6 @@ import GHC.Generics (Generic1) # endif #endif -import GHC.Show (showSpace) -#if __GLASGOW_HASKELL__ < 711 -import GHC.Show (appPrec) -#endif import Prelude () import Prelude.Compat @@ -42,7 +40,13 @@ import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) -import TransformersCompat (Show1(..), Show2(..)) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2(..)) +import GHC.Show (showSpace) +# if __GLASGOW_HASKELL__ < 711 +import GHC.Show (appPrec) +# endif +#endif ------------------------------------------------------------------------------- @@ -60,12 +64,7 @@ ------------------------------------------------------------------------------- -data family TyFamily -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b :: * -#else - y z :: * -#endif +data family TyFamily y z :: * infixl 4 :!: data instance TyFamily a b = TyFamilyPrefix { tf1 :: a, tf2 :: b } @@ -93,33 +92,40 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance Show a => Show1 (TyCon a) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +instance Show a => Show1 (TyFamily a) where + showsPrec1 = showsPrec +#else +instance Show a => Show1 (TyCon a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyFamily a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + instance Show2 TyCon where - showsPrecWith2 sp1 sp2 p (TyConPrefix a b) = + liftShowsPrec2 sp1 _ sp2 _ p (TyConPrefix a b) = showsRecord sp1 sp2 "TyConPrefix" "tc1" "tc2" p a b - showsPrecWith2 sp1 sp2 p (a :@: b) = + liftShowsPrec2 sp1 _ sp2 _ p (a :@: b) = showsRecord sp2 sp1 "(:@:)" "tc3" "tc4" p a b - -instance Show a => Show1 (TyFamily a) where - showsPrecWith = showsPrecWith2 showsPrec instance Show2 TyFamily where - showsPrecWith2 sp1 sp2 p (TyFamilyPrefix a b) = + liftShowsPrec2 sp1 _ sp2 _ p (TyFamilyPrefix a b) = showsRecord sp1 sp2 "TyFamilyPrefix" "tf1" "tf2" p a b - showsPrecWith2 sp1 sp2 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 = -#if __GLASGOW_HASKELL__ < 711 +# if __GLASGOW_HASKELL__ < 711 showParen (_p > appPrec) $ -#endif +# endif showString con . showSpace . showChar '{' . showString rec1 . showString " = " . sp1 0 a . showString ", " . showString rec2 . showString " = " . sp2 0 b . showChar '}' +#endif ------------------------------------------------------------------------------- diff --git a/tests/Derived/TypeSynonyms.hs b/tests/Derived/TypeSynonyms.hs --- a/tests/Derived/TypeSynonyms.hs +++ b/tests/Derived/TypeSynonyms.hs @@ -23,6 +23,13 @@ #include "generic.h" +import Data.Functor.Classes ( Show1(..) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) + , Show2(..) + , showsUnaryWith +#endif + ) + #if !defined(__LANGUAGE_DERIVE_GENERIC1__) import qualified Generics.Deriving.TH as Generics #endif @@ -40,8 +47,6 @@ import TextShow.TH (deriveTextShow, deriveTextShow1, deriveTextShow2) -import TransformersCompat (Show1(..), Show2(..), showsUnaryWith) - ------------------------------------------------------------------------------- type FakeOut a = Int @@ -52,13 +57,15 @@ instance Functor ((,,,) a b c) where fmap f (a, b, c, d) = (a, b, c, f d) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) instance (Show a, Show b) => Show2 ((,,,) a b) where - showsPrecWith2 sp1 sp2 _ (a, b, c, d) = + liftShowsPrec2 sp1 _ sp2 _ _ (a, b, c, d) = showChar '(' . showsPrec 0 a . showChar ',' . showsPrec 0 b . showChar ',' . sp1 0 c . showChar ',' . sp2 0 d . showChar ')' +#endif ------------------------------------------------------------------------------- @@ -80,12 +87,7 @@ ------------------------------------------------------------------------------- -data family TyFamily -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - a b :: * -#else - y z :: * -#endif +data family TyFamily y z :: * newtype instance TyFamily a b = TyFamily ( Id (FakeOut (Id a)) @@ -105,21 +107,32 @@ ------------------------------------------------------------------------------- +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) instance Show a => Show1 (TyCon a) where - showsPrecWith = showsPrecWith2 showsPrec + showsPrec1 = showsPrec +instance Show a => Show1 (TyFamily a) where + showsPrec1 = showsPrec +#else +instance Show a => Show1 (TyCon a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList +instance Show a => Show1 (TyFamily a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + instance Show2 TyCon where - showsPrecWith2 sp1 sp2 p (TyCon x) = - showsUnaryWith (showsPrecWith2 (showsPrecWith2 showsPrec sp1) - (showsPrecWith2 sp1 sp2) + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyCon x) = + showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 showsPrec showList sp1 sl1) + (liftShowList2 showsPrec showList sp1 sl1) + (liftShowsPrec2 sp1 sl1 sp2 sl2) + (liftShowList2 sp1 sl1 sp2 sl2) ) "TyCon" p x - -instance Show a => Show1 (TyFamily a) where - showsPrecWith = showsPrecWith2 showsPrec instance Show2 TyFamily where - showsPrecWith2 sp1 sp2 p (TyFamily x) = - showsUnaryWith (showsPrecWith2 (showsPrecWith2 showsPrec sp1) - (showsPrecWith2 sp1 sp2) + liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamily x) = + showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 showsPrec showList sp1 sl1) + (liftShowList2 showsPrec showList sp1 sl1) + (liftShowsPrec2 sp1 sl1 sp2 sl2) + (liftShowList2 sp1 sl1 sp2 sl2) ) "TyFamily" p x +#endif ------------------------------------------------------------------------------- diff --git a/tests/Instances/Control/Exception.hs b/tests/Instances/Control/Exception.hs --- a/tests/Instances/Control/Exception.hs +++ b/tests/Instances/Control/Exception.hs @@ -79,6 +79,11 @@ arbitrary = pure AllocationLimitExceeded #endif +#if MIN_VERSION_base(4,9,0) +instance Arbitrary TypeError where + arbitrary = TypeError <$> arbitrary +#endif + instance Arbitrary Deadlock where arbitrary = pure Deadlock diff --git a/tests/Instances/Data/Functor/Compose.hs b/tests/Instances/Data/Functor/Compose.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Functor/Compose.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +{-| +Module: Instances.Data.Functor.Compose +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Arbitrary' instance for 'Compose'. +-} +module Instances.Data.Functor.Compose () where + +import Data.Functor.Compose (Compose(..)) +import Test.QuickCheck (Arbitrary) + +deriving instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) diff --git a/tests/Instances/Data/Functor/Product.hs b/tests/Instances/Data/Functor/Product.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Functor/Product.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +{-| +Module: Instances.Data.Functor.Product +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Arbitrary' instance for 'Product'. +-} +module Instances.Data.Functor.Product () where + +import Data.Functor.Product (Product(..)) + +import Prelude () +import Prelude.Compat + +import Test.QuickCheck (Arbitrary(..)) + +instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Product f g a) where + arbitrary = Pair <$> arbitrary <*> arbitrary diff --git a/tests/Instances/Data/Functor/Sum.hs b/tests/Instances/Data/Functor/Sum.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Functor/Sum.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +{-| +Module: Instances.Data.Functor.Sum +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Arbitrary' instance for 'Sum'. +-} +module Instances.Data.Functor.Sum () where + +import Data.Functor.Sum (Sum(..)) + +import Prelude () +import Prelude.Compat + +import Test.QuickCheck (Arbitrary(..), oneof) + +instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Sum f g a) where + arbitrary = oneof [InL <$> arbitrary, InR <$> arbitrary] diff --git a/tests/Instances/Data/List/NonEmpty.hs b/tests/Instances/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/List/NonEmpty.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: Instances.Data.List.NonEmpty +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Arbitrary' instance for 'NonEmpty'. +-} +module Instances.Data.List.NonEmpty () where + +import Data.Functor.Classes (Show1(..)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Prelude () +import Prelude.Compat + +import Test.QuickCheck (Arbitrary(..)) + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + +#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) +instance Show1 NonEmpty where + showsPrec1 = showsPrec +#else +instance Show1 NonEmpty where + liftShowsPrec sp sl p (h :| t) = showParen (p > infixPrec) $ + sp (infixPrec+1) h . showString " :| " . liftShowsPrec sp sl (infixPrec+1) t + where + infixPrec :: Int + infixPrec = 5 +#endif diff --git a/tests/Instances/Data/Semigroup.hs b/tests/Instances/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Semigroup.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Module: Instances.Data.Semigroup +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +'Arbitrary' instances for datatypes in the "Data.Semigroup" module. +-} +module Instances.Data.Semigroup () where + +import Data.Semigroup (Min(..), Max(..), First(..), Last(..), + WrappedMonoid(..), Option(..), Arg(..)) + +import Prelude () +import Prelude.Compat + +import Test.QuickCheck (Arbitrary(..)) + +deriving instance Arbitrary a => Arbitrary (Min a) +deriving instance Arbitrary a => Arbitrary (Max a) +deriving instance Arbitrary a => Arbitrary (First a) +deriving instance Arbitrary a => Arbitrary (Last a) +deriving instance Arbitrary a => Arbitrary (WrappedMonoid a) +deriving instance Arbitrary a => Arbitrary (Option a) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Arg a b) where + arbitrary = Arg <$> arbitrary <*> arbitrary diff --git a/tests/Instances/Data/Typeable.hs b/tests/Instances/Data/Typeable.hs --- a/tests/Instances/Data/Typeable.hs +++ b/tests/Instances/Data/Typeable.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| @@ -13,14 +14,28 @@ -} module Instances.Data.Typeable () where +#include "MachDeps.h" + #if MIN_VERSION_base(4,4,0) -import Data.Typeable.Internal (TyCon(..), TypeRep(..)) +import Data.Typeable.Internal (TypeRep(..)) import Instances.Utils ((<@>)) #else import Data.Typeable (TyCon, TypeRep, mkTyCon, typeOf) import Test.QuickCheck (Gen) #endif +#if MIN_VERSION_base(4,9,0) +import GHC.Types (TyCon(..), TrName(..), Module(..)) +# if WORD_SIZE_IN_BITS < 64 +import GHC.Word (Word64(..)) +# else +import GHC.Word (Word(..)) +# endif +import Test.QuickCheck (oneof) +#elif MIN_VERSION_base(4,4,0) +import Data.Typeable.Internal (TyCon(..)) +#endif + import Instances.GHC.Fingerprint () import Prelude () @@ -42,8 +57,26 @@ #endif instance Arbitrary TyCon where -#if MIN_VERSION_base(4,4,0) +#if MIN_VERSION_base(4,9,0) + arbitrary = do +# if WORD_SIZE_IN_BITS < 64 + W64# w1# <- arbitrary + W64# w2# <- arbitrary +# else + W# w1# <- arbitrary + W# w2# <- arbitrary +# endif + TyCon w1# w2# <$> arbitrary <*> arbitrary +#elif MIN_VERSION_base(4,4,0) arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary #else arbitrary = mkTyCon <$> arbitrary +#endif + +#if MIN_VERSION_base(4,9,0) +instance Arbitrary TrName where + arbitrary = oneof [pure (TrNameS "wat"#), TrNameD <$> arbitrary] + +instance Arbitrary Module where + arbitrary = Module <$> arbitrary <*> arbitrary #endif diff --git a/tests/Instances/FromStringTextShow.hs b/tests/Instances/FromStringTextShow.hs --- a/tests/Instances/FromStringTextShow.hs +++ b/tests/Instances/FromStringTextShow.hs @@ -16,9 +16,9 @@ module Instances.FromStringTextShow () where import Test.QuickCheck (Arbitrary) -import TextShow (FromStringShow(..), FromTextShow(..)) -import TransformersCompat (FromStringShow1(..), FromStringShow2(..), - FromTextShow1(..), FromTextShow2(..)) +import TextShow (FromStringShow(..), FromTextShow(..), + FromStringShow1(..), FromStringShow2(..), + FromTextShow1(..), FromTextShow2(..)) deriving instance Arbitrary a => Arbitrary (FromStringShow a) deriving instance Arbitrary (f a) => Arbitrary (FromStringShow1 f a) diff --git a/tests/Instances/GHC/Generics.hs b/tests/Instances/GHC/Generics.hs --- a/tests/Instances/GHC/Generics.hs +++ b/tests/Instances/GHC/Generics.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -51,8 +52,25 @@ instance Arbitrary Associativity where arbitrary = arbitraryBoundedEnum +#if MIN_VERSION_base(4,9,0) +deriving instance Bounded SourceUnpackedness +deriving instance Enum SourceUnpackedness +instance Arbitrary SourceUnpackedness where + arbitrary = arbitraryBoundedEnum + +deriving instance Bounded SourceStrictness +deriving instance Enum SourceStrictness +instance Arbitrary SourceStrictness where + arbitrary = arbitraryBoundedEnum + +deriving instance Bounded DecidedStrictness +deriving instance Enum DecidedStrictness +instance Arbitrary DecidedStrictness where + arbitrary = arbitraryBoundedEnum +#else instance Arbitrary Arity where arbitrary = oneof [pure NoArity, Arity <$> arbitrary] +#endif instance Arbitrary (UChar p) where arbitrary = do diff --git a/tests/Spec/Control/ApplicativeSpec.hs b/tests/Spec/Control/ApplicativeSpec.hs --- a/tests/Spec/Control/ApplicativeSpec.hs +++ b/tests/Spec/Control/ApplicativeSpec.hs @@ -11,6 +11,7 @@ module Spec.Control.ApplicativeSpec (main, spec) where import Control.Applicative (Const, ZipList) +import Control.Monad.Trans.Instances () import Data.Orphans () @@ -18,7 +19,7 @@ import Instances.Control.Applicative () -import Spec.Utils (prop_matchesTextShow, prop_matchesTextShow2, +import Spec.Utils (prop_matchesTextShow, prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) @@ -30,7 +31,7 @@ spec :: Spec spec = parallel $ do describe "Const Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> Const Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> Const Int Int -> Bool) describe "ZipList Int" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> ZipList Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> ZipList Int -> Bool) diff --git a/tests/Spec/Control/ExceptionSpec.hs b/tests/Spec/Control/ExceptionSpec.hs --- a/tests/Spec/Control/ExceptionSpec.hs +++ b/tests/Spec/Control/ExceptionSpec.hs @@ -54,6 +54,10 @@ describe "AllocationLimitExceeded" $ prop "TextShow instance" (prop_matchesTextShow :: Int -> AllocationLimitExceeded -> Bool) #endif +#if MIN_VERSION_base(4,9,0) + describe "TypeError" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> TypeError -> Bool) +#endif describe "Deadlock" $ prop "TextShow instance" (prop_matchesTextShow :: Int -> Deadlock -> Bool) describe "NoMethodError" $ diff --git a/tests/Spec/Data/EitherSpec.hs b/tests/Spec/Data/EitherSpec.hs --- a/tests/Spec/Data/EitherSpec.hs +++ b/tests/Spec/Data/EitherSpec.hs @@ -12,7 +12,7 @@ import Generics.Deriving.Instances () -import Spec.Utils (prop_matchesTextShow2, prop_genericTextShow, prop_genericTextShow1) +import Spec.Utils (prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -22,6 +22,6 @@ spec :: Spec spec = parallel . describe "Either Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> Either Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> Either Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> Either Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> Either Int Int -> Bool) diff --git a/tests/Spec/Data/Functor/ComposeSpec.hs b/tests/Spec/Data/Functor/ComposeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Data/Functor/ComposeSpec.hs @@ -0,0 +1,30 @@ +{-| +Module: Spec.Data.Functor.ComposeSpec +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ test for 'Compose'. +-} +module Spec.Data.Functor.ComposeSpec (main, spec) where + +import Control.Monad.Trans.Instances () + +import Data.Functor.Compose (Compose) + +import Instances.Data.Functor.Compose () + +import Spec.Utils (prop_matchesTextShow1) + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.Hspec.QuickCheck (prop) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel . describe "Compose Maybe Maybe Int" $ + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> Compose Maybe Maybe Int -> Bool) + diff --git a/tests/Spec/Data/Functor/IdentitySpec.hs b/tests/Spec/Data/Functor/IdentitySpec.hs --- a/tests/Spec/Data/Functor/IdentitySpec.hs +++ b/tests/Spec/Data/Functor/IdentitySpec.hs @@ -1,5 +1,5 @@ {-| -Module: Spec.Data.Functor.Identity +Module: Spec.Data.Functor.IdentitySpec Copyright: (C) 2014-2015 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott @@ -10,7 +10,8 @@ -} module Spec.Data.Functor.IdentitySpec (main, spec) where -import Data.Functor.Classes () +import Control.Monad.Trans.Instances () + import Data.Functor.Identity (Identity) import Instances.Data.Functor.Identity () diff --git a/tests/Spec/Data/Functor/ProductSpec.hs b/tests/Spec/Data/Functor/ProductSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Data/Functor/ProductSpec.hs @@ -0,0 +1,29 @@ +{-| +Module: Spec.Data.Functor.ProductSpec +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ test for 'Product'. +-} +module Spec.Data.Functor.ProductSpec (main, spec) where + +import Control.Monad.Trans.Instances () + +import Data.Functor.Product (Product) + +import Instances.Data.Functor.Product () + +import Spec.Utils (prop_matchesTextShow1) + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.Hspec.QuickCheck (prop) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel . describe "Product Maybe Maybe Int" $ + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> Product Maybe Maybe Int -> Bool) diff --git a/tests/Spec/Data/Functor/SumSpec.hs b/tests/Spec/Data/Functor/SumSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Data/Functor/SumSpec.hs @@ -0,0 +1,30 @@ +{-| +Module: Spec.Data.Functor.SumSpec +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ test for 'Sum'. +-} +module Spec.Data.Functor.SumSpec (main, spec) where + +import Control.Monad.Trans.Instances () + +import Data.Functor.Sum (Sum) + +import Instances.Data.Functor.Sum () + +import Spec.Utils (prop_matchesTextShow1) + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.Hspec.QuickCheck (prop) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel . describe "Sum Maybe Maybe Int" $ + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> Sum Maybe Maybe Int -> Bool) + diff --git a/tests/Spec/Data/List/NonEmptySpec.hs b/tests/Spec/Data/List/NonEmptySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Data/List/NonEmptySpec.hs @@ -0,0 +1,27 @@ +{-| +Module: Spec.Data.List.NonEmptySpec +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ test for 'NonEmpty'. +-} +module Spec.Data.List.NonEmptySpec (main, spec) where + +import Data.List.NonEmpty (NonEmpty) + +import Instances.Data.List.NonEmpty () + +import Spec.Utils (prop_matchesTextShow1) + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.Hspec.QuickCheck (prop) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel . describe "NonEmpty Int" $ + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> NonEmpty Int -> Bool) diff --git a/tests/Spec/Data/SemigroupSpec.hs b/tests/Spec/Data/SemigroupSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Data/SemigroupSpec.hs @@ -0,0 +1,40 @@ +{-| +Module: Spec.Data.SemigroupSpec +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +@hspec@ tests for data types in the "Data.Semigroup" module. +-} +module Spec.Data.SemigroupSpec (main, spec) where + +import Data.Semigroup (Min, Max, First, Last, WrappedMonoid, Option, Arg) + +import Instances.Data.Semigroup () + +import Spec.Utils (prop_matchesTextShow) + +import Test.Hspec (Spec, describe, hspec, parallel) +import Test.Hspec.QuickCheck (prop) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do + describe "Min Int" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> Min Int -> Bool) + describe "Max Int" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> Max Int -> Bool) + describe "First Int" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> First Int -> Bool) + describe "Last Int" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> Last Int -> Bool) + describe "WrappedMonoid ()" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> WrappedMonoid () -> Bool) + describe "Option Int" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> Option Int -> Bool) + describe "Arg Int Char" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> Arg Int Char -> Bool) diff --git a/tests/Spec/Data/TupleSpec.hs b/tests/Spec/Data/TupleSpec.hs --- a/tests/Spec/Data/TupleSpec.hs +++ b/tests/Spec/Data/TupleSpec.hs @@ -14,7 +14,7 @@ import Instances.Data.Tuple () -import Spec.Utils (prop_matchesTextShow, prop_matchesTextShow2, +import Spec.Utils (prop_matchesTextShow, prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) @@ -31,8 +31,8 @@ prop "generic TextShow" (prop_genericTextShow :: Int -> () -> Bool) describe "(Int, Int)" $ do - prop "TextShow2 instance" - (prop_matchesTextShow2 :: Int -> (Int, Int) -> Bool) + prop "TextShow1 instance" + (prop_matchesTextShow1 :: Int -> (Int, Int) -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> (Int, Int) -> Bool) prop "generic TextShow1" diff --git a/tests/Spec/Data/TypeableSpec.hs b/tests/Spec/Data/TypeableSpec.hs --- a/tests/Spec/Data/TypeableSpec.hs +++ b/tests/Spec/Data/TypeableSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {-| Module: Spec.Data.TypeableSpec Copyright: (C) 2014-2015 Ryan Scott @@ -12,6 +14,10 @@ import Data.Typeable (TyCon, TypeRep) +#if MIN_VERSION_base(4,9,0) +import GHC.Types (TrName, Module) +#endif + import Instances.Data.Typeable () import Spec.Utils (prop_matchesTextShow) @@ -28,3 +34,9 @@ prop "TextShow instance" (prop_matchesTextShow :: Int -> TypeRep -> Bool) describe "TyCon" $ prop "TextShow instance" (prop_matchesTextShow :: Int -> TyCon -> Bool) +#if MIN_VERSION_base(4,9,0) + describe "TrName" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> TrName -> Bool) + describe "Module" $ + prop "TextShow instance" (prop_matchesTextShow :: Int -> Module -> Bool) +#endif diff --git a/tests/Spec/Derived/DataFamiliesSpec.hs b/tests/Spec/Derived/DataFamiliesSpec.hs --- a/tests/Spec/Derived/DataFamiliesSpec.hs +++ b/tests/Spec/Derived/DataFamiliesSpec.hs @@ -20,11 +20,15 @@ #if MIN_VERSION_template_haskell(2,7,0) import Derived.DataFamilies (NotAllShow) -import Spec.Utils (prop_matchesTextShow2, prop_genericTextShow, prop_genericTextShow1) +import Spec.Utils (prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (describe) import Test.Hspec.QuickCheck (prop) +# if __GLASGOW_HASKELL__ >= 706 +import Derived.DataFamilies (KindDistinguished) +# endif + # if __GLASGOW_HASKELL__ >= 708 import Derived.DataFamilies (NullaryData) import Spec.Utils (prop_matchesTextShow) @@ -38,9 +42,23 @@ spec = parallel $ do #if MIN_VERSION_template_haskell(2,7,0) describe "NotAllShow Int Int Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> NotAllShow Int Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> NotAllShow Int Int Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> NotAllShow Int Int Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> NotAllShow Int Int Int Int -> Bool) +# if __GLASGOW_HASKELL__ >= 706 + describe "KindDistinguished Int Int Int" $ do + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> KindDistinguished Int Int Int -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> KindDistinguished Int Int Int -> Bool) + prop "generic TextShow1" (prop_genericTextShow1 :: Int -> KindDistinguished Int Int Int -> Bool) + describe "KindDistinguished Maybe Int Int" $ do + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> KindDistinguished Maybe Int Int -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> KindDistinguished Maybe Int Int -> Bool) + prop "generic TextShow1" (prop_genericTextShow1 :: Int -> KindDistinguished Maybe Int Int -> Bool) + describe "KindDistinguished Either Int Int" $ do + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> KindDistinguished Either Int Int -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> KindDistinguished Either Int Int -> Bool) + prop "generic TextShow1" (prop_genericTextShow1 :: Int -> KindDistinguished Either Int Int -> Bool) +# endif # if __GLASGOW_HASKELL__ >= 708 describe "NullaryData" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> NullaryData -> Bool) diff --git a/tests/Spec/Derived/DatatypeContextsSpec.hs b/tests/Spec/Derived/DatatypeContextsSpec.hs --- a/tests/Spec/Derived/DatatypeContextsSpec.hs +++ b/tests/Spec/Derived/DatatypeContextsSpec.hs @@ -14,7 +14,7 @@ import Derived.DatatypeContexts -import Spec.Utils (prop_matchesTextShow2) +import Spec.Utils (prop_matchesTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -25,8 +25,8 @@ spec :: Spec spec = parallel $ do describe "TyCon Int Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyCon Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyCon Int Int Int -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily Int Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamily Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamily Int Int Int -> Bool) #endif diff --git a/tests/Spec/Derived/ExistentialQuantificationSpec.hs b/tests/Spec/Derived/ExistentialQuantificationSpec.hs --- a/tests/Spec/Derived/ExistentialQuantificationSpec.hs +++ b/tests/Spec/Derived/ExistentialQuantificationSpec.hs @@ -14,7 +14,7 @@ import Derived.ExistentialQuantification -import Spec.Utils (prop_matchesTextShow2) +import Spec.Utils (prop_matchesTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -25,8 +25,8 @@ spec :: Spec spec = parallel $ do describe "TyCon Int Int Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyCon Int Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyCon Int Int Int Int -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily Int Int Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamily Int Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamily Int Int Int Int -> Bool) #endif diff --git a/tests/Spec/Derived/MagicHashSpec.hs b/tests/Spec/Derived/MagicHashSpec.hs --- a/tests/Spec/Derived/MagicHashSpec.hs +++ b/tests/Spec/Derived/MagicHashSpec.hs @@ -15,7 +15,7 @@ import Derived.MagicHash -import Spec.Utils (prop_matchesTextShow2, prop_genericTextShow, prop_genericTextShow1) +import Spec.Utils (prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -26,12 +26,12 @@ spec :: Spec spec = parallel $ do describe "TyCon# Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyCon# Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyCon# Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyCon# Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyCon# Int Int -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily# Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamily# Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamily# Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyFamily# Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyFamily# Int Int -> Bool) #endif diff --git a/tests/Spec/Derived/PolyKindsSpec.hs b/tests/Spec/Derived/PolyKindsSpec.hs --- a/tests/Spec/Derived/PolyKindsSpec.hs +++ b/tests/Spec/Derived/PolyKindsSpec.hs @@ -14,7 +14,7 @@ import Derived.PolyKinds -import Spec.Utils (prop_matchesTextShow2, prop_genericTextShow, prop_genericTextShow1) +import Spec.Utils (prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -25,28 +25,28 @@ spec :: Spec spec = parallel $ do describe "TyConCompose Either Either Either Maybe Maybe Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyConCompose Either Either Either Maybe Maybe Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyConCompose Either Either Either Maybe Maybe Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyConCompose Either Either Either Maybe Maybe Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyConCompose Either Either Either Maybe Maybe Int Int -> Bool) describe "TyConProxy Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyConProxy Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyConProxy Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyConProxy Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyConProxy Int Int -> Bool) describe "TyConReallyHighKinds (,,,,) Int Int Int Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyConReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyConReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyConReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyConReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamilyCompose Either Either Either Maybe Maybe Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamilyCompose Either Either Either Maybe Maybe Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamilyCompose Either Either Either Maybe Maybe Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyFamilyCompose Either Either Either Maybe Maybe Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyFamilyCompose Either Either Either Maybe Maybe Int Int -> Bool) describe "TyFamilyProxy Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamilyProxy Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamilyProxy Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyFamilyProxy Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyFamilyProxy Int Int -> Bool) describe "TyFamilyReallyHighKinds (,,,,) Int Int Int Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamilyReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamilyReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyFamilyReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyFamilyReallyHighKinds (,,,,) Int Int Int Int Int -> Bool) #endif diff --git a/tests/Spec/Derived/RankNTypesSpec.hs b/tests/Spec/Derived/RankNTypesSpec.hs --- a/tests/Spec/Derived/RankNTypesSpec.hs +++ b/tests/Spec/Derived/RankNTypesSpec.hs @@ -12,9 +12,9 @@ -} module Spec.Derived.RankNTypesSpec (main, spec) where -import Derived.Records +import Derived.RankNTypes -import Spec.Utils (prop_matchesTextShow2) +import Spec.Utils (prop_matchesTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -25,8 +25,8 @@ spec :: Spec spec = parallel $ do describe "TyCon Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyCon Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyCon Int Int -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily Int Int" $ - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamily Int Int -> Bool) + prop "TextShow2 instance" (prop_matchesTextShow1 :: Int -> TyFamily Int Int -> Bool) #endif diff --git a/tests/Spec/Derived/RecordsSpec.hs b/tests/Spec/Derived/RecordsSpec.hs --- a/tests/Spec/Derived/RecordsSpec.hs +++ b/tests/Spec/Derived/RecordsSpec.hs @@ -14,7 +14,7 @@ import Derived.Records -import Spec.Utils (prop_matchesTextShow2, prop_genericTextShow, prop_genericTextShow1) +import Spec.Utils (prop_matchesTextShow1, prop_genericTextShow, prop_genericTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) @@ -25,12 +25,12 @@ spec :: Spec spec = parallel $ do describe "TyCon Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyCon Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyCon Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyCon Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyCon Int Int -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamily Int Int" $ do - prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> TyFamily Int Int -> Bool) + prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> TyFamily Int Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> TyFamily Int Int -> Bool) prop "generic TextShow1" (prop_genericTextShow1 :: Int -> TyFamily Int Int -> Bool) #endif diff --git a/tests/Spec/FromStringTextShowSpec.hs b/tests/Spec/FromStringTextShowSpec.hs --- a/tests/Spec/FromStringTextShowSpec.hs +++ b/tests/Spec/FromStringTextShowSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {-| Module: Spec.FromStringTextShowSpec Copyright: (C) 2014-2015 Ryan Scott @@ -12,15 +14,18 @@ import Instances.FromStringTextShow () -import Spec.Utils (prop_matchesTextShow, prop_matchesTextShow1, prop_matchesTextShow2) +import Spec.Utils (prop_matchesTextShow, prop_matchesTextShow1) import Test.Hspec (Spec, describe, hspec, parallel) import Test.Hspec.QuickCheck (prop) import TextShow (FromStringShow(..), FromTextShow(..)) -import TransformersCompat (FromStringShow1(..), FromStringShow2(..), - FromTextShow1(..), FromTextShow2(..)) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Spec.Utils (prop_matchesTextShow2) +import TextShow (FromStringShow1(..), FromStringShow2(..), + FromTextShow1(..), FromTextShow2(..)) +#endif main :: IO () main = hspec spec @@ -39,6 +44,7 @@ describe "FromTextShow String" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> FromTextShow String -> Bool) prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> FromTextShow String -> Bool) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) describe "FromStringShow1 Maybe Int" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> FromStringShow1 Maybe Int -> Bool) prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> FromStringShow1 Maybe Int -> Bool) @@ -53,3 +59,4 @@ prop "TextShow instance" (prop_matchesTextShow :: Int -> FromTextShow2 Either Char Int -> Bool) prop "TextShow1 instance" (prop_matchesTextShow1 :: Int -> FromTextShow2 Either Char Int -> Bool) prop "TextShow2 instance" (prop_matchesTextShow2 :: Int -> FromTextShow2 Either Char Int -> Bool) +#endif diff --git a/tests/Spec/GHC/GenericsSpec.hs b/tests/Spec/GHC/GenericsSpec.hs --- a/tests/Spec/GHC/GenericsSpec.hs +++ b/tests/Spec/GHC/GenericsSpec.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +#endif + {-| Module: Spec.GHC.GenericsSpec Copyright: (C) 2014-2015 Ryan Scott @@ -14,9 +19,16 @@ import Data.Orphans () -import Generics.Deriving.Base (U1, Par1, Rec1, K1, M1, (:+:), (:*:), (:.:), - UChar, UDouble, UFloat, UInt, UWord, - Fixity, Associativity, Arity) +import Generics.Deriving.Base ( U1, Par1, Rec1, K1, M1, (:+:), (:*:), (:.:) + , UChar, UDouble, UFloat, UInt, UWord + , Fixity, Associativity +#if MIN_VERSION_base(4,9,0) + , Meta(MetaData), SourceUnpackedness + , SourceStrictness, DecidedStrictness +#else + , Arity +#endif + ) import Generics.Deriving.Instances () import Instances.GHC.Generics () @@ -29,6 +41,18 @@ main :: IO () main = hspec spec +#if MIN_VERSION_base(4,9,0) +type MD = 'MetaData "Example" "Module" "package" 'False + +m1Description :: String +m1Description = "M1 () ('MetaData \"Example\" \"Module\" \"package\" 'False) Maybe Int" +#else +type MD = () + +m1Description :: String +m1Description = "M1 () () Maybe Int" +#endif + spec :: Spec spec = parallel $ do describe "Fixity" $ do @@ -37,9 +61,21 @@ describe "Associativity" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> Associativity -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> Associativity -> Bool) +#if MIN_VERSION_base(4,9,0) + describe "SourceUnpackedness" $ do + prop "TextShow instance" (prop_matchesTextShow :: Int -> SourceUnpackedness -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> SourceUnpackedness -> Bool) + describe "SourceStrictness" $ do + prop "TextShow instance" (prop_matchesTextShow :: Int -> SourceStrictness -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> SourceStrictness -> Bool) + describe "DecidedStrictness" $ do + prop "TextShow instance" (prop_matchesTextShow :: Int -> DecidedStrictness -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> DecidedStrictness -> Bool) +#else describe "Arity" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> Arity -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> Arity -> Bool) +#endif describe "U1 Int" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> U1 Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> U1 Int -> Bool) @@ -52,9 +88,9 @@ describe "K1 () Int ()" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> K1 () Int () -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> K1 () Int () -> Bool) - describe "M1 () () Maybe Int" $ do - prop "TextShow instance" (prop_matchesTextShow :: Int -> M1 () () Maybe Int -> Bool) - prop "generic TextShow" (prop_genericTextShow :: Int -> M1 () () Maybe Int -> Bool) + describe m1Description $ do + prop "TextShow instance" (prop_matchesTextShow :: Int -> M1 () MD Maybe Int -> Bool) + prop "generic TextShow" (prop_genericTextShow :: Int -> M1 () MD Maybe Int -> Bool) describe "(Maybe :+: Maybe) Int" $ do prop "TextShow instance" (prop_matchesTextShow :: Int -> (Maybe :+: Maybe) Int -> Bool) prop "generic TextShow" (prop_genericTextShow :: Int -> (Maybe :+: Maybe) Int -> Bool) diff --git a/tests/Spec/Utils.hs b/tests/Spec/Utils.hs --- a/tests/Spec/Utils.hs +++ b/tests/Spec/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} + {-| Module: Spec.Utils Copyright: (C) 2014-2015 Ryan Scott @@ -14,12 +15,14 @@ ioProperty , prop_matchesTextShow , prop_matchesTextShow1 +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) , prop_matchesTextShow2 +#endif , prop_genericTextShow , prop_genericTextShow1 ) where -#include "generic.h" +import Data.Functor.Classes (Show1, showsPrec1) import Generics.Deriving.Base @@ -30,12 +33,13 @@ #endif import Test.QuickCheck (Property, Testable) -import TextShow (TextShow(..), TextShow1(..), TextShow2(..), - Builder, FromStringShow(..)) +import TextShow (TextShow(..), TextShow1(..), showbPrec1, fromString) import TextShow.Generic -import TransformersCompat (Show1, Show2, - FromStringShow1(..), FromStringShow2(..)) +#if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show2, showsPrec2) +import TextShow (TextShow2(..), showbPrec2) +#endif ioProperty :: Testable prop => IO prop -> Property #if MIN_VERSION_QuickCheck(2,7,0) @@ -47,29 +51,20 @@ -- | 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 = showbPrec p (FromStringShow x) == showbPrec p x +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', -- irrespective of precedence. -prop_matchesTextShow1 :: (Show1 f, TextShow1 f) => Int -> f a -> Bool -prop_matchesTextShow1 p x = showbPrecWith showb27Prec p (FromStringShow1 x) - == showbPrecWith showb27Prec p x +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 !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) -- | Verifies that a type's @Show2@ instances coincide for both 'String's and 'Text', -- irrespective of precedence. -prop_matchesTextShow2 :: (Show2 f, TextShow2 f) => Int -> f a b -> Bool -prop_matchesTextShow2 p x = showbPrecWith2 showb27Prec showb42Prec p (FromStringShow2 x) - == showbPrecWith2 showb27Prec showb42Prec p x - --- | Show the number 27, which certain parody singer-songwriters find humorous. --- Useful for testing higher-order @Show@ classes. -showb27Prec :: Int -> a -> Builder -showb27Prec p _ = showbPrec p $ Just (27 :: Int) - --- | Show the number 42, which is said to be the answer to something or other. --- Useful for testing higher-order @Show@ classes. -showb42Prec :: Int -> a -> Builder -showb42Prec p _ = showbPrec p $ Just (42 :: Int) +prop_matchesTextShow2 :: (Show2 f, Show a, Show b, TextShow2 f, TextShow a, TextShow b) + => Int -> f a b -> Bool +prop_matchesTextShow2 p x = fromString (showsPrec2 p x "") == showbPrec2 p x +#endif -- | Verifies that a type's 'TextShow' instance coincides with the output produced -- by the equivalent 'Generic' functions. @@ -79,7 +74,7 @@ -- | Verifies that a type's 'TextShow1' instance coincides with the output produced -- by the equivalent 'Generic1' functions. -prop_genericTextShow1 :: (TextShow1 f, Generic1 f, GTextShow1 (Rep1 f)) +prop_genericTextShow1 :: (TextShow1 f, Generic1 f, GTextShow1 (Rep1 f), TextShow a) => Int -> f a -> Bool -prop_genericTextShow1 p x = showbPrecWith showb27Prec p x - == genericShowbPrecWith showb27Prec p x +prop_genericTextShow1 p x = + showbPrec1 p x == genericLiftShowbPrec showbPrec showbList p x diff --git a/tests/TransformersCompat.hs b/tests/TransformersCompat.hs deleted file mode 100644 --- a/tests/TransformersCompat.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -#endif - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -{-| -Module: TransformersCompat -Copyright: (C) 2014-2015 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Stability: Provisional -Portability: GHC - -Defines the 'Show1' and 'Show2' classes for @String@s. This module will be removed -once the next version of @transformers@/@transformers-compat@ is released. --} -module TransformersCompat ( - -- * Liftings of Prelude classes - -- ** For unary constructors - Show1(..), showsPrec1, - -- ** For binary constructors - Show2(..), showsPrec2, - -- * Helper functions - showsUnaryWith, - showsBinaryWith, - -- * Conversion between @Text-@ and @String@ @Show1@/@Show2@ - FromStringShow1(..), FromTextShow1(..), - FromStringShow2(..), FromTextShow2(..) - ) where - -#include "inline.h" - -import Control.Applicative (Const(..)) - -import Data.Bifunctor.TH (deriveBifunctor, deriveBifoldable, - deriveBitraversable) -#if __GLASGOW_HASKELL__ >= 708 -import Data.Data (Data, Typeable) -#endif -import Data.Functor.Identity (Identity(..)) - -#if __GLASGOW_HASKELL__ < 706 -import qualified Generics.Deriving.TH as Generics -#endif - -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -# if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -# endif -#endif - -import Prelude () -import Prelude.Compat - -import Text.Read (Read(..), readListPrecDefault) - -import TextShow (TextShow(showbPrec), TextShow1(..), TextShow2(..), - FromStringShow(..), FromTextShow(..), - showsToShowb, showbToShows, showbPrec1, showbPrec2) - --- | Lifting of the 'Show' class to unary type constructors. -class Show1 f where - -- | Lift a 'showsPrec' function through the type constructor. - showsPrecWith :: (Int -> a -> ShowS) -> Int -> f a -> ShowS - --- | Lift the standard 'showsPrec' function through the type constructor. -showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS -showsPrec1 = showsPrecWith showsPrec - --- | The 'TextShow1' instance for 'FromStringShow1' is based on its @String@ --- 'Show1' instance. That is, --- --- @ --- showbPrecWith sp p ('FromStringShow1' x) = --- 'showsToShowb' ('showsPrecWith' ('showbToShows' sp)) p x --- @ --- --- /Since: ?.?/ -newtype FromStringShow1 f a = FromStringShow1 { fromStringShow1 :: f a } - deriving ( Eq - , Functor - , Foldable -#if __GLASGOW_HASKELL__ >= 702 - , Generic -# if __GLASGOW_HASKELL__ >= 706 - , Generic1 -# endif -#endif - , Ord - , Show1 - , Traversable -#if __GLASGOW_HASKELL__ >= 708 - , Data - , Typeable -#endif - ) - -instance Read (f a) => Read (FromStringShow1 f a) where - readPrec = FromStringShow1 <$> readPrec - INLINE_INST_FUN(readPrec) - - readListPrec = readListPrecDefault - INLINE_INST_FUN(readListPrec) - -instance (Show1 f, Show a) => TextShow (FromStringShow1 f a) where - showbPrec = showbPrecWith (showsToShowb showsPrec) - INLINE_INST_FUN(showbPrec) - -instance Show1 f => TextShow1 (FromStringShow1 f) where - showbPrecWith sp p = - showsToShowb (showsPrecWith $ showbToShows sp) p . fromStringShow1 - INLINE_INST_FUN(showbPrecWith) - -instance (Show1 f, Show a) => Show (FromStringShow1 f a) where - showsPrec = showsPrec1 - INLINE_INST_FUN(showsPrec) - --- | Lifting of the 'Show' class to binary type constructors. -class Show2 f where - -- | Lift 'showsPrec' functions through the type constructor. - showsPrecWith2 :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> - Int -> f a b -> ShowS - --- | Lift the standard 'showsPrec' function through the type constructor. -showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS -showsPrec2 = showsPrecWith2 showsPrec showsPrec - --- | The @String@ 'Show1' instance for 'FromTextShow1' is based on its --- 'TextShow1' instance. That is, --- --- @ --- showsPrecWith sp p ('FromTextShow1' x) = --- 'showbToShows' ('showbPrecWith' ('showsToShowb' sp)) p x --- @ --- --- /Since: ?.?/ -newtype FromTextShow1 f a = FromTextShow1 { fromTextShow1 :: f a } - deriving ( Eq - , Functor - , Foldable -#if __GLASGOW_HASKELL__ >= 702 - , Generic -# if __GLASGOW_HASKELL__ >= 706 - , Generic1 -# endif -#endif - , Ord - , TextShow1 - , Traversable -#if __GLASGOW_HASKELL__ >= 708 - , Data - , Typeable -#endif - ) - -instance Read (f a) => Read (FromTextShow1 f a) where - readPrec = FromTextShow1 <$> readPrec - INLINE_INST_FUN(readPrec) - - readListPrec = readListPrecDefault - INLINE_INST_FUN(readListPrec) - -instance (TextShow1 f, TextShow a) => Show (FromTextShow1 f a) where - showsPrec = showsPrecWith (showbToShows showbPrec) - INLINE_INST_FUN(showsPrec) - -instance TextShow1 f => Show1 (FromTextShow1 f) where - showsPrecWith sp p = - showbToShows (showbPrecWith $ showsToShowb sp) p . fromTextShow1 - INLINE_INST_FUN(showsPrecWith) - -instance (TextShow1 f, TextShow a) => TextShow (FromTextShow1 f a) where - showbPrec = showbPrec1 - INLINE_INST_FUN(showbPrec) - --- | The 'TextShow2' instance for 'FromStringShow2' is based on its @String@ --- 'Show2' instance. That is, --- --- @ --- showbPrecWith2 sp1 sp2 p ('FromStringShow2' x) = --- 'showsToShowb' ('showsPrecWith2' ('showbToShows' sp1) ('showbToShows' sp2)) p x --- @ --- --- /Since: ?.?/ -newtype FromStringShow2 f a b = FromStringShow2 { fromStringShow2 :: f a b } - deriving ( Eq - , Functor - , Foldable -#if __GLASGOW_HASKELL__ >= 702 - , Generic -# if defined(__LANGUAGE_DERIVE_GENERIC1__) - , Generic1 -# endif -#endif - , Ord - , Show2 - , Traversable -#if __GLASGOW_HASKELL__ >= 708 - , Data - , Typeable -#endif - ) - -instance Read (f a b) => Read (FromStringShow2 f a b) where - readPrec = FromStringShow2 <$> readPrec - INLINE_INST_FUN(readPrec) - - readListPrec = readListPrecDefault - INLINE_INST_FUN(readListPrec) - -instance (Show2 f, Show a, Show b) => TextShow (FromStringShow2 f a b) where - showbPrec = showbPrecWith (showsToShowb showsPrec) - INLINE_INST_FUN(showbPrec) - -instance (Show2 f, Show a) => TextShow1 (FromStringShow2 f a) where - showbPrecWith = showbPrecWith2 (showsToShowb showsPrec) - INLINE_INST_FUN(showbPrecWith) - -instance Show2 f => TextShow2 (FromStringShow2 f) where - showbPrecWith2 sp1 sp2 p = - showsToShowb (showsPrecWith2 (showbToShows sp1) (showbToShows sp2)) p . fromStringShow2 - INLINE_INST_FUN(showbPrecWith2) - -instance (Show2 f, Show a, Show b) => Show (FromStringShow2 f a b) where - showsPrec = showsPrec2 - INLINE_INST_FUN(showsPrec) - -instance (Show2 f, Show a) => Show1 (FromStringShow2 f a) where - showsPrecWith = showsPrecWith2 showsPrec - INLINE_INST_FUN(showsPrecWith) - --- | The @String@ 'Show2' instance for 'FromTextShow2' is based on its --- 'TextShow2' instance. That is, --- --- @ --- showsPrecWith2 sp1 sp2 p ('FromTextShow2' x) = --- 'showbToShows' ('showbPrecWith2' ('showsToShowb' sp1) ('showsToShowb' sp2)) p x --- @ --- --- /Since: ?.?/ -newtype FromTextShow2 f a b = FromTextShow2 { fromTextShow2 :: f a b } - deriving ( Eq - , Functor - , Foldable -#if __GLASGOW_HASKELL__ >= 702 - , Generic -# if defined(__LANGUAGE_DERIVE_GENERIC1__) - , Generic1 -# endif -#endif - , Ord - , TextShow2 - , Traversable -#if __GLASGOW_HASKELL__ >= 708 - , Data - , Typeable -#endif - ) - -instance Read (f a b) => Read (FromTextShow2 f a b) where - readPrec = FromTextShow2 <$> readPrec - INLINE_INST_FUN(readPrec) - - readListPrec = readListPrecDefault - INLINE_INST_FUN(readListPrec) - -instance (TextShow2 f, TextShow a, TextShow b) => Show (FromTextShow2 f a b) where - showsPrec = showsPrecWith (showbToShows showbPrec) - INLINE_INST_FUN(showsPrec) - -instance (TextShow2 f, TextShow a) => Show1 (FromTextShow2 f a) where - showsPrecWith = showsPrecWith2 (showbToShows showbPrec) - INLINE_INST_FUN(showsPrecWith) - -instance TextShow2 f => Show2 (FromTextShow2 f) where - showsPrecWith2 sp1 sp2 p = - showbToShows (showbPrecWith2 (showsToShowb sp1) (showsToShowb sp2)) p . fromTextShow2 - INLINE_INST_FUN(showsPrecWith2) - -instance (TextShow2 f, TextShow a, TextShow b) => TextShow (FromTextShow2 f a b) where - showbPrec = showbPrec2 - INLINE_INST_FUN(showbPrec) - -instance (TextShow2 f, TextShow a) => TextShow1 (FromTextShow2 f a) where - showbPrecWith = showbPrecWith2 showbPrec - INLINE_INST_FUN(showbPrecWith) - -------------------------------------------------------------------------------- - --- | @'showsUnaryWith' sp n d x@ produces the string representation of a --- unary data constructor with name @n@ and argument @x@, in precedence --- context @d@. -showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS -showsUnaryWith sp name d x = showParen (d > 10) $ - showString name . showChar ' ' . sp 11 x - --- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string --- representation of a binary data constructor with name @n@ and arguments --- @x@ and @y@, in precedence context @d@. -showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> - String -> Int -> a -> b -> ShowS -showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y - -------------------------------------------------------------------------------- - -instance Show a => Show1 ((,) a) where - showsPrecWith = showsPrecWith2 showsPrec - -instance Show a => Show1 (Either a) where - showsPrecWith = showsPrecWith2 showsPrec - -instance Show a => Show1 (Const a) where - showsPrecWith = showsPrecWith2 showsPrec - -instance Show1 Maybe where - showsPrecWith _ _ Nothing = showString "Nothing" - showsPrecWith sp d (Just x) = showsUnaryWith sp "Just" d x - -instance Show1 [] where - showsPrecWith _ _ [] = showString "[]" - showsPrecWith sp _ (x:xs) = showChar '[' . sp 0 x . showl xs - where - showl [] = showChar ']' - showl (y:ys) = showChar ',' . sp 0 y . showl ys - -instance Show1 Identity where - showsPrecWith sp d (Identity x) = showsUnaryWith sp "Identity" d x - -instance Show2 (,) where - showsPrecWith2 sp1 sp2 _ (x, y) = - showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' - -instance Show2 Either where - showsPrecWith2 sp1 _ d (Left x) = showsUnaryWith sp1 "Left" d x - showsPrecWith2 _ sp2 d (Right x) = showsUnaryWith sp2 "Right" d x - -instance Show2 Const where - showsPrecWith2 sp _ d (Const x) = showsUnaryWith sp "Const" d x - -instance (Show a, Show b, Show c) => Show2 ((,,,,) a b c) where - showsPrecWith2 sp1 sp2 _ (a, b, c, d, e) = - showChar '(' . shows a . showChar ',' - . shows b . showChar ',' - . shows c . showChar ',' - . sp1 0 d . showChar ',' - . sp2 0 e . showChar ')' - --- TODO: Move these instance into text-show itself once transformers is updated -instance Show1 FromStringShow where - showsPrecWith sp p = sp p . fromStringShow - INLINE_INST_FUN(showsPrecWith) - -instance Show1 FromTextShow where - showsPrecWith sp p = - showbToShows (showsToShowb sp) p . fromTextShow - INLINE_INST_FUN(showsPrecWith) - -------------------------------------------------------------------------------- - -$(deriveBifunctor ''FromStringShow2) -$(deriveBifunctor ''FromTextShow2) -$(deriveBifoldable ''FromStringShow2) -$(deriveBifoldable ''FromTextShow2) -$(deriveBitraversable ''FromStringShow2) -$(deriveBitraversable ''FromTextShow2) - -#if __GLASGOW_HASKELL__ < 706 -$(Generics.deriveMeta ''FromStringShow1) -$(Generics.deriveRepresentable1 ''FromStringShow1) -$(Generics.deriveMeta ''FromTextShow1) -$(Generics.deriveRepresentable1 ''FromTextShow1) -$(Generics.deriveMeta ''FromStringShow2) -$(Generics.deriveRepresentable1 ''FromStringShow2) -$(Generics.deriveMeta ''FromTextShow2) -$(Generics.deriveRepresentable1 ''FromTextShow2) -#endif - -#if __GLASGOW_HASKELL__ < 702 -$(Generics.deriveRepresentable0 ''FromStringShow1) -$(Generics.deriveRepresentable0 ''FromStringShow2) -$(Generics.deriveRepresentable0 ''FromTextShow1) -$(Generics.deriveRepresentable0 ''FromTextShow2) -#endif diff --git a/text-show.cabal b/text-show.cabal --- a/text-show.cabal +++ b/text-show.cabal @@ -1,5 +1,5 @@ name: text-show -version: 2.1.2 +version: 3 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 @@ -50,6 +50,7 @@ , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 + , GHC == 8.0.1 extra-source-files: CHANGELOG.md, README.md, include/*.h cabal-version: >=1.10 @@ -78,18 +79,23 @@ TextShow.Data.Either TextShow.Data.Fixed TextShow.Data.Floating + TextShow.Data.Functor.Compose TextShow.Data.Functor.Identity + TextShow.Data.Functor.Product + TextShow.Data.Functor.Sum TextShow.Debug.Trace TextShow.Debug.Trace.Generic TextShow.Debug.Trace.TH TextShow.Generic TextShow.Data.Integral TextShow.Data.List + TextShow.Data.List.NonEmpty TextShow.Data.Maybe TextShow.Data.Monoid TextShow.Data.Ord TextShow.Data.Proxy TextShow.Data.Ratio + TextShow.Data.Semigroup TextShow.Data.Text TextShow.Data.Tuple TextShow.Data.Typeable @@ -136,30 +142,33 @@ TextShow.TH.Internal TextShow.TH.Names TextShow.Utils - build-depends: array >= 0.3 && < 0.6 - , base >= 4.3 && < 5 - , base-compat >= 0.8.1 && < 1 - , bytestring  >= 0.9 && < 0.11 + build-depends: array >= 0.3 && < 0.6 + , base >= 4.3 && < 5 + , base-compat >= 0.8.1 && < 1 + , bifunctors >= 5.1 && < 6 + , bytestring >= 0.9 && < 0.11 , bytestring-builder - , containers >= 0.1 && < 0.6 - , generic-deriving >= 1.9 && < 2 + , containers >= 0.1 && < 0.6 + , generic-deriving >= 1.9 && < 2 , ghc-prim , integer-gmp - , nats >= 0.1 && < 2 - , semigroups >= 0.16.1 && < 1 - , tagged >= 0.4.4 && < 1 - , text >= 0.11.1 && < 1.3 - , template-haskell >= 2.5 && < 2.12 - , transformers >= 0.2.1 && < 0.5 - , void >= 0.5 && < 1 + , nats >= 0.1 && < 2 + , semigroups >= 0.17 && < 1 + , tagged >= 0.4.4 && < 1 + , text >= 0.11.1 && < 1.3 + , template-haskell >= 2.5 && < 2.12 + , th-lift >= 0.7.6 && < 1 + , transformers >= 0.2.1 && < 0.6 + , transformers-compat >= 0.5 && < 1 + , void >= 0.5 && < 1 + if impl(ghc >= 8.0) + build-depends: ghc-boot hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall include-dirs: include includes: inline.h , utils.h - install-includes: inline.h - , utils.h test-suite spec type: exitcode-stdio-1.0 @@ -183,10 +192,15 @@ Instances.Data.Data Instances.Data.Dynamic Instances.Data.Floating + Instances.Data.Functor.Compose Instances.Data.Functor.Identity + Instances.Data.Functor.Product + Instances.Data.Functor.Sum + Instances.Data.List.NonEmpty Instances.Data.Monoid Instances.Data.Ord Instances.Data.Proxy + Instances.Data.Semigroup Instances.Data.Text Instances.Data.Tuple Instances.Data.Typeable @@ -242,14 +256,19 @@ Spec.Data.EitherSpec Spec.Data.FixedSpec Spec.Data.FloatingSpec + Spec.Data.Functor.ComposeSpec Spec.Data.Functor.IdentitySpec + Spec.Data.Functor.ProductSpec + Spec.Data.Functor.SumSpec Spec.Data.IntegralSpec Spec.Data.ListSpec + Spec.Data.List.NonEmptySpec Spec.Data.MaybeSpec Spec.Data.MonoidSpec Spec.Data.OrdSpec Spec.Data.ProxySpec Spec.Data.RatioSpec + Spec.Data.SemigroupSpec Spec.Data.TextSpec Spec.Data.TupleSpec Spec.Data.TypeableSpec @@ -301,33 +320,32 @@ -- Only exports tests if base >= 4.8 Spec.GHC.RTS.FlagsSpec Spec.GHC.StaticPtrSpec - - TransformersCompat build-depends: array >= 0.3 && < 0.6 , base >= 4.3 && < 5 , base-compat >= 0.8.2 && < 1 , base-orphans >= 0.4.2 && < 1 , bifunctors >= 5.1 && < 6 - , bytestring  >= 0.9 && < 0.11 + , bytestring >= 0.9 && < 0.11 , bytestring-builder + , containers >= 0.1 && < 0.6 , generic-deriving >= 1.9 && < 2 , ghc-prim , hspec >= 2 && < 3 + , integer-gmp , nats >= 0.1 && < 2 , QuickCheck >= 2.5 && < 3 , quickcheck-instances >= 0.1 && < 0.4 - , tagged >= 0.8.1 && < 1 + , semigroups >= 0.17 && < 1 + , tagged >= 0.8.3 && < 1 + , template-haskell >= 2.5 && < 2.12 , text >= 0.11.1 && < 1.3 - , transformers >= 0.2.1 && < 0.5 - , transformers-compat >= 0.3 && < 1 + , transformers >= 0.2.1 && < 0.6 + , transformers-compat >= 0.5 && < 1 , void >= 0.5 && < 1 - if flag(developer) - build-depends: containers >= 0.1 && < 0.6 - , integer-gmp - , semigroups >= 0.16.1 && < 1 - , template-haskell >= 2.5 && < 2.12 - else - build-depends: text-show == 2.1.2 + if impl(ghc >= 8.0) + build-depends: ghc-boot + if !flag(developer) + build-depends: text-show == 3 hs-source-dirs: tests if flag(developer) @@ -337,8 +355,5 @@ ghc-options: -Wall -threaded -rtsopts include-dirs: include includes: generic.h - , overlap.h - , utils.h - install-includes: generic.h , overlap.h , utils.h