diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,30 +1,50 @@ -## 0.4.1.0 -* Added the utility functions `toStrictText` and `toString` for working with `Builder`s. +# 0.5 +* Fix build for GHC 7.10, old GHC versions, and Windows +* Removed the `Text.Show.Text.Data.Containers` and `Text.Show.Text.Data.Time` modules. The modules for the data types in `containers` and `time` were migrated to a separate library, `text-show-instances`. +* Removed the `-ftext-format` flag, as `text-show` no longer uses `text-format`. +* A [serious bug](https://github.com/bos/text/issues/99) in the `text` package that caused segfaults when building large `Integer`s was fixed in `text-1.2.0.2`. A flag (`-frecent-text`) was added that allows you to take advantage of this. +* Fixed a bug that would cause the output of functions in the `Text.Show.Text.Data.Floating` module to not match `base` depending on what version of `base` is used. +* The type signatures of lambda expressions generated by `mkShow` and related functions were loosened to allow them to be used to "manually" derive `Show` instances for data types with higher-kinded type parameters or type arguments with restricted `Show` instances. This should not be a breaking change; you can simply do more with `mkShow` et al. than you could before. For more information, see the documentation in `Text.Show.Text.TH`. +* Loosened the `Show` instance of `Complex a` to only depend on `Show a` (previously required `RealFloat a`) if using base-4.4.0.0 or later +* Moved `showbRatioPrec` to `Text.Show.Text.Data.Ratio`, `showbComplexPrec` to `Text.Show.Text.Data.Complex`, `showbProxy` to `Text.Show.Text.Data.Proxy`, and `showbFingerprint` to `Text.Show.Text.GHC.Fingerprint` +* Added `deriveShowPragmas` to `Text.Show.Text.TH` to allow users to specify `INLINE` or `SPECIALIZE instance` pragmas with `Show` instances. +* Added `FromStringShow`, `showbSpace`, `showbUnary`, `showbUnary1`, and `showbBinary1` to `Text.Show.Text` +* Added `mkShowList`, `mkShowListLazy`, and `mkShowbList` to `Text.Data.Text.TH` +* For base-4.8.0.0 and above, added the `Text.Show.Text.Data.Functor.Identity`, `Text.Show.Text.Data.Void`, `Text.Show.Text.GHC.RTS.Flags`, `Text.Show.Text.GHC.StaticPtr`, and `Text.Show.Text.Numeric.Natural` modules. Also added `Show` instances for `AllocationLimitExceeded` in `Text.Show.Text.Control.Exception` and `Alt` in `Text.Show.Text.Data.Monoid`. Also fixed the `Show` instance for `Fixed` values. +* Added the `Text.Show.Text.Data.GHC.Conc.Windows` module (Windows-only) +* Added the `Text.Show.Text.Data.OldTypeable` module for base-4.7 +* Added the `Text.Show.Text.GHC.TypeLits` module for base-4.6 and above +* Added the `Text.Show.Text.Debug.Trace` and `Text.Show.Text.Debug.Trace.TH` modules as an analog to `Debug.Trace` +* Added the `Show1` class and corresponding instances for unary type constructors. +* Added `LitChar` and `LitString` to `Text.Show.Text.Data.Char` +* Exported `asciiTabB` in `Text.Show.Text.Data.Char` +* Renamed `showbTextStrict` to 'showbText' (to keep with naming conventions in the `text` library) and added `showbBuilder` to `Text.Show.Text.Data.Text`. +## 0.4.1 +* Added the utility functions `toText` and `toString` for working with `Builder`s. + # 0.4 * Due to [GHC bug #5289](http://ghc.haskell.org/trac/ghc/ticket/5289), projects that depend on the `double-conversion` library (such as `text-format`, a dependency of `text-show`) may break due to GHC incorrectly linking against libstdc++. Therefore, `text-show` was changed so that it does not depend on `text-format` by default. This behavior can be changed by using the `-ftext-format` flag when using `cabal`. -* Add `showbZonedTime` to `Text.Show.Text.Data.Time` (and corresponding `Show` instance for `ZonedTime`) -* Expose `showbMaskingState` (is was already there, I just forgot to export it) -* If using GHC 7.6 or earlier, depend on tagged so that Data.Proxy can be used -* Refactor code to use Template Haskell derivations when possible +* Added `showbZonedTime` to `Text.Show.Text.Data.Time` (and corresponding `Show` instance for `ZonedTime`) +* Exposed `showbMaskingState` (is was already there, I just forgot to export it) +* If using GHC 7.6 or earlier, depend on tagged so that `Data.Proxy` (and thus `showbProxy` from `Text.Show.Text.Data.Typeable`) can be used +* Refactored code to use Template Haskell derivations when possible ## 0.3.1.0 -* Add `showList` and `showListLazy` -* Don't use showbListDefault to show `containers` data types -* Add the ability to splice `show` functions for arbitrary data types (even if they aren't `Show` instances). These functions are `mkShow`, `mkShowLazy`, `mkShowPrec`, `mkShowPrecLazy`, `mkShowb`, `mkShowbPrec`, `mkPrint`, `mkPrintLazy`, `mkHPrint`, and `mkHPrintLazy`. +* Added `showList` and `showListLazy` +* Don't use `showbListDefault` to show `containers` data types +* Added the ability to splice `show` functions for arbitrary data types (even if they aren't `Show` instances). These functions are `mkShow`, `mkShowLazy`, `mkShowPrec`, `mkShowPrecLazy`, `mkShowb`, `mkShowbPrec`, `mkPrint`, `mkPrintLazy`, `mkHPrint`, and `mkHPrintLazy`. # 0.3.0.0 * Lots of bugfixes -* Show instances for many other data types in `base`, `containers` and `time` -* Expose internal modules with monomorphic functions +* `Show` instances for many other data types in `base`, `containers` and `time` +* Exposed internal modules with monomorphic functions * `Text.Show.Text` now exports `Data.Text.Lazy.Builder` for convenience * Add `showLazy`, `showPrec`, `showPrecLazy`, `printLazy`, `hPrint`, `hPrintLazy`, `lengthB`, and `replicateB` * Template Haskell derivation of `Show` instances (doesn't support data families yet) # 0.2.0.0 - -* Add `Show` instances for strict and lazy `Text` +* Added `Show` instances for strict and lazy `Text` # 0.1.0.0 - * Initial commit diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,24 @@ # `text-show` [![Hackage version](https://img.shields.io/hackage/v/text-show.svg)](http://hackage.haskell.org/package/text-show) [![Build Status](https://travis-ci.org/RyanGlScott/text-show.svg)](https://travis-ci.org/RyanGlScott/text-show) -Efficient conversion of values into [`Text`](https://github.com/bos/text), in the spirit of [`bytestring-show`](http://hackage.haskell.org/package/bytestring-show). +`text-show` offers a replacement for the `Show` typeclass intended for use with `Text` instead of `String`s. This package was created in the spirit of [`bytestring-show`](http://hackage.haskell.org/package/bytestring-show). + +At the moment, `text-show` provides `Show` instances for most data types in the [`array`](http://hackage.haskell.org/package/array), [`base`](http://hackage.haskell.org/package/base), [`bytestring`](http://hackage.haskell.org/package/bytestring), and [`text`](http://hackage.haskell.org/package/text) packages. Therefore, much of the source code for `text-show` consists of borrowed code from those packages in order to ensure that the behaviors of the two `Show` typeclasses coincide. + +For most uses, simply importing `Text.Show.Text` will suffice: + +```haskell +{-# LANGUAGE NoImplicitPrelude #-} +module Main where + +import Data.Text (Text) +import Prelude hiding (Show(..), print) +import Text.Show.Text + +number :: Text +number = show (Just "Hello, World!") + +main :: IO () +main = print number +``` + +If you desire it, there are also monomorphic versions of the `showb` function available in the submodules of `Text.Show.Text`. A naming convention is present in which functions that show different values depending on the precedence end with `Prec`(e.g., `showbIntPrec`), whereas functions that show the same values regardless of precedence do not end with `Prec` (e.g., `showbBool`). diff --git a/include/inline.h b/include/inline.h new file mode 100644 --- /dev/null +++ b/include/inline.h @@ -0,0 +1,13 @@ +#ifndef INLINE_H +#define INLINE_H + +#define OPEN_PRAGMA {-# +#define CLOSE_PRAGMA #-} + +#if __GLASGOW_HASKELL__ >= 702 +#define INLINE_INST_FUN(F) OPEN_PRAGMA INLINE F CLOSE_PRAGMA +#else +#define INLINE_INST_FUN(F) +#endif + +#endif diff --git a/src/Text/Show/Text.hs b/src/Text/Show/Text.hs --- a/src/Text/Show/Text.hs +++ b/src/Text/Show/Text.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE NoImplicitPrelude #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Efficiently convert from values to 'Text' via 'Builder's. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Efficiently convert from values to 'Text' via 'Builder's. + +/Since: 0.1/ +-} module Text.Show.Text ( -- * The 'Show' class - Show (..) + Show(..) , show , showLazy , showPrec @@ -20,6 +20,11 @@ , showList , showListLazy , showbParen + , showbSpace + , showbUnary + , Show1(..) + , showbUnary1 + , showbBinary1 -- * 'Builder's , module Data.Text.Lazy.Builder , toString @@ -33,13 +38,15 @@ , printLazy , hPrint , hPrintLazy + -- * @FromStringShow@ + , FromStringShow(..) ) where import Data.Text.Lazy.Builder import Prelude hiding (Show(show, showList), print) -import Text.Show.Text.Class +import Text.Show.Text.Classes import Text.Show.Text.Instances () import Text.Show.Text.Utils (toString, toText, lengthB, replicateB, unlinesB, unwordsB) diff --git a/src/Text/Show/Text/Class.hs b/src/Text/Show/Text/Class.hs deleted file mode 100644 --- a/src/Text/Show/Text/Class.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Class --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- The 'Show' type class. ----------------------------------------------------------------------------- -module Text.Show.Text.Class where - -import Data.Text as TS (Text) -import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) -import qualified Data.Text.Lazy as TL (Text) -import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, toLazyText) - -import Prelude hiding (Show(show, showList)) - -import System.IO (Handle) - -import Text.Show.Text.Utils ((<>), s) - --- | --- Conversion of values to @Text@. Because there are both strict and lazy @Text@ --- variants, the 'Show' class deliberately avoids using @Text@ in its functions. --- Instead, 'showbPrec', 'showb', and 'showbList' all return 'Builder', an --- efficient intermediate form that can be converted to either kind of @Text@. --- --- 'Builder' is a 'Monoid', so it is useful to use the 'mappend' (or '<>') function --- to combine 'Builder's when creating 'Show' instances. As an example: --- --- @ --- import Text.Show.Text --- --- data Example = Example Int Int --- instance Show Example where --- showb (Example i1 i2) = showb i1 <> singleton ' ' <> showb i2 --- @ --- --- If you do not want to create 'Show' instances manually, you can alternatively --- use the "Text.Show.Text.TH" module to automatically generate default 'Show' --- instances using Template Haskell. -class Show a where - -- | - -- Constructs a @Text@ via an efficient 'Builder'. The precedence is used to - -- determine where to put parentheses in a shown expression involving operators. - -- - -- 'Builder's can be efficiently combined, so the @showb@ functions are available - -- for showing multiple values before producing an output @Text@. - showbPrec :: Int -> a -> Builder - - -- | - -- Constructs a @Text@ via an efficient 'Builder'. 'Builder's can be efficiently - -- combined, so this is available building a 'Text' from multiple values. - showb :: a -> Builder - - -- | - -- Allows for specialized display of lists. This is used, for example, when - -- showing lists of 'Char's. - showbList :: [a] -> Builder - - showbPrec _ = showb - - showb = showbPrec 0 - - showbList = showbListDefault showb -#if __GLASGOW_HASKELL__ >= 708 - {-# MINIMAL showbPrec | showb #-} -#endif - --- | Constructs a strict 'TS.Text' from a single value. -show :: Show a => a -> TS.Text -show = toStrict . showLazy -{-# INLINE show #-} - --- | Constructs a lazy 'TL.Text' from a single value. -showLazy :: Show a => a -> TL.Text -showLazy = toLazyText . showb -{-# INLINE showLazy #-} - --- | Constructs a strict 'TS.Text' from a single value with the given precedence. -showPrec :: Show a => Int -> a -> TS.Text -showPrec p = toStrict . showPrecLazy p -{-# INLINE showPrec #-} - --- | Constructs a lazy 'TL.Text' from a single value with the given precedence. -showPrecLazy :: Show a => Int -> a -> TL.Text -showPrecLazy p = toLazyText . showbPrec p -{-# INLINE showPrecLazy #-} - --- | Construct a strict 'TS.Text' from a list of values. -showList :: Show a => [a] -> TS.Text -showList = toStrict . showListLazy -{-# INLINE showList #-} - --- | Construct a lazy 'TL.Text' from a list of values. -showListLazy :: Show a => [a] -> TL.Text -showListLazy = toLazyText . showbList -{-# INLINE showListLazy #-} - --- | Surrounds 'Builder' output with parentheses if the 'Bool' parameter is 'True'. -showbParen :: Bool -> Builder -> Builder -showbParen p builder | p = s '(' <> builder <> s ')' - | otherwise = builder -{-# INLINE showbParen #-} - --- | --- Converts a list of values into a 'Builder' in which the values are surrounded --- by square brackets and each value is separated by a comma. This is the default --- implementation of 'showbList' save for a few special cases (e.g., 'String'). -showbListDefault :: (a -> Builder) -> [a] -> Builder -showbListDefault _ [] = "[]" -showbListDefault showbx (x:xs) = s '[' <> showbx x <> go xs -- "[.. - where - go (y:ys) = s ',' <> showbx y <> go ys -- ..,.. - go [] = s ']' -- ..]" -{-# INLINE showbListDefault #-} - --- | Writes a value's strict 'TS.Text' representation to the standard output, followed --- by a newline. -print :: Show a => a -> IO () -print = TS.putStrLn . show -{-# INLINE print #-} - --- | Writes a value's lazy 'TL.Text' representation to the standard output, followed --- by a newline. -printLazy :: Show a => a -> IO () -printLazy = TL.putStrLn . showLazy -{-# INLINE printLazy #-} - --- | Writes a value's strict 'TS.Text' representation to a file handle, followed --- by a newline. -hPrint :: Show a => Handle -> a -> IO () -hPrint h = TS.hPutStrLn h . show -{-# INLINE hPrint #-} - --- | Writes a value's lazy 'TL.Text' representation to a file handle, followed --- by a newline. -hPrintLazy :: Show a => Handle -> a -> IO () -hPrintLazy h = TL.hPutStrLn h . showLazy -{-# INLINE hPrintLazy #-} diff --git a/src/Text/Show/Text/Classes.hs b/src/Text/Show/Text/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Classes.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, + DeriveTraversable, GeneralizedNewtypeDeriving, OverloadedStrings #-} +#if MIN_VERSION_base(4,4,0) +{-# LANGUAGE DeriveGeneric #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE TypeFamilies #-} +#endif +{-| +Module: Text.Show.Text.Classes +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +The 'Show' and 'Show1' typeclasses. +-} +module Text.Show.Text.Classes where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative (Applicative((<*>), pure)) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +#endif + +import Control.Monad.Fix (MonadFix(mfix)) +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzip, mzipWith, munzip)) +#endif + +import Data.Bits (Bits) +#if MIN_VERSION_base(4,7,0) +import Data.Bits (FiniteBits) +#endif +import Data.Data (Data, Typeable) +import Data.Ix (Ix) +import Data.String (IsString) +import Data.Text as TS (Text) +import qualified Data.Text.IO as TS (putStrLn, hPutStrLn) +import qualified Data.Text.Lazy as TL (Text) +import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (Builder, fromString, toLazyText) + +import Foreign.Storable (Storable) + +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Exts (IsList(Item, fromList, toList)) +#endif +#if MIN_VERSION_base(4,4,0) +import GHC.Generics (Generic) +# if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic1) +# endif +#endif +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show(show, showList)) + +import System.IO (Handle) + +import Text.Printf (PrintfArg, PrintfType) +import qualified Text.Show as S (Show(showsPrec)) +import Text.Show.Text.Utils ((<>), s) + +#include "inline.h" + +-- | Conversion of values to @Text@. Because there are both strict and lazy @Text@ +-- variants, the 'Show' class deliberately avoids using @Text@ in its functions. +-- Instead, 'showbPrec', 'showb', and 'showbList' all return 'Builder', an +-- efficient intermediate form that can be converted to either kind of @Text@. +-- +-- 'Builder' is a 'Monoid', so it is useful to use the 'mappend' (or '<>') function +-- to combine 'Builder's when creating 'Show' instances. As an example: +-- +-- @ +-- import Text.Show.Text +-- +-- data Example = Example Int Int +-- instance Show Example where +-- showb (Example i1 i2) = showb i1 <> showbSpace <> showb i2 +-- @ +-- +-- If you do not want to create 'Show' instances manually, you can alternatively +-- use the "Text.Show.Text.TH" module to automatically generate default 'Show' +-- instances using Template Haskell. +-- +-- /Since: 0.1/ +class Show a where + -- | Convert a value to a 'Builder' with the given predence. + -- + -- /Since: 0.1/ + 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'. + -> Builder + + -- | A specialized variant of 'showbPrec' using precedence context zero. + -- + -- /Since: 0.1/ + showb :: a -> Builder + + -- | Allows for specialized display of lists. This is used, for example, when + -- showing lists of 'Char's. + -- + -- /Since: 0.1/ + showbList :: [a] -> Builder + + showbPrec _ = showb + + showb = showbPrec 0 + + showbList = showbListDefault showb +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL showbPrec | showb #-} +#endif + +-- | Lifting of the 'Show' class to unary type constructors. +-- +-- /Since: 0.5/ +class Show1 f where + -- | 'Builder' conversion for values of a type that has a unary type constructor. + -- + -- /Since: 0.5/ + showbPrec1 :: Show a => Int -> f a -> Builder + +-- | Constructs a strict 'TS.Text' from a single value. +-- +-- /Since: 0.1/ +show :: Show a => a -> TS.Text +show = toStrict . showLazy +{-# INLINE show #-} + +-- | Constructs a lazy 'TL.Text' from a single value. +-- +-- /Since: 0.3/ +showLazy :: Show a => a -> TL.Text +showLazy = toLazyText . showb +{-# INLINE showLazy #-} + +-- | Constructs a strict 'TS.Text' from a single value with the given precedence. +-- +-- /Since: 0.3/ +showPrec :: Show a => Int -> a -> TS.Text +showPrec p = toStrict . showPrecLazy p +{-# INLINE showPrec #-} + +-- | Constructs a lazy 'TL.Text' from a single value with the given precedence. +-- +-- /Since: 0.3/ +showPrecLazy :: Show a => Int -> a -> TL.Text +showPrecLazy p = toLazyText . showbPrec p +{-# INLINE showPrecLazy #-} + +-- | Construct a strict 'TS.Text' from a list of values. +-- +-- /Since: 0.3.1/ +showList :: Show a => [a] -> TS.Text +showList = toStrict . showListLazy +{-# INLINE showList #-} + +-- | Construct a lazy 'TL.Text' from a list of values. +-- +-- /Since: 0.3.1/ +showListLazy :: Show a => [a] -> TL.Text +showListLazy = toLazyText . showbList +{-# INLINE showListLazy #-} + +-- | Surrounds 'Builder' output with parentheses if the 'Bool' parameter is 'True'. +-- +-- /Since: 0.1/ +showbParen :: Bool -> Builder -> Builder +showbParen p builder | p = s '(' <> builder <> s ')' + | otherwise = builder +{-# INLINE showbParen #-} + +-- | Construct a 'Builder' containing a single space character. +-- +-- /Since: 0.5/ +showbSpace :: Builder +showbSpace = s ' ' +{-# INLINE showbSpace #-} + +-- | Converts a list of values into a 'Builder' in which the values are surrounded +-- by square brackets and each value is separated by a comma. This is the default +-- implementation of 'showbList' save for a few special cases (e.g., 'String'). +-- +-- /Since: 0.3/ +showbListDefault :: (a -> Builder) -> [a] -> Builder +showbListDefault _ [] = "[]" +showbListDefault showbx (x:xs) = s '[' <> showbx x <> go xs -- "[.. + where + go (y:ys) = s ',' <> showbx y <> go ys -- ..,.. + go [] = s ']' -- ..]" +{-# INLINE showbListDefault #-} + +-- | @'showbUnary' n p x@ produces the 'Builder' representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @p@. +-- +-- /Since: 0.5/ +showbUnary :: Show a => Builder -> Int -> a -> Builder +showbUnary nameB p x = showbParen (p > appPrec) $ + nameB <> showbSpace <> showbPrec appPrec1 x +{-# INLINE showbUnary #-} + +-- | @'showbUnary1' n p x@ produces the 'Builder' representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @p@. +-- +-- /Since: 0.5/ +showbUnary1 :: (Show1 f, Show a) => Builder -> Int -> f a -> Builder +showbUnary1 nameB p x = showbParen (p > appPrec) $ + nameB <> showbSpace <> showbPrec1 appPrec1 x +{-# INLINE showbUnary1 #-} + +-- | @'showbBinary1' n p x y@ produces the 'Builder' representation of a binary +-- data constructor with name @n@ and arguments @x@ and @y@, in precedence +-- context @p@. +-- +-- /Since: 0.5/ +showbBinary1 :: (Show1 f, Show1 g, Show a) => Builder -> Int -> f a -> g a -> Builder +showbBinary1 nameB p x y = showbParen (p > appPrec) $ nameB + <> showbSpace <> showbPrec1 appPrec1 x + <> showbSpace <> showbPrec1 appPrec1 y +{-# INLINE showbBinary1 #-} + +-- | Writes a value's strict 'TS.Text' representation to the standard output, followed +-- by a newline. +-- +-- /Since: 0.1/ +print :: Show a => a -> IO () +print = TS.putStrLn . show +{-# INLINE print #-} + +-- | Writes a value's lazy 'TL.Text' representation to the standard output, followed +-- by a newline. +-- +-- /Since: 0.3/ +printLazy :: Show a => a -> IO () +printLazy = TL.putStrLn . showLazy +{-# INLINE printLazy #-} + +-- | Writes a value's strict 'TS.Text' representation to a file handle, followed +-- by a newline. +-- +-- /Since: 0.3/ +hPrint :: Show a => Handle -> a -> IO () +hPrint h = TS.hPutStrLn h . show +{-# INLINE hPrint #-} + +-- | Writes a value's lazy 'TL.Text' representation to a file handle, followed +-- by a newline. +-- +-- /Since: 0.3/ +hPrintLazy :: Show a => Handle -> a -> IO () +hPrintLazy h = TL.hPutStrLn h . showLazy +{-# INLINE hPrintLazy #-} + +-- | The @Text@ 'T.Show' instance for 'FromStringShow' is based on its @String@ +-- 'S.Show' instance. That is, +-- +-- @ +-- showbPrec p ('FromStringShow' x) = 'fromString' (showsPrec p x "") +-- @ +-- +-- /Since: 0.5/ +newtype FromStringShow a = FromStringShow { fromStringShow :: a } + deriving ( Bits + , Bounded + , Data + , Enum + , Eq +#if MIN_VERSION_base(4,7,0) + , FiniteBits +#endif + , Floating + , Foldable + , Fractional + , Functor +#if MIN_VERSION_base(4,4,0) + , Generic +# if __GLASGOW_HASKELL__ >= 706 + , Generic1 +# endif +#endif + , Integral + , IsString + , Ix + , Num + , Ord + , PrintfArg + , PrintfType + , Read + , Real + , RealFloat + , RealFrac + , S.Show + , Storable + , Traversable + , Typeable + ) + +instance Applicative FromStringShow where + pure = FromStringShow + INLINE_INST_FUN(pure) + + FromStringShow f <*> FromStringShow x = FromStringShow $ f x + INLINE_INST_FUN((<*>)) + +#if __GLASGOW_HASKELL__ >= 708 +instance IsList a => IsList (FromStringShow a) where + type Item (FromStringShow a) = Item a + fromList = FromStringShow . fromList + {-# INLINE fromList #-} + toList = toList . fromStringShow + {-# INLINE toList #-} +#endif + +instance Monad FromStringShow where + return = FromStringShow + INLINE_INST_FUN(return) + + FromStringShow a >>= f = f a + INLINE_INST_FUN((>>=)) + +instance MonadFix FromStringShow where + mfix f = FromStringShow $ let FromStringShow a = f a in a + INLINE_INST_FUN(mfix) + +#if MIN_VERSION_base(4,4,0) +instance MonadZip FromStringShow where + mzip (FromStringShow a) (FromStringShow b) = FromStringShow (a, b) + INLINE_INST_FUN(mzip) + + mzipWith f (FromStringShow a) (FromStringShow b) = FromStringShow $ f a b + INLINE_INST_FUN(mzipWith) + + munzip (FromStringShow (a, b)) = (FromStringShow a, FromStringShow b) + INLINE_INST_FUN(munzip) +#endif + +instance S.Show a => Show (FromStringShow a) where + showbPrec p (FromStringShow x) = fromString $ S.showsPrec p x "" + INLINE_INST_FUN(showbPrec) diff --git a/src/Text/Show/Text/Control.hs b/src/Text/Show/Text/Control.hs --- a/src/Text/Show/Text/Control.hs +++ b/src/Text/Show/Text/Control.hs @@ -1,14 +1,13 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Control --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' instances for @Control@ modules. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Control +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Control@ modules. +-} module Text.Show.Text.Control () where import Text.Show.Text.Control.Applicative () diff --git a/src/Text/Show/Text/Control/Applicative.hs b/src/Text/Show/Text/Control/Applicative.hs --- a/src/Text/Show/Text/Control/Applicative.hs +++ b/src/Text/Show/Text/Control/Applicative.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Control.Applicative --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'ZipList'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Control.Applicative +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'ZipList'. + +/Since: 0.3/ +-} module Text.Show.Text.Control.Applicative (showbZipListPrec) where import Control.Applicative (ZipList) @@ -19,13 +20,21 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec)) +import Text.Show.Text.Classes (Show(showbPrec), Show1(showbPrec1)) import Text.Show.Text.Data.List () -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +#include "inline.h" + -- | Convert a 'ZipList' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbZipListPrec :: Show a => Int -> ZipList a -> Builder showbZipListPrec = showbPrec {-# INLINE showbZipListPrec #-} -$(deriveShow ''ZipList) +$(deriveShowPragmas defaultInlineShowbPrec ''ZipList) + +instance Show1 ZipList where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Control/Concurrent.hs b/src/Text/Show/Text/Control/Concurrent.hs --- a/src/Text/Show/Text/Control/Concurrent.hs +++ b/src/Text/Show/Text/Control/Concurrent.hs @@ -1,50 +1,59 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Control.Concurrent --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for concurrency-related data types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Control.Concurrent +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for concurrency-related data types. + +/Since: 0.3/ +-} module Text.Show.Text.Control.Concurrent ( showbThreadIdPrec , showbThreadStatusPrec , showbBlockReason ) where -import Data.Text.Lazy.Builder (Builder, fromString) +import Data.Text.Lazy.Builder (Builder) -import GHC.Conc (BlockReason, ThreadId, ThreadStatus) +import GHC.Conc (BlockReason, ThreadId, ThreadStatus) -import qualified Prelude as P -import Prelude hiding (Show) +import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec)) -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.Classes (Show(showb, showbPrec), FromStringShow(..)) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb, + defaultInlineShowbPrec) +#include "inline.h" + -- | Convert a 'ThreadId' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbThreadIdPrec :: Int -> ThreadId -> Builder -showbThreadIdPrec p ti = fromString $ P.showsPrec p ti "" +showbThreadIdPrec p = showbPrec p . FromStringShow {-# INLINE showbThreadIdPrec #-} -- | Convert a 'ThreadStatus' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbThreadStatusPrec :: Int -> ThreadStatus -> Builder showbThreadStatusPrec = showbPrec {-# INLINE showbThreadStatusPrec #-} -- | Convert a 'BlockReason' to a 'Builder'. +-- +-- /Since: 0.3/ showbBlockReason :: BlockReason -> Builder showbBlockReason = showb {-# INLINE showbBlockReason #-} instance Show ThreadId where showbPrec = showbThreadIdPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) -$(deriveShow ''ThreadStatus) -$(deriveShow ''BlockReason) +$(deriveShowPragmas defaultInlineShowbPrec ''ThreadStatus) +$(deriveShowPragmas defaultInlineShowb ''BlockReason) diff --git a/src/Text/Show/Text/Control/Exception.hs b/src/Text/Show/Text/Control/Exception.hs --- a/src/Text/Show/Text/Control/Exception.hs +++ b/src/Text/Show/Text/Control/Exception.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Monoid --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'Exception's. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Control.Exception +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'Exception's. + +/Since: 0.3/ +-} module Text.Show.Text.Control.Exception ( showbSomeExceptionPrec , showbIOException @@ -25,6 +26,9 @@ , showbNestedAtomically , showbBlockedIndefinitelyOnMVar , showbBlockedIndefinitelyOnSTM +#if MIN_VERSION_base(4,8,0) + , showbAllocationLimitExceeded +#endif , showbDeadlock , showbNoMethodError , showbPatternMatchFail @@ -35,29 +39,38 @@ , showbMaskingState ) where -import Control.Exception.Base +import Control.Exception.Base -import Data.Monoid (mempty) -import Data.Text.Lazy.Builder (Builder, fromString) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mempty) +#endif +import Data.Text.Lazy.Builder (Builder, fromString) -import qualified Prelude as P -import Prelude hiding (Show) +import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec)) -import Text.Show.Text.TH.Internal (deriveShow) -import Text.Show.Text.Utils ((<>)) +import Text.Show.Text.Classes (Show(showb, showbPrec), FromStringShow(..)) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) +import Text.Show.Text.Utils ((<>)) +#include "inline.h" + -- | Convert a 'SomeException' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbSomeExceptionPrec :: Int -> SomeException -> Builder -showbSomeExceptionPrec p (SomeException e) = fromString $ P.showsPrec p e "" +showbSomeExceptionPrec p (SomeException e) = showbPrec p $ FromStringShow e {-# INLINE showbSomeExceptionPrec #-} -- | Convert an 'IOException' to a 'Builder'. +-- +-- /Since: 0.3/ showbIOException :: IOException -> Builder -showbIOException = fromString . show +showbIOException = showb . FromStringShow {-# INLINE showbIOException #-} -- | Convert an 'ArithException' to a 'Builder'. +-- +-- /Since: 0.3/ showbArithException :: ArithException -> Builder showbArithException Overflow = "arithmetic overflow" showbArithException Underflow = "arithmetic underflow" @@ -70,6 +83,8 @@ {-# INLINE showbArithException #-} -- | Convert an 'ArrayException' to a 'Builder'. +-- +-- /Since: 0.3/ showbArrayException :: ArrayException -> Builder showbArrayException (IndexOutOfBounds s) = "array index out of range" @@ -82,18 +97,25 @@ {-# INLINE showbArrayException #-} -- | Convert an 'AssertionFailed' exception to a 'Builder'. +-- +-- /Since: 0.3/ showbAssertionFailed :: AssertionFailed -> Builder showbAssertionFailed (AssertionFailed err) = fromString err {-# INLINE showbAssertionFailed #-} #if MIN_VERSION_base(4,7,0) -- | Convert a 'SomeAsyncException' value to a 'Builder'. +-- This function is only available with @base-4.7.0.0@ or later. +-- +-- /Since: 0.3/ showbSomeAsyncException :: SomeAsyncException -> Builder -showbSomeAsyncException (SomeAsyncException e) = fromString $ P.show e +showbSomeAsyncException (SomeAsyncException e) = showb $ FromStringShow e {-# INLINE showbSomeAsyncException #-} #endif -- | Convert an 'AsyncException' to a 'Builder'. +-- +-- /Since: 0.3/ showbAsyncException :: AsyncException -> Builder showbAsyncException StackOverflow = "stack overflow" showbAsyncException HeapOverflow = "heap overflow" @@ -102,84 +124,118 @@ {-# INLINE showbAsyncException #-} -- | Convert a 'NonTermination' exception to a 'Builder'. +-- +-- /Since: 0.3/ showbNonTermination :: NonTermination -> Builder showbNonTermination NonTermination = "<>" {-# INLINE showbNonTermination #-} -- | Convert a 'NestedAtomically' exception to a 'Builder'. +-- +-- /Since: 0.3/ showbNestedAtomically :: NestedAtomically -> Builder showbNestedAtomically NestedAtomically = "Control.Concurrent.STM.atomically was nested" {-# INLINE showbNestedAtomically #-} -- | Convert a 'BlockedIndefinitelyOnMVar' exception to a 'Builder'. +-- +-- /Since: 0.3/ showbBlockedIndefinitelyOnMVar :: BlockedIndefinitelyOnMVar -> Builder showbBlockedIndefinitelyOnMVar BlockedIndefinitelyOnMVar = "thread blocked indefinitely in an MVar operation" {-# INLINE showbBlockedIndefinitelyOnMVar #-} -- | Convert a 'BlockedIndefinitelyOnSTM' exception to a 'Builder'. +-- +-- /Since: 0.3/ showbBlockedIndefinitelyOnSTM :: BlockedIndefinitelyOnSTM -> Builder showbBlockedIndefinitelyOnSTM BlockedIndefinitelyOnSTM = "thread blocked indefinitely in an STM transaction" {-# INLINE showbBlockedIndefinitelyOnSTM #-} +#if MIN_VERSION_base(4,8,0) +-- | Convert an 'AllocationLimitExceeded' exception to a 'Builder'. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbAllocationLimitExceeded :: AllocationLimitExceeded -> Builder +showbAllocationLimitExceeded AllocationLimitExceeded = "allocation limit exceeded" +{-# INLINE showbAllocationLimitExceeded #-} +#endif + -- | Convert a 'Deadlock' exception to a 'Builder'. +-- +-- /Since: 0.3/ showbDeadlock :: Deadlock -> Builder showbDeadlock Deadlock = "<>" {-# INLINE showbDeadlock #-} -- | Convert a 'NoMethodError' to a 'Builder'. +-- +-- /Since: 0.3/ showbNoMethodError :: NoMethodError -> Builder showbNoMethodError (NoMethodError err) = fromString err {-# INLINE showbNoMethodError #-} -- | Convert a 'PatternMatchFail' to a 'Builder'. +-- +-- /Since: 0.3/ showbPatternMatchFail :: PatternMatchFail -> Builder showbPatternMatchFail (PatternMatchFail err) = fromString err {-# INLINE showbPatternMatchFail #-} -- | Convert a 'RecConError' to a 'Builder'. +-- +-- /Since: 0.3/ showbRecConError :: RecConError -> Builder showbRecConError (RecConError err) = fromString err {-# INLINE showbRecConError #-} -- | Convert a 'RecSelError' to a 'Builder'. +-- +-- /Since: 0.3/ showbRecSelError :: RecSelError -> Builder showbRecSelError (RecSelError err) = fromString err {-# INLINE showbRecSelError #-} -- | Convert a 'RecUpdError' to a 'Builder'. +-- +-- /Since: 0.3/ showbRecUpdError :: RecUpdError -> Builder showbRecUpdError (RecUpdError err) = fromString err {-# INLINE showbRecUpdError #-} -- | Convert an 'ErrorCall' to a 'Builder'. +-- +-- /Since: 0.3/ showbErrorCall :: ErrorCall -> Builder showbErrorCall (ErrorCall err) = fromString err {-# INLINE showbErrorCall #-} -- | Convert a 'MaskingState' to a 'Builder'. +-- +-- /Since: 0.4/ showbMaskingState :: MaskingState -> Builder showbMaskingState = showb {-# INLINE showbMaskingState #-} instance Show SomeException where showbPrec = showbSomeExceptionPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show IOException where showb = showbIOException - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show ArithException where showb = showbArithException - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show ArrayException where showb = showbArrayException - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show AssertionFailed where showb = showbAssertionFailed - {-# INLINE showb #-} + INLINE_INST_FUN(showb) #if MIN_VERSION_base(4,7,0) instance Show SomeAsyncException where @@ -189,50 +245,56 @@ instance Show AsyncException where showb = showbAsyncException - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show NonTermination where showb = showbNonTermination - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show NestedAtomically where showb = showbNestedAtomically - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show BlockedIndefinitelyOnMVar where showb = showbBlockedIndefinitelyOnMVar - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show BlockedIndefinitelyOnSTM where showb = showbBlockedIndefinitelyOnSTM + INLINE_INST_FUN(showb) + +#if MIN_VERSION_base(4,8,0) +instance Show AllocationLimitExceeded where + showb = showbAllocationLimitExceeded {-# INLINE showb #-} +#endif instance Show Deadlock where showb = showbDeadlock - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show NoMethodError where showb = showbNoMethodError - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show PatternMatchFail where showb = showbPatternMatchFail - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show RecConError where showb = showbRecConError - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show RecSelError where showb = showbRecSelError - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show RecUpdError where showb = showbRecUpdError - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show ErrorCall where showb = showbErrorCall - {-# INLINE showb #-} + INLINE_INST_FUN(showb) -$(deriveShow ''MaskingState) +$(deriveShowPragmas defaultInlineShowb ''MaskingState) diff --git a/src/Text/Show/Text/Control/Monad/ST.hs b/src/Text/Show/Text/Control/Monad/ST.hs --- a/src/Text/Show/Text/Control/Monad/ST.hs +++ b/src/Text/Show/Text/Control/Monad/ST.hs @@ -1,28 +1,37 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Control.Monad.ST --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for strict 'ST' values. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Control.Monad.ST +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for strict 'ST' values. + +/Since: 0.3/ +-} module Text.Show.Text.Control.Monad.ST (showbST) where import Control.Monad.ST (ST) import Data.Text.Lazy.Builder (Builder) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +#include "inline.h" + -- | Convert a strict 'ST' value to a 'Builder'. +-- +-- /Since: 0.3/ showbST :: ST s a -> Builder showbST _ = "<>" {-# INLINE showbST #-} instance Show (ST s a) where showb = showbST - {-# INLINE showb #-} + INLINE_INST_FUN(showb) + +instance Show1 (ST s) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data.hs b/src/Text/Show/Text/Data.hs --- a/src/Text/Show/Text/Data.hs +++ b/src/Text/Show/Text/Data.hs @@ -1,38 +1,43 @@ {-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' instances for @Data@ modules. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Data@ modules. +-} module Text.Show.Text.Data () where -import Text.Show.Text.Data.Array () -import Text.Show.Text.Data.Bool () -import Text.Show.Text.Data.ByteString () -import Text.Show.Text.Data.Char () -import Text.Show.Text.Data.Containers () -import Text.Show.Text.Data.Data () -import Text.Show.Text.Data.Dynamic () -import Text.Show.Text.Data.Either () -import Text.Show.Text.Data.Fixed () -import Text.Show.Text.Data.Floating () -import Text.Show.Text.Data.Integral () -import Text.Show.Text.Data.List () -import Text.Show.Text.Data.Maybe () -import Text.Show.Text.Data.Monoid () -import Text.Show.Text.Data.Ord () -import Text.Show.Text.Data.Text () -import Text.Show.Text.Data.Time () -import Text.Show.Text.Data.Tuple () +import Text.Show.Text.Data.Array () +import Text.Show.Text.Data.Bool () +import Text.Show.Text.Data.ByteString () +import Text.Show.Text.Data.Char () +import Text.Show.Text.Data.Complex () +import Text.Show.Text.Data.Data () +import Text.Show.Text.Data.Dynamic () +import Text.Show.Text.Data.Either () +import Text.Show.Text.Data.Fixed () +import Text.Show.Text.Data.Floating () +import Text.Show.Text.Data.Functor.Identity () +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.List () +import Text.Show.Text.Data.Maybe () +import Text.Show.Text.Data.Monoid () +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) +import Text.Show.Text.Data.OldTypeable () +#endif +import Text.Show.Text.Data.Ord () +import Text.Show.Text.Data.Proxy () +import Text.Show.Text.Data.Ratio () +import Text.Show.Text.Data.Text () +import Text.Show.Text.Data.Tuple () #if MIN_VERSION_base(4,7,0) -import Text.Show.Text.Data.Type.Coercion () -import Text.Show.Text.Data.Type.Equality () +import Text.Show.Text.Data.Type.Coercion () +import Text.Show.Text.Data.Type.Equality () #endif -import Text.Show.Text.Data.Typeable () -import Text.Show.Text.Data.Version () +import Text.Show.Text.Data.Typeable () +import Text.Show.Text.Data.Version () +import Text.Show.Text.Data.Void () diff --git a/src/Text/Show/Text/Data/Array.hs b/src/Text/Show/Text/Data/Array.hs --- a/src/Text/Show/Text/Data/Array.hs +++ b/src/Text/Show/Text/Data/Array.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Array --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Array' values. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Array +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Array' values. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Array (showbArrayPrec) where import Data.Array (Array, assocs, bounds) @@ -21,20 +22,24 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Classes (Show(showb, showbPrec), showbParen, showbSpace) import Text.Show.Text.Data.List () import Text.Show.Text.Data.Tuple () -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Utils ((<>)) +#include "inline.h" + -- | Convert a 'Array' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbArrayPrec :: (Show i, Show e, Ix i) => Int -> Array i e -> Builder showbArrayPrec p a = showbParen (p > appPrec) $ "array " <> showb (bounds a) - <> s ' ' + <> showbSpace <> showb (assocs a) {-# INLINE showbArrayPrec #-} instance (Show i, Show e, Ix i) => Show (Array i e) where showbPrec = showbArrayPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) diff --git a/src/Text/Show/Text/Data/Bool.hs b/src/Text/Show/Text/Data/Bool.hs --- a/src/Text/Show/Text/Data/Bool.hs +++ b/src/Text/Show/Text/Data/Bool.hs @@ -1,26 +1,29 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Bool --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'Bool' values. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Bool +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Bool' values. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Bool (showbBool) where import Data.Text.Lazy.Builder (Builder) -import Text.Show.Text.Class (showb) -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.Classes (showb) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) -- | Convert a 'Bool' to a 'Builder'. +-- +-- /Since: 0.3/ showbBool :: Bool -> Builder showbBool = showb {-# INLINE showbBool #-} -$(deriveShow ''Bool) +$(deriveShowPragmas defaultInlineShowb ''Bool) diff --git a/src/Text/Show/Text/Data/ByteString.hs b/src/Text/Show/Text/Data/ByteString.hs --- a/src/Text/Show/Text/Data/ByteString.hs +++ b/src/Text/Show/Text/Data/ByteString.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} #if !(MIN_VERSION_bytestring(0,10,0)) {-# LANGUAGE TemplateHaskell #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Foreign.Data.ByteString --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for data types in the @bytestring@ library. --- These are included for convenience (and because @bytestring@ is a --- dependency of this library). ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.ByteString +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @bytestring@ library. + +/Since: 0.3/ +-} module Text.Show.Text.Data.ByteString ( showbByteStringStrict , showbByteStringLazy @@ -30,23 +29,28 @@ #if MIN_VERSION_bytestring(0,10,4) import Data.ByteString.Short (ShortByteString) #endif -import Data.Text.Lazy.Builder (Builder, fromString) +import Data.Text.Lazy.Builder (Builder) -import qualified Prelude as P import Prelude hiding (Show(show)) -import Text.Show.Text.Class (Show(showb, showbPrec)) +import Text.Show.Text.Classes (Show(showb, showbPrec), FromStringShow(..)) #if !(MIN_VERSION_bytestring(0,10,0)) -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) #endif +#include "inline.h" + -- | Convert a strict 'BS.ByteString' to a 'Builder'. +-- +-- /Since: 0.3/ showbByteStringStrict :: BS.ByteString -> Builder -showbByteStringStrict = fromString . P.show +showbByteStringStrict = showb . FromStringShow {-# INLINE showbByteStringStrict #-} -- | Convert a lazy 'BL.ByteString' to a 'Builder'. +-- +-- /Since: 0.3/ showbByteStringLazy :: BL.ByteString -> Builder showbByteStringLazy = showbByteStringLazyPrec 0 {-# INLINE showbByteStringLazy #-} @@ -58,9 +62,11 @@ -- On earlier versions of @bytestring@, however, lazy 'BL.ByteString's can be printed -- with parentheses (e.g., @Chunk "example" Empty@ vs. @(Chunk "example" Empty)@) -- depending on the precedence. +-- +-- /Since: 0.3/ showbByteStringLazyPrec :: Int -> BL.ByteString -> Builder #if MIN_VERSION_bytestring(0,10,0) -showbByteStringLazyPrec _ = fromString . P.show +showbByteStringLazyPrec _ = showb . FromStringShow #else showbByteStringLazyPrec = showbPrec #endif @@ -68,25 +74,28 @@ #if MIN_VERSION_bytestring(0,10,4) -- | Convert a 'ShortByteString' to a 'Builder'. +-- This function is only available with @bytestring-0.10.4.0@ or later. +-- +-- /Since: 0.3/ showbShortByteString :: ShortByteString -> Builder -showbShortByteString = fromString . P.show +showbShortByteString = showb . FromStringShow {-# INLINE showbShortByteString #-} #endif instance Show BS.ByteString where showb = showbByteStringStrict - {-# INLINE showb #-} + INLINE_INST_FUN(showb) #if MIN_VERSION_bytestring(0,10,0) instance Show BL.ByteString where showbPrec = showbByteStringLazyPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) #else -$(deriveShow ''BL.ByteString) +$(deriveShowPragmas defaultInlineShowbPrec ''BL.ByteString) #endif #if MIN_VERSION_bytestring(0,10,4) instance Show ShortByteString where showb = showbShortByteString - {-# INLINE showb #-} + INLINE_INST_FUN(showb) #endif diff --git a/src/Text/Show/Text/Data/Char.hs b/src/Text/Show/Text/Data/Char.hs --- a/src/Text/Show/Text/Data/Char.hs +++ b/src/Text/Show/Text/Data/Char.hs @@ -1,37 +1,68 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, + OverloadedStrings, TemplateHaskell #-} +#if MIN_VERSION_base(4,4,0) +{-# LANGUAGE DeriveGeneric #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE TypeFamilies #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Char --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'Char' and 'String'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Char +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'Char' and 'String'. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Char ( showbChar , showbLitChar , showbString , showbLitString , showbGeneralCategory + , asciiTabB + , LitChar(..) + , LitString(..) ) where -import Data.Array (Array, (!), listArray) -import Data.Char (GeneralCategory, isDigit, ord) -import Data.Monoid (mempty) -import Data.Text.Lazy.Builder (Builder) +import Data.Array (Array, (!), listArray) +import Data.Char (GeneralCategory, isDigit, ord) +import Data.Data (Data, Typeable) +import Data.Ix (Ix) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid(mempty)) +#endif +import Data.String (IsString) +import Data.Text.Lazy.Builder (Builder) -import Prelude hiding (Show) +import Foreign.Storable (Storable) -import Text.Show.Text.Class (Show(..)) -import Text.Show.Text.Data.Integral (showbIntPrec) -import Text.Show.Text.TH.Internal (deriveShow) -import Text.Show.Text.Utils ((<>), s) +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Exts (IsList(Item, fromList, toList)) +#endif +#if MIN_VERSION_base(4,4,0) +import GHC.Generics (Generic) +#endif +import Prelude hiding (Show) + +import Text.Printf (PrintfArg, PrintfType) +import qualified Text.Show as S (Show) +import Text.Show.Text.Classes (Show(..)) +import Text.Show.Text.Data.Integral (showbIntPrec) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) +import Text.Show.Text.Utils ((<>), s) + +#include "inline.h" + -- | A table of ASCII control characters that needs to be escaped with a backslash. +-- +-- /Since: 0.5/ asciiTabB :: Array Int Builder asciiTabB = listArray (0, 32) ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", @@ -40,12 +71,16 @@ "SP"] -- | Convert a 'Char' to a 'Builder' (surrounded by single quotes). +-- +-- /Since: 0.3/ showbChar :: Char -> Builder showbChar '\'' = "'\\''" showbChar c = s '\'' <> showbLitChar c <> s '\'' {-# INLINE showbChar #-} -- | Convert a 'Char' to a 'Builder' (without single quotes). +-- +-- /Since: 0.3/ showbLitChar :: Char -> Builder showbLitChar c | c > '\DEL' = s '\\' <> showbIntPrec 0 (ord c) showbLitChar '\DEL' = "\\DEL" @@ -63,11 +98,15 @@ {-# INLINE showbLitChar #-} -- | Convert a 'String' to a 'Builder' (surrounded by double quotes). +-- +-- /Since: 0.3/ showbString :: String -> Builder showbString cs = s '"' <> showbLitString cs <> s '"' {-# INLINE showbString #-} -- | Convert a 'String' to a 'Builder' (without double quotes). +-- +-- /Since: 0.3/ showbLitString :: String -> Builder showbLitString [] = mempty showbLitString ('\SO':'H':cs) = "\\SO\\&H" <> showbLitString cs @@ -78,15 +117,83 @@ {-# INLINE showbLitString #-} -- | Convert a 'GeneralCategory' to a 'Builder'. +-- +-- /Since: 0.3/ showbGeneralCategory :: GeneralCategory -> Builder showbGeneralCategory = showb {-# INLINE showbGeneralCategory #-} instance Show Char where showb = showbChar - {-# INLINE showb #-} + INLINE_INST_FUN(showb) showbList = showbString - {-# INLINE showbList #-} + INLINE_INST_FUN(showbList) -$(deriveShow ''GeneralCategory) +$(deriveShowPragmas defaultInlineShowb ''GeneralCategory) + +-- | The @Text@ 'T.Show' instance for 'LitChar' is like that of a regular 'Char', +-- except it is not escaped by single quotes. That is, +-- +-- @ +-- showb ('LitChar' c) = 'showbLitChar' c +-- @ +-- +-- /Since: 0.5/ +newtype LitChar = LitChar { getLitChar :: Char } + deriving ( Bounded + , Data + , Enum + , Eq +#if MIN_VERSION_base(4,4,0) + , Generic +#endif + , Ix + , Ord + , PrintfArg + , Read + , S.Show + , Storable + , Typeable + ) + +instance Show LitChar where + showb = showbLitChar . getLitChar + INLINE_INST_FUN(showb) + +-- | The @Text@ 'T.Show' instance for 'LitString' is like that of a regular +-- 'String', except it is not escaped by double quotes. That is, +-- +-- @ +-- showb ('LitString' s) = 'showbLitString' s +-- @ +-- +-- /Since: 0.5/ +newtype LitString = LitString { getLitString :: String } + deriving ( Data + , Eq +#if MIN_VERSION_base(4,4,0) + , Generic +#endif + , IsString + , Monoid + , Ord + , PrintfArg + , PrintfType + , Read + , S.Show + , Typeable + ) + +#if __GLASGOW_HASKELL__ >= 708 +instance IsList LitString where + type Item LitString = Char + fromList = LitString + {-# INLINE fromList #-} + toList = getLitString + {-# INLINE toList #-} +#endif + +instance Show LitString where + showb = showbLitString . getLitString + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Complex.hs b/src/Text/Show/Text/Data/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Complex.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Ratio +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Ratio' values. + +/Since: 0.5/ +-} +module Text.Show.Text.Data.Complex (showbComplexPrec) where + +import Data.Complex (Complex) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showbPrec)) +import Text.Show.Text.Data.Floating () +#if MIN_VERSION_base(4,4,0) +import Text.Show.Text.Classes (Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec, + specializeTypes) +#else +import Text.Show.Text.TH.Internal (mkShowbPrec) +#endif + +#include "inline.h" + +-- | Convert a 'Complex' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.5/ +#if MIN_VERSION_base(4,4,0) +showbComplexPrec :: Show a +#else +showbComplexPrec :: (RealFloat a, Show a) +#endif + => Int + -> Complex a + -> Builder +showbComplexPrec = showbPrec +{-# INLINE showbComplexPrec #-} + +#if MIN_VERSION_base(4,4,0) +$(deriveShowPragmas defaultInlineShowbPrec { + specializeTypes = [ [t| Complex Float |] + , [t| Complex Double |] + ] + } + ''Complex) + +instance Show1 Complex where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) +#else +instance (RealFloat a, Show a) => Show (Complex a) where + {-# SPECIALIZE instance Show (Complex Float) #-} + {-# SPECIALIZE instance Show (Complex Double) #-} + showbPrec = $(mkShowbPrec ''Complex) + INLINE_INST_FUN(showbPrec) +#endif diff --git a/src/Text/Show/Text/Data/Containers.hs b/src/Text/Show/Text/Data/Containers.hs deleted file mode 100644 --- a/src/Text/Show/Text/Data/Containers.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, TemplateHaskell #-} -{-# OPTIONS -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Containers --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for data types in the @containers@ library. --- These are included for convenience (and because @containers@ is a --- dependency of this library). ----------------------------------------------------------------------------- -module Text.Show.Text.Data.Containers ( - showbIntMapPrec - , showbIntSetPrec - , showbMapPrec - , showbSequencePrec - , showbSetPrec - , showbTreePrec - ) where - -import qualified Data.Foldable as F -import Data.Text.Lazy.Builder (Builder) - -import qualified Data.IntMap as IM -import Data.IntMap (IntMap) -import qualified Data.IntSet as IS -import Data.IntSet (IntSet) -import qualified Data.Map as M -import Data.Map (Map) -import Data.Sequence (Seq) -import qualified Data.Set as Set -import Data.Set (Set) -import Data.Tree (Tree) - -import GHC.Show (appPrec) - -import Prelude hiding (Show) - -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) -import Text.Show.Text.Data.Integral () -import Text.Show.Text.Data.List () -import Text.Show.Text.Data.Tuple () -import Text.Show.Text.TH.Internal (deriveShow) -import Text.Show.Text.Utils ((<>)) - --- | Convert an 'IntMap' into a 'Builder' with the given precedence. -showbIntMapPrec :: Show v => Int -> IntMap v -> Builder -showbIntMapPrec p im - = showbParen (p > appPrec) $ "fromList " <> showb (IM.toList im) -{-# INLINE showbIntMapPrec #-} - --- | Convert an 'IntSet' into a 'Builder' with the given precedence. -showbIntSetPrec :: Int -> IntSet -> Builder -showbIntSetPrec p is - = showbParen (p > appPrec) $ "fromList " <> showb (IS.toList is) -{-# INLINE showbIntSetPrec #-} - --- | Convert a 'Map' into a 'Builder' with the given precedence. -showbMapPrec :: (Show k, Show v) => Int -> Map k v -> Builder -showbMapPrec p m - = showbParen (p > appPrec) $ "fromList " <> showb (M.toList m) -{-# INLINE showbMapPrec #-} - --- | Convert a 'Sequence' into a 'Builder' with the given precedence. -showbSequencePrec :: Show a => Int -> Seq a -> Builder -showbSequencePrec p s' - = showbParen (p > appPrec) $ "fromList " <> showb (F.toList s') -{-# INLINE showbSequencePrec #-} - --- | Convert a 'Set' into a 'Builder' with the given precedence. -showbSetPrec :: Show a => Int -> Set a -> Builder -showbSetPrec p s' - = showbParen (p > appPrec) $ "fromList " <> showb (Set.toList s') -{-# INLINE showbSetPrec #-} - --- | Convert a 'Tree' into a 'Builder' with the given precedence. -showbTreePrec :: Show a => Int -> Tree a -> Builder -showbTreePrec = showbPrec -{-# INLINE showbTreePrec #-} - -instance Show v => Show (IntMap v) where - showbPrec = showbIntMapPrec - {-# INLINE showbPrec #-} - -instance Show IntSet where - showbPrec = showbIntSetPrec - {-# INLINE showbPrec #-} - -instance (Show k, Show v) => Show (Map k v) where - showbPrec = showbMapPrec - {-# INLINE showbPrec #-} - -instance Show a => Show (Seq a) where - showbPrec = showbSequencePrec - {-# INLINE showbPrec #-} - -instance Show a => Show (Set a) where - showbPrec = showbSetPrec - {-# INLINE showbPrec #-} - -$(deriveShow ''Tree) diff --git a/src/Text/Show/Text/Data/Data.hs b/src/Text/Show/Text/Data/Data.hs --- a/src/Text/Show/Text/Data/Data.hs +++ b/src/Text/Show/Text/Data/Data.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Data --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for data types in the @Data@ module. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Data +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @Data.Data@ module. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Data ( showbConstr , showbConstrRepPrec @@ -24,41 +25,54 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec)) -import Text.Show.Text.Data.Integral () +import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Data.List () -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.Data.Ratio () +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec, + defaultInlineShowb) +#include "inline.h" + -- | Convert a 'DataType' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbDataTypePrec :: Int -> DataType -> Builder showbDataTypePrec = showbPrec {-# INLINE showbDataTypePrec #-} -- | Convert a 'DataRep' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbDataRepPrec :: Int -> DataRep -> Builder showbDataRepPrec = showbPrec {-# INLINE showbDataRepPrec #-} -- | Convert a 'Constr' to a 'Builder'. +-- +-- /Since: 0.3/ showbConstr :: Constr -> Builder showbConstr = fromString . showConstr {-# INLINE showbConstr #-} -- | Convert a 'Fixity' value to a 'Builder'. +-- +-- /Since: 0.3/ showbFixity :: Fixity -> Builder showbFixity = showb {-# INLINE showbFixity #-} -- | Convert a 'ConstrRep' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbConstrRepPrec :: Int -> ConstrRep -> Builder showbConstrRepPrec = showbPrec {-# INLINE showbConstrRepPrec #-} -$(deriveShow ''DataType) -$(deriveShow ''DataRep) -$(deriveShow ''ConstrRep) -$(deriveShow ''Fixity) +$(deriveShowPragmas defaultInlineShowbPrec ''DataType) +$(deriveShowPragmas defaultInlineShowbPrec ''DataRep) +$(deriveShowPragmas defaultInlineShowbPrec ''ConstrRep) +$(deriveShowPragmas defaultInlineShowb ''Fixity) instance Show Constr where showb = showbConstr - {-# INLINE showb #-} + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Dynamic.hs b/src/Text/Show/Text/Data/Dynamic.hs --- a/src/Text/Show/Text/Data/Dynamic.hs +++ b/src/Text/Show/Text/Data/Dynamic.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Dynamic --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Dynamic'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Dynamic +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Dynamic'. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Dynamic (showbDynamic) where import Data.Dynamic (Dynamic, dynTypeRep) @@ -18,15 +19,19 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Classes (Show(showb)) import Text.Show.Text.Data.Typeable (showbTypeRepPrec) import Text.Show.Text.Utils ((<>)) +#include "inline.h" + -- | Convert a 'Dynamic' value to a 'Builder'. +-- +-- /Since: 0.3/ showbDynamic :: Dynamic -> Builder showbDynamic dyn = "<<" <> showbTypeRepPrec 0 (dynTypeRep dyn) <> ">>" {-# INLINE showbDynamic #-} instance Show Dynamic where showb = showbDynamic - {-# INLINE showb #-} + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Either.hs b/src/Text/Show/Text/Data/Either.hs --- a/src/Text/Show/Text/Data/Either.hs +++ b/src/Text/Show/Text/Data/Either.hs @@ -1,28 +1,37 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Either --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Either' values. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Either +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Either' values. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Either (showbEitherPrec) where import Data.Text.Lazy.Builder (Builder) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec)) -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.Classes (Show(showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +#include "inline.h" + -- | Convert a 'Either' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbEitherPrec :: (Show a, Show b) => Int -> Either a b -> Builder showbEitherPrec = showbPrec {-# INLINE showbEitherPrec #-} -$(deriveShow ''Either) +$(deriveShowPragmas defaultInlineShowbPrec ''Either) + +instance Show a => Show1 (Either a) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Fixed.hs b/src/Text/Show/Text/Data/Fixed.hs --- a/src/Text/Show/Text/Data/Fixed.hs +++ b/src/Text/Show/Text/Data/Fixed.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Fixed --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Fixed' values. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Fixed +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Fixed' values. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Fixed (showbFixed) where import Data.Fixed (HasResolution(..)) @@ -18,12 +19,14 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Classes (Show(showb)) #if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(..)) import Data.Int (Int64) +# if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (mempty) +# endif import Text.Show.Text.Data.Integral () import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) @@ -32,8 +35,12 @@ import Data.Text.Lazy.Builder (fromString) #endif +#include "inline.h" + -- | Convert a 'Fixed' value to a 'Builder', where the first argument indicates --- whether to chop off trailing zeroes. +-- whether to chop off trailing zeroes. +-- +-- /Since: 0.3/ showbFixed :: HasResolution a => Bool -> Fixed a -> Builder #if MIN_VERSION_base(4,7,0) showbFixed chopTrailingZeroes fa@(MkFixed a) | a < 0 @@ -45,7 +52,12 @@ (i, d) = divMod (fromInteger a) res digits = ceiling (logBase 10 (fromInteger $ resolution fa) :: Double) maxnum = 10 ^ digits +# if MIN_VERSION_base(4,8,0) + fracNum = divCeil (d * maxnum) res + divCeil x y = (x + y - 1) `div` y +# else fracNum = div (d * maxnum) res +# endif #else showbFixed chopTrailingZeroes = fromString . showFixed chopTrailingZeroes #endif @@ -78,4 +90,4 @@ instance HasResolution a => Show (Fixed a) where showb = showbFixed False - {-# INLINE showb #-} + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Floating.hs b/src/Text/Show/Text/Data/Floating.hs --- a/src/Text/Show/Text/Data/Floating.hs +++ b/src/Text/Show/Text/Data/Floating.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Floating --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for floating-point types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Floating +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for floating-point types. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Floating ( showbRealFloatPrec , showbFloatPrec , showbDoublePrec - , showbComplexPrec , showbEFloat , showbFFloat , showbGFloat @@ -25,7 +25,6 @@ import Data.Array.Base (unsafeAt) import Data.Array.IArray (Array, array) -import Data.Complex (Complex(..)) import qualified Data.Text as T (replicate) import Data.Text.Lazy.Builder (Builder, fromString, fromText) import Data.Text.Lazy.Builder.Int (decimal) @@ -33,10 +32,14 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Classes (Show(showbPrec), showbParen) import Text.Show.Text.Utils ((<>), i2d, s) +#include "inline.h" + -- | Convert a 'RealFloat' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbRealFloatPrec :: RealFloat a => Int -> a -> Builder showbRealFloatPrec p x | x < 0 || isNegativeZero x = showbParen (p > 6) $ s '-' <> showbGFloat Nothing (-x) @@ -44,40 +47,39 @@ {-# INLINE showbRealFloatPrec #-} -- | Convert a 'Float' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbFloatPrec :: Int -> Float -> Builder showbFloatPrec = showbRealFloatPrec {-# INLINE showbFloatPrec #-} -- | Convert a 'Double' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbDoublePrec :: Int -> Double -> Builder showbDoublePrec = showbRealFloatPrec {-# INLINE showbDoublePrec #-} --- | Convert a 'Complex' value to a 'Builder' with the given precedence. -showbComplexPrec :: (RealFloat a, Show a) => Int -> Complex a -> Builder -showbComplexPrec p (a :+ b) = showbParen (p > complexPrec) $ - showbPrec (complexPrec+1) a - <> " :+ " - <> showbPrec (complexPrec+1) b - where complexPrec = 6 -{-# INLINE showbComplexPrec #-} - -- | Show a signed 'RealFloat' value -- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@). --- +-- -- In the call @'showbEFloat' digs val@, if @digs@ is 'Nothing', -- the value is shown to full precision; if @digs@ is @'Just' d@, -- then at most @d@ digits after the decimal point are shown. +-- +-- /Since: 0.3/ showbEFloat :: RealFloat a => Maybe Int -> a -> Builder showbEFloat = formatRealFloat Exponent {-# INLINE showbEFloat #-} -- | Show a signed 'RealFloat' value -- using standard decimal notation (e.g. @245000@, @0.0015@). --- +-- -- In the call @'showbFFloat' digs val@, if @digs@ is 'Nothing', -- the value is shown to full precision; if @digs@ is @'Just' d@, -- then at most @d@ digits after the decimal point are shown. +-- +-- /Since: 0.3/ showbFFloat :: RealFloat a => Maybe Int -> a -> Builder showbFFloat = formatRealFloat Fixed {-# INLINE showbFFloat #-} @@ -85,19 +87,23 @@ -- | Show a signed 'RealFloat' value -- using standard decimal notation for arguments whose absolute value lies -- between @0.1@ and @9,999,999@, and scientific notation otherwise. --- +-- -- In the call @'showbGFloat' digs val@, if @digs@ is 'Nothing', -- the value is shown to full precision; if @digs@ is @'Just' d@, -- then at most @d@ digits after the decimal point are shown. +-- +-- /Since: 0.3/ showbGFloat :: RealFloat a => Maybe Int -> a -> Builder showbGFloat = formatRealFloat Generic {-# INLINE showbGFloat #-} -- | Show a signed 'RealFloat' value -- using standard decimal notation (e.g. @245000@, @0.0015@). --- +-- -- This behaves as 'showFFloat', except that a decimal point -- is always guaranteed, even if not needed. +-- +-- /Since: 0.3/ showbFFloatAlt :: RealFloat a => Maybe Int -> a -> Builder showbFFloatAlt d x = formatRealFloatAlt Fixed d True x {-# INLINE showbFFloatAlt #-} @@ -105,33 +111,29 @@ -- | Show a signed 'RealFloat' value -- using standard decimal notation for arguments whose absolute value lies -- between @0.1@ and @9,999,999@, and scientific notation otherwise. --- +-- -- This behaves as 'showFFloat', except that a decimal point -- is always guaranteed, even if not needed. +-- +-- /Since: 0.3/ showbGFloatAlt :: RealFloat a => Maybe Int -> a -> Builder showbGFloatAlt d x = formatRealFloatAlt Generic d True x {-# INLINE showbGFloatAlt #-} instance Show Float where showbPrec = showbFloatPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Double where showbPrec = showbDoublePrec - {-# INLINE showbPrec #-} - -instance (RealFloat a, Show a) => Show (Complex a) where - {-# SPECIALIZE instance Show (Complex Float) #-} - {-# SPECIALIZE instance Show (Complex Double) #-} - showbPrec = showbComplexPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) ------------------------------------------------------------------------------- -- GHC.Float internal functions, adapted for Builders ------------------------------------------------------------------------------- -- | Like 'formatRealFloatAlt', except that the decimal is only shown for arguments --- whose absolute value is between @0.1@ and @9,999,999@. +-- whose absolute value is between @0.1@ and @9,999,999@. formatRealFloat :: RealFloat a => FPFormat -- ^ What notation to use. -> Maybe Int -- ^ Number of decimal places to render. @@ -318,23 +320,43 @@ in (map fromIntegral (reverse rds), k) --- | roundTo :: Int -> [Int] -> (Int,[Int]) +#if MIN_VERSION_base(4,6,0) roundTo d is = case f d True is of x@(0,_) -> x (1,xs) -> (1, 1:xs) _ -> error "roundTo: bad Value" where + b2 = base `quot` 2 + f n _ [] = (0, replicate n 0) - f 0 e (x:xs) | x == 5 && e && all (== 0) xs = (0, []) -- Round to even when at exactly half the base - | otherwise = (if x >= 5 then 1 else 0, []) + f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, []) -- Round to even when at exactly half the base + | otherwise = (if x >= b2 then 1 else 0, []) f n _ (i:xs) - | i' == 10 = (1,0:ds) + | i' == base = (1,0:ds) | otherwise = (0,i':ds) where (c,ds) = f (n-1) (even i) xs i' = c + i + base = 10 +#else +roundTo d is = + case f d is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" + where + f n [] = (0, replicate n 0) + f 0 (x:_) = (if x >= 5 then 1 else 0, []) + f n (i:xs) + | i' == 10 = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) xs + i' = c + i +#endif + -- Exponentiation with a cache for the most common numbers. diff --git a/src/Text/Show/Text/Data/Functor/Identity.hs b/src/Text/Show/Text/Data/Functor/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Functor/Identity.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Functor.Identity +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Identity' values. + +/Since: 0.5/ +-} +module Text.Show.Text.Data.Functor.Identity (showbIdentityPrec) where + +import Data.Functor.Identity (Identity(..)) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showbPrec), Show1(showbPrec1), showbUnary) + +#include "inline.h" + +-- | Convert an 'Identity' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.5/ +showbIdentityPrec :: Show a => Int -> Identity a -> Builder +-- This would be equivalent to the derived instance of 'Identity' if the +-- 'runIdentity' field were removed. +showbIdentityPrec p (Identity x) = showbUnary "Identity" p x +{-# INLINE showbIdentityPrec #-} + +instance Show a => Show (Identity a) where + showbPrec = showbIdentityPrec + {-# INLINE showbPrec #-} + +instance Show1 Identity where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Integral.hs b/src/Text/Show/Text/Data/Integral.hs --- a/src/Text/Show/Text/Data/Integral.hs +++ b/src/Text/Show/Text/Data/Integral.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, OverloadedStrings #-} -#if !defined(TEXT_FORMAT) -{-# LANGUAGE BangPatterns, UnboxedTuples #-} +{-# LANGUAGE CPP, MagicHash, OverloadedStrings #-} +#if !defined(RECENT_TEXT) +{-# LANGUAGE BangPatterns, RankNTypes, ScopedTypeVariables, UnboxedTuples #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Integral --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for integral types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Integral +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for integral types. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Integral ( showbIntPrec , showbInt8Prec @@ -26,7 +27,6 @@ , showbBin , showbHex , showbOct - , showbRatioPrec , showbWord , showbWord8 , showbWord16 @@ -36,10 +36,18 @@ import Data.Char (intToDigit) import Data.Int (Int8, Int16, Int32, Int64) +#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (mempty) -import Data.Ratio (Ratio, numerator, denominator) +#endif import Data.Text.Lazy.Builder (Builder) -import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Word ( Word8 + , Word16 + , Word32 + , Word64 +#if !(MIN_VERSION_base(4,8,0)) + , Word +#endif + ) import GHC.Exts (Int(I#)) #if __GLASGOW_HASKELL__ >= 708 @@ -47,17 +55,22 @@ import GHC.Prim (Int#) #endif import GHC.Prim ((<#), (>#)) -import GHC.Real (ratioPrec, ratioPrec1) -import qualified Prelude as P (show) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Classes (Show(showb, showbPrec)) +import Text.Show.Text.Utils ((<>), s, toString) -#if defined(TEXT_FORMAT) -import Data.Text.Buildable (build) +#if defined(RECENT_TEXT) +import Data.Text.Lazy.Builder.Int (decimal) #else +import Control.Monad.ST (ST) + +import qualified Data.ByteString.Unsafe as B +import Data.Text.Array (MArray, unsafeWrite) +import Data.Text.Internal.Builder (writeN) +import Data.Text.Internal.Builder.Int.Digits (digits) + import GHC.Base (quotInt, remInt) import GHC.Integer.GMP.Internals (Integer(..)) import GHC.Num (quotRemInteger) @@ -65,11 +78,15 @@ import Text.Show.Text.Utils (i2d) #endif +#include "inline.h" + -- | Convert an 'Int' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbIntPrec :: Int -> Int -> Builder showbIntPrec (I# p) n'@(I# n) - | isTrue (n <# 0#) && isTrue (p ># 6#) = s '(' <> build n' <> s ')' - | otherwise = build n' + | isTrue (n <# 0#) && isTrue (p ># 6#) = s '(' <> decimal n' <> s ')' + | otherwise = decimal n' where #if __GLASGOW_HASKELL__ >= 708 isTrue :: Int# -> Bool @@ -80,21 +97,29 @@ #endif -- | Convert an 'Int8' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbInt8Prec :: Int -> Int8 -> Builder showbInt8Prec p = showbIntPrec p . fromIntegral {-# INLINE showbInt8Prec #-} -- | Convert an 'Int16' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbInt16Prec :: Int -> Int16 -> Builder showbInt16Prec p = showbIntPrec p . fromIntegral {-# INLINE showbInt16Prec #-} -- | Convert an 'Int32' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbInt32Prec :: Int -> Int32 -> Builder showbInt32Prec p = showbIntPrec p . fromIntegral {-# INLINE showbInt32Prec #-} -- | Convert an 'Int64' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbInt64Prec :: Int -> Int64 -> Builder #if WORD_SIZE_IN_BITS < 64 showbInt64Prec p = showbIntegerPrec p . toInteger @@ -104,23 +129,29 @@ {-# INLINE showbInt64Prec #-} -- | Convert an 'Integer' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbIntegerPrec :: Int -> Integer -> Builder showbIntegerPrec p n - | p > 6 && n < 0 = s '(' <> build n <> s ')' - | otherwise = build n + | p > 6 && n < 0 = s '(' <> decimal n <> s ')' + | otherwise = decimal n {-# INLINE showbIntegerPrec #-} -- | Convert an 'Integral' type to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbIntegralPrec :: Integral a => Int -> a -> Builder showbIntegralPrec p = showbIntegerPrec p . toInteger {-# INLINE showbIntegralPrec #-} -- | Shows a /non-negative/ 'Integral' number using the base specified by the --- first argument, and the character representation specified by the second. +-- first argument, and the character representation specified by the second. +-- +-- /Since: 0.3/ showbIntAtBase :: (Integral a, Show a) => a -> (Int -> Char) -> a -> Builder showbIntAtBase base toChr n0 - | base <= 1 = error . P.show $ "Text.Show.Text.Int.showbIntAtBase: applied to unsupported base" <> showb base - | n0 < 0 = error . P.show $ "Text.Show.Text.Int.showbIntAtBase: applied to negative number " <> showb n0 + | base <= 1 = error . toString $ "Text.Show.Text.Int.showbIntAtBase: applied to unsupported base" <> showb base + | n0 < 0 = error . toString $ "Text.Show.Text.Int.showbIntAtBase: applied to negative number " <> showb n0 | otherwise = showbIt (quotRem n0 base) mempty where showbIt (n, d) b = seq c $ -- stricter than necessary @@ -136,78 +167,172 @@ {-# INLINE showbIntAtBase #-} -- | Show /non-negative/ 'Integral' numbers in base 2. +-- +-- /Since: 0.3/ showbBin :: (Integral a, Show a) => a -> Builder showbBin = showbIntAtBase 2 intToDigit {-# INLINE showbBin #-} -- | Show /non-negative/ 'Integral' numbers in base 16. +-- +-- /Since: 0.3/ showbHex :: (Integral a, Show a) => a -> Builder showbHex = showbIntAtBase 16 intToDigit {-# INLINE showbHex #-} -- | Show /non-negative/ 'Integral' numbers in base 8. +-- +-- /Since: 0.3/ showbOct :: (Integral a, Show a) => a -> Builder showbOct = showbIntAtBase 8 intToDigit {-# INLINE showbOct #-} --- | Convert a 'Ratio' to a 'Builder' with the given precedence. -showbRatioPrec :: (Show a, Integral a) => Int -> Ratio a -> Builder -showbRatioPrec p q = showbParen (p > ratioPrec) $ - showbPrec ratioPrec1 (numerator q) - <> " % " - <> showbPrec ratioPrec1 (denominator q) -{-# INLINE showbRatioPrec #-} - -- | Convert a 'Word' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbWord :: Word -> Builder -showbWord = build +showbWord = decimal {-# INLINE showbWord #-} -- | Convert a 'Word8' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbWord8 :: Word8 -> Builder -showbWord8 = build +showbWord8 = decimal {-# INLINE showbWord8 #-} -- | Convert a 'Word16' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbWord16 :: Word16 -> Builder -showbWord16 = build +showbWord16 = decimal {-# INLINE showbWord16 #-} -- | Convert a 'Word32' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbWord32 :: Word32 -> Builder -showbWord32 = build +showbWord32 = decimal {-# INLINE showbWord32 #-} -- | Convert a 'Word64' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbWord64 :: Word64 -> Builder -showbWord64 = build +showbWord64 = decimal {-# INLINE showbWord64 #-} -#if !defined(TEXT_FORMAT) -build :: Integral a => a -> Builder -build = decimal -{-# INLINE build #-} - +#if !defined(RECENT_TEXT) decimal :: Integral a => a -> Builder -{-# SPECIALIZE decimal :: Int -> Builder #-} -{-# SPECIALIZE decimal :: Int8 -> Builder #-} -{-# SPECIALIZE decimal :: Int16 -> Builder #-} -{-# SPECIALIZE decimal :: Int32 -> Builder #-} -{-# SPECIALIZE decimal :: Int64 -> Builder #-} -{-# SPECIALIZE decimal :: Word -> Builder #-} -{-# SPECIALIZE decimal :: Word8 -> Builder #-} -{-# SPECIALIZE decimal :: Word16 -> Builder #-} -{-# SPECIALIZE decimal :: Word32 -> Builder #-} -{-# SPECIALIZE decimal :: Word64 -> Builder #-} +{-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-} +{-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-} +{-# RULES "decimal/Int16" decimal = boundedDecimal :: Int16 -> Builder #-} +{-# RULES "decimal/Int32" decimal = boundedDecimal :: Int32 -> Builder #-} +{-# RULES "decimal/Int64" decimal = boundedDecimal :: Int64 -> Builder #-} +{-# RULES "decimal/Word" decimal = positive :: Word -> Builder #-} +{-# RULES "decimal/Word8" decimal = positive :: Word8 -> Builder #-} +{-# RULES "decimal/Word16" decimal = positive :: Word16 -> Builder #-} +{-# RULES "decimal/Word32" decimal = positive :: Word32 -> Builder #-} +{-# RULES "decimal/Word64" decimal = positive :: Word64 -> Builder #-} {-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-} -decimal i - | i < 0 = minus <> go (-i) - | otherwise = go i - where - go n | n < 10 = digit n - | otherwise = go (n `quot` 10) <> digit (n `rem` 10) -{-# NOINLINE[0] decimal #-} +decimal i = decimal' (<= -128) i +{-# NOINLINE decimal #-} +boundedDecimal :: (Integral a, Bounded a) => a -> Builder +{-# SPECIALIZE boundedDecimal :: Int -> Builder #-} +{-# SPECIALIZE boundedDecimal :: Int8 -> Builder #-} +{-# SPECIALIZE boundedDecimal :: Int16 -> Builder #-} +{-# SPECIALIZE boundedDecimal :: Int32 -> Builder #-} +{-# SPECIALIZE boundedDecimal :: Int64 -> Builder #-} +boundedDecimal i = decimal' (== minBound) i + +decimal' :: Integral a => (a -> Bool) -> a -> Builder +{-# INLINE decimal' #-} +decimal' p i + | i < 0 = if p i + then let (q, r) = i `quotRem` 10 + qq = -q + !n = countDigits qq + in writeN (n + 2) $ \marr off -> do + unsafeWrite marr off minus + posDecimal marr (off+1) n qq + unsafeWrite marr (off+n+1) (i2w (-r)) + else let j = -i + !n = countDigits j + in writeN (n + 1) $ \marr off -> + unsafeWrite marr off minus >> posDecimal marr (off+1) n j + | otherwise = positive i + +positive :: Integral a => a -> Builder +{-# SPECIALIZE positive :: Int -> Builder #-} +{-# SPECIALIZE positive :: Int8 -> Builder #-} +{-# SPECIALIZE positive :: Int16 -> Builder #-} +{-# SPECIALIZE positive :: Int32 -> Builder #-} +{-# SPECIALIZE positive :: Int64 -> Builder #-} +{-# SPECIALIZE positive :: Word -> Builder #-} +{-# SPECIALIZE positive :: Word8 -> Builder #-} +{-# SPECIALIZE positive :: Word16 -> Builder #-} +{-# SPECIALIZE positive :: Word32 -> Builder #-} +{-# SPECIALIZE positive :: Word64 -> Builder #-} +positive i + | i < 10 = writeN 1 $ \marr off -> unsafeWrite marr off (i2w i) + | otherwise = let !n = countDigits i + in writeN n $ \marr off -> posDecimal marr off n i + +posDecimal :: Integral a => + forall s. MArray s -> Int -> Int -> a -> ST s () +{-# INLINE posDecimal #-} +posDecimal marr off0 ds v0 = go (off0 + ds - 1) v0 + where go off v + | v >= 100 = do + let (q, r) = v `quotRem` 100 + write2 off r + go (off - 2) q + | v < 10 = unsafeWrite marr off (i2w v) + | otherwise = write2 off v + write2 off i0 = do + let i = fromIntegral i0; j = i + i + unsafeWrite marr off $ get (j + 1) + unsafeWrite marr (off - 1) $ get j + get = fromIntegral . B.unsafeIndex digits + +minus, zero :: Word16 +{-# INLINE minus #-} +{-# INLINE zero #-} +minus = 45 +zero = 48 + +i2w :: Integral a => a -> Word16 +{-# INLINE i2w #-} +i2w v = zero + fromIntegral v + +countDigits :: Integral a => a -> Int +{-# INLINE countDigits #-} +countDigits v0 + | fromIntegral v64 == v0 = go 1 v64 + | otherwise = goBig 1 (fromIntegral v0) + where v64 = fromIntegral v0 + goBig !k (v :: Integer) + | v > big = goBig (k + 19) (v `quot` big) + | otherwise = go k (fromIntegral v) + big = 10000000000000000000 + go !k (v :: Word64) + | v < 10 = k + | v < 100 = k + 1 + | v < 1000 = k + 2 + | v < 1000000000000 = + k + if v < 100000000 + then if v < 1000000 + then if v < 10000 + then 3 + else 4 + fin v 100000 + else 6 + fin v 10000000 + else if v < 10000000000 + then 8 + fin v 1000000000 + else 10 + fin v 100000000000 + | otherwise = go (k + 12) (v `quot` 1000000000000) + fin v n = if v >= n then 1 else 0 + hexadecimal :: Integral a => a -> Builder {-# SPECIALIZE hexadecimal :: Int -> Builder #-} {-# SPECIALIZE hexadecimal :: Int8 -> Builder #-} @@ -219,40 +344,37 @@ {-# SPECIALIZE hexadecimal :: Word16 -> Builder #-} {-# SPECIALIZE hexadecimal :: Word32 -> Builder #-} {-# SPECIALIZE hexadecimal :: Word64 -> Builder #-} -{-# RULES "hexadecimal/Integer" hexadecimal = integer 16 :: Integer -> Builder #-} +{-# RULES "hexadecimal/Integer" + hexadecimal = hexInteger :: Integer -> Builder #-} hexadecimal i - | i < 0 = minus <> go (-i) + | i < 0 = error hexErrMsg | otherwise = go i where go n | n < 16 = hexDigit n | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16) {-# NOINLINE[0] hexadecimal #-} -digit :: Integral a => a -> Builder -digit n = s $! i2d (fromIntegral n) -{-# INLINE digit #-} +hexInteger :: Integer -> Builder +hexInteger i + | i < 0 = error hexErrMsg + | otherwise = integer 16 i +hexErrMsg :: String +hexErrMsg = "Data.Text.Lazy.Builder.Int.hexadecimal: applied to negative number" + hexDigit :: Integral a => a -> Builder hexDigit n | n <= 9 = s $! i2d (fromIntegral n) | otherwise = s $! toEnum (fromIntegral n + 87) {-# INLINE hexDigit #-} -minus :: Builder -minus = s '-' -{-# INLINE minus #-} - -int :: Int -> Builder -int = decimal -{-# INLINE int #-} - data T = T !Integer !Int integer :: Int -> Integer -> Builder integer 10 (S# i#) = decimal (I# i#) integer 16 (S# i#) = hexadecimal (I# i#) integer base i - | i < 0 = minus <> go (-i) + | i < 0 = s '-' <> go (-i) | otherwise = go i where go n | n < maxInt = int (fromInteger n) @@ -299,60 +421,59 @@ r = fromInteger y putB _ = mempty + int :: Int -> Builder + int x | base == 10 = decimal x + | otherwise = hexadecimal x + pblock = loop maxDigits where loop !d !n - | d == 1 = digit n - | otherwise = loop (d-1) q <> digit r + | d == 1 = hexDigit n + | otherwise = loop (d-1) q <> hexDigit r where q = n `quotInt` base r = n `remInt` base #endif instance Show Int where showbPrec = showbIntPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Int8 where showbPrec = showbInt8Prec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Int16 where showbPrec = showbInt16Prec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Int32 where showbPrec = showbInt32Prec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Int64 where showbPrec = showbInt64Prec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Integer where showbPrec = showbIntegerPrec - {-# INLINE showbPrec #-} - -instance (Show a, Integral a) => Show (Ratio a) where - {-# SPECIALIZE instance Show Rational #-} - showbPrec = showbRatioPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show Word where showb = showbWord - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show Word8 where showb = showbWord8 - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show Word16 where showb = showbWord16 - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show Word32 where showb = showbWord32 - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show Word64 where showb = showbWord64 - {-# INLINE showb #-} + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/List.hs b/src/Text/Show/Text/Data/List.hs --- a/src/Text/Show/Text/Data/List.hs +++ b/src/Text/Show/Text/Data/List.hs @@ -1,27 +1,33 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.List --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Exports 'showbListDefault'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.List +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Exports 'showbListDefault'. +-} module Text.Show.Text.Data.List (showbListDefault) where import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbList), showbListDefault) +import Text.Show.Text.Classes (Show(showb, showbPrec, showbList), + Show1(showbPrec1), showbListDefault) import Text.Show.Text.Data.Char () import Text.Show.Text.Data.Integral () +#include "inline.h" + instance Show a => Show [a] where {-# SPECIALIZE instance Show [String] #-} {-# SPECIALIZE instance Show [Char] #-} {-# SPECIALIZE instance Show [Int] #-} showb = showbList - {-# INLINE showb #-} + INLINE_INST_FUN(showb) + +instance Show1 [] where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Maybe.hs b/src/Text/Show/Text/Data/Maybe.hs --- a/src/Text/Show/Text/Data/Maybe.hs +++ b/src/Text/Show/Text/Data/Maybe.hs @@ -1,28 +1,37 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Maybe --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Maybe' values. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Maybe +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Maybe' values. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Maybe (showbMaybePrec) where import Data.Text.Lazy.Builder (Builder) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec)) -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.Classes (Show(showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +#include "inline.h" + -- | Convert a 'Maybe' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbMaybePrec :: Show a => Int -> Maybe a -> Builder showbMaybePrec = showbPrec {-# INLINE showbMaybePrec #-} -$(deriveShow ''Maybe) +$(deriveShowPragmas defaultInlineShowbPrec ''Maybe) + +instance Show1 Maybe where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Monoid.hs b/src/Text/Show/Text/Data/Monoid.hs --- a/src/Text/Show/Text/Data/Monoid.hs +++ b/src/Text/Show/Text/Data/Monoid.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} +#if MIN_VERSION_base(4,8,0) +{-# LANGUAGE FlexibleContexts #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Monoid --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'Monoid'-related newtypes. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Monoid +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'Monoid'-related newtypes. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Monoid ( showbAllPrec , showbAnyPrec @@ -19,6 +23,9 @@ , showbLastPrec , showbProductPrec , showbSumPrec +#if MIN_VERSION_base(4,8,0) + , showbAltPrec +#endif ) where import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) @@ -26,50 +33,107 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec)) +import Text.Show.Text.Classes (Show(showbPrec), Show1(showbPrec1)) import Text.Show.Text.Data.Bool () import Text.Show.Text.Data.Maybe () -import Text.Show.Text.TH.Internal +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt) + +import Text.Show.Text.TH.Internal (mkShowbPrec) +#endif + +#include "inline.h" + -- | Convert an 'All' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbAllPrec :: Int -> All -> Builder showbAllPrec = showbPrec {-# INLINE showbAllPrec #-} -- | Convert an 'Any' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbAnyPrec :: Int -> Any -> Builder showbAnyPrec = showbPrec {-# INLINE showbAnyPrec #-} -- | Convert a 'Dual' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbDualPrec :: Show a => Int -> Dual a -> Builder showbDualPrec = showbPrec {-# INLINE showbDualPrec #-} -- | Convert a 'First' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbFirstPrec :: Show a => Int -> First a -> Builder showbFirstPrec = showbPrec {-# INLINE showbFirstPrec #-} -- | Convert a 'Last' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbLastPrec :: Show a => Int -> Last a -> Builder showbLastPrec = showbPrec {-# INLINE showbLastPrec #-} -- | Convert a 'Product' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbProductPrec :: Show a => Int -> Product a -> Builder showbProductPrec = showbPrec {-# INLINE showbProductPrec #-} -- | Convert a 'Sum' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbSumPrec :: Show a => Int -> Sum a -> Builder showbSumPrec = showbPrec {-# INLINE showbSumPrec #-} -$(deriveShow ''All) -$(deriveShow ''Any) -$(deriveShow ''Dual) -$(deriveShow ''First) -$(deriveShow ''Last) -$(deriveShow ''Product) -$(deriveShow ''Sum) +#if MIN_VERSION_base(4,8,0) +-- | Convert an 'Alt' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbAltPrec :: Show (f a) => Int -> Alt f a -> Builder +showbAltPrec = showbPrec +{-# INLINE showbAltPrec #-} +#endif + +$(deriveShowPragmas defaultInlineShowbPrec ''All) +$(deriveShowPragmas defaultInlineShowbPrec ''Any) +$(deriveShowPragmas defaultInlineShowbPrec ''Dual) +$(deriveShowPragmas defaultInlineShowbPrec ''First) +$(deriveShowPragmas defaultInlineShowbPrec ''Last) +$(deriveShowPragmas defaultInlineShowbPrec ''Product) +$(deriveShowPragmas defaultInlineShowbPrec ''Sum) +#if MIN_VERSION_base(4,8,0) +instance Show (f a) => Show (Alt f a) where + showbPrec = $(mkShowbPrec ''Alt) + {-# INLINE showbPrec #-} +#endif + +instance Show1 Dual where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 First where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 Last where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 Product where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 Sum where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/OldTypeable.hs b/src/Text/Show/Text/Data/OldTypeable.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/OldTypeable.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} +{-| +Module: Text.Show.Text.Data.OldTypeable +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @OldTypeable@ module. +This module is only available with @base-4.7@. + +/Since: 0.5/ +-} +module Text.Show.Text.Data.OldTypeable (showbTyCon, showbTypeRepPrec) where + +import Data.OldTypeable.Internal (TyCon(TyCon, tyConName), TypeRep(..), + funTc, listTc) +import Data.Text.Lazy.Builder (Builder, fromString) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showb, showbPrec), showbParen, showbSpace) +import Text.Show.Text.Data.Typeable.Utils (showbArgs, showbTuple) +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'TyCon' to a 'Builder'. +-- This function is only available with @base-4.7@. +-- +-- /Since: 0.5/ +showbTyCon :: TyCon -> Builder +showbTyCon = fromString . tyConName +{-# INLINE showbTyCon #-} + +-- | Convert a 'TypeRep' to a 'Builder' with the given precedence. +-- This function is only available with @base-4.7@. +-- +-- /Since: 0.5/ +showbTypeRepPrec :: Int -> TypeRep -> Builder +showbTypeRepPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showbTyCon tycon + [x] | tycon == listTc -> s '[' <> showb x <> s ']' + [a,r] | tycon == funTc -> showbParen (p > 8) $ + showbPrec 9 a + <> " -> " + <> showbPrec 8 r + xs | isTupleTyCon tycon -> showbTuple xs + | otherwise -> showbParen (p > 9) $ + showbPrec p tycon + <> showbSpace + <> showbArgs showbSpace tys + +-- | Does the 'TyCon' represent a tuple type constructor? +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True +isTupleTyCon _ = False +{-# INLINE isTupleTyCon #-} + +instance Show TyCon where + showb = showbTyCon + {-# INLINE showb #-} + +instance Show TypeRep where + showbPrec = showbTypeRepPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Data/Ord.hs b/src/Text/Show/Text/Data/Ord.hs --- a/src/Text/Show/Text/Data/Ord.hs +++ b/src/Text/Show/Text/Data/Ord.hs @@ -1,19 +1,17 @@ {-# LANGUAGE CPP, TemplateHaskell #-} -#if MIN_VERSION_base(4,6,0) -{-# LANGUAGE NoImplicitPrelude #-} -#endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Ord --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'Ordering' and 'Down'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Ord +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'Ordering' and 'Down'. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Ord ( showbOrdering #if MIN_VERSION_base(4,6,0) @@ -23,29 +21,41 @@ import Data.Text.Lazy.Builder (Builder) -import Text.Show.Text.Class (showb) -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.Classes (showb) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) #if MIN_VERSION_base(4,6,0) import Data.Ord (Down) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec)) +import Text.Show.Text.Classes (Show(showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (defaultInlineShowbPrec) #endif +#include "inline.h" + -- | Convert a 'Ordering' to a 'Builder'. +-- +-- /Since: 0.3/ showbOrdering :: Ordering -> Builder showbOrdering = showb {-# INLINE showbOrdering #-} -$(deriveShow ''Ordering) +$(deriveShowPragmas defaultInlineShowb ''Ordering) #if MIN_VERSION_base(4,6,0) -- | Convert a 'Down' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.6.0.0@ or later. +-- +-- /Since: 0.3/ showbDownPrec :: Show a => Int -> Down a -> Builder showbDownPrec = showbPrec {-# INLINE showbDownPrec #-} -$(deriveShow ''Down) +$(deriveShowPragmas defaultInlineShowbPrec ''Down) + +instance Show1 Down where + showbPrec1 = showbPrec + {-# INLINE showbPrec1 #-} #endif diff --git a/src/Text/Show/Text/Data/Proxy.hs b/src/Text/Show/Text/Data/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Proxy.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Proxy +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Proxy' values. + +/Since: 0.4/ +-} +module Text.Show.Text.Data.Proxy (showbProxy) where + +import Data.Proxy (Proxy(..)) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (mkShowbPrec) + +#include "inline.h" + +-- | Convert a 'Proxy' type to a 'Builder'. +-- +-- /Since: 0.4/ +showbProxy :: Proxy s -> Builder +showbProxy = showb +{-# INLINE showbProxy #-} + +-- TODO: See why 'deriveShow' can't detect Proxy's phantom type correctly +instance Show (Proxy s) where + showbPrec = $(mkShowbPrec ''Proxy) + INLINE_INST_FUN(showb) + +instance Show1 Proxy where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Ratio.hs b/src/Text/Show/Text/Data/Ratio.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Ratio.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Ratio +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Ratio' values. + +/Since: 0.5/ +-} +module Text.Show.Text.Data.Ratio (showbRatioPrec) where + +import Data.Text.Lazy.Builder (Builder) +import Data.Ratio (Ratio, numerator, denominator) + +import GHC.Real (ratioPrec, ratioPrec1) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showbPrec), showbParen) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Utils ((<>)) + +#include "inline.h" + +-- | Convert a 'Ratio' to a 'Builder' with the given precedence. +-- +-- /Since: 0.5/ +showbRatioPrec :: (Show a, Integral a) => Int -> Ratio a -> Builder +showbRatioPrec p q = showbParen (p > ratioPrec) $ + showbPrec ratioPrec1 (numerator q) + <> " % " + <> showbPrec ratioPrec1 (denominator q) +{-# INLINE showbRatioPrec #-} + +instance (Show a, Integral a) => Show (Ratio a) where + {-# SPECIALIZE instance Show Rational #-} + showbPrec = showbRatioPrec + INLINE_INST_FUN(showbPrec) diff --git a/src/Text/Show/Text/Data/Text.hs b/src/Text/Show/Text/Data/Text.hs --- a/src/Text/Show/Text/Data/Text.hs +++ b/src/Text/Show/Text/Data/Text.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Text --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'Text' types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Text +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'Text' types. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Text ( - showbTextStrict + showbText , showbTextLazy + , showbBuilder ) where import Data.Text as TS @@ -22,28 +24,45 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) -import Text.Show.Text.Data.Char () -import Text.Show.Text.Data.List () +import Text.Show.Text.Classes (Show(showb)) +import Text.Show.Text.Data.Char (showbString) +#include "inline.h" + -- | Convert a strict 'TS.Text' into a 'Builder'. -showbTextStrict :: TS.Text -> Builder -showbTextStrict = showb . TS.unpack +-- 'showbText' should not be confused with @fromText@, as 'showbText' escapes +-- certain characters (such as double quotes). +-- +-- /Since: 0.5/ +showbText :: TS.Text -> Builder +showbText = showbString . TS.unpack +{-# INLINE showbText #-} -- | Convert a lazy 'TL.Text' into a 'Builder'. +-- 'showbTextLazy' should not be confused with @fromTextLazy@, as 'showbTextLazy' +-- escapes certain characters (such as double quotes). +-- +-- /Since: 0.3/ showbTextLazy :: TL.Text -> Builder -showbTextLazy = showb . TL.unpack +showbTextLazy = showbString . TL.unpack +{-# INLINE showbTextLazy #-} -instance Show Builder where - showb = showb . toLazyText - {-# INLINE showb #-} +-- | Show a 'Builder' as if it were a 'String' (i.e., escape certain characters, +-- such as double quotes). +-- +-- /Since: 0.5/ +showbBuilder :: Builder -> Builder +showbBuilder = showbTextLazy . toLazyText +{-# INLINE showbBuilder #-} --- Strict variant instance Show TS.Text where - showb = showbTextStrict - {-# INLINE showb #-} + showb = showbText + INLINE_INST_FUN(showb) --- Lazy variant instance Show TL.Text where showb = showbTextLazy - {-# INLINE showb #-} + INLINE_INST_FUN(showb) + +instance Show Builder where + showb = showbBuilder + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Time.hs b/src/Text/Show/Text/Data/Time.hs deleted file mode 100644 --- a/src/Text/Show/Text/Data/Time.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Foreign.Data.Time --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for data types in the @time@ library. These --- are included for convenience (and because @time@ is a dependency of this --- library). ----------------------------------------------------------------------------- -module Text.Show.Text.Data.Time ( - showbDay - , showbDiffTime - , showbUTCTime - , showbNominalDiffTime - , showbAbsoluteTime - , showbTimeZone - , showbTimeOfDay - , showbLocalTime - , showbZonedTime - ) where - -import Data.Text.Lazy.Builder (Builder) -import Data.Time.Calendar (Day) -import Data.Time.Clock (DiffTime, UTCTime, NominalDiffTime) -import Data.Time.Clock.TAI (AbsoluteTime, taiToUTCTime) -import Data.Time.LocalTime (TimeZone(..), TimeOfDay(..), LocalTime(..), - ZonedTime(..), utc, utcToLocalTime) - -import Prelude hiding (Show) - -import Text.Show.Text.Class (Show(showb)) -import Text.Show.Text.Utils ((<>)) - -#if defined(TEXT_FORMAT) -import Data.Text.Buildable (build) -#else -import Data.Fixed (Pico) -import Data.Text.Lazy.Builder (fromString) -import Data.Time.Calendar (toGregorian) -import Data.Time.Format (NumericPadOption) -import Data.Time.LocalTime (utcToZonedTime) - -import qualified Prelude as P - -import Text.Show.Text.Data.Fixed (showbFixed) -import Text.Show.Text.Data.Integral () -import Text.Show.Text.Utils (lengthB, replicateB, s) -#endif - --- | Convert a 'Day' into a 'Builder'. -showbDay :: Day -> Builder -#if defined(TEXT_FORMAT) -showbDay = build -#else -showbDay = showbGregorian -#endif -{-# INLINE showbDay #-} - --- | Convert a 'DiffTime' into a 'Builder'. -showbDiffTime :: DiffTime -> Builder -#if defined(TEXT_FORMAT) -showbDiffTime = build -#else -showbDiffTime = fromString . P.show -#endif -{-# INLINE showbDiffTime #-} - --- | Convert a 'UTCTime' into a 'Builder'. -showbUTCTime :: UTCTime -> Builder -#if defined(TEXT_FORMAT) -showbUTCTime = build -#else -showbUTCTime = showb . utcToZonedTime utc -#endif -{-# INLINE showbUTCTime #-} - --- | Convert a 'NominalDiffTime' into a 'Builder'. -showbNominalDiffTime :: NominalDiffTime -> Builder -#if defined(TEXT_FORMAT) -showbNominalDiffTime = build -#else -showbNominalDiffTime = fromString . P.show -#endif -{-# INLINE showbNominalDiffTime #-} - --- | Convert a 'AbsoluteTime' into a 'Builder'. -showbAbsoluteTime :: AbsoluteTime -> Builder -showbAbsoluteTime t = showbLocalTime (utcToLocalTime utc $ taiToUTCTime (const 0) t) - <> " TAI" -- ugly, but standard apparently -{-# INLINE showbAbsoluteTime #-} - --- | Convert a 'TimeZone' into a 'Builder'. -showbTimeZone :: TimeZone -> Builder -#if defined(TEXT_FORMAT) -showbTimeZone = build -#else -showbTimeZone zone@(TimeZone _ _ "") = timeZoneOffsetBuilder zone -showbTimeZone (TimeZone _ _ name) = fromString name -#endif -{-# INLINE showbTimeZone #-} - --- | Convert a 'TimeOfDay' into a 'Builder'. -showbTimeOfDay :: TimeOfDay -> Builder -#if defined(TEXT_FORMAT) -showbTimeOfDay = build -#else -showbTimeOfDay (TimeOfDay h m sec) = showb2 zeroOpt h - <> s ':' - <> showb2 zeroOpt m - <> s ':' - <> showb2Fixed zeroOpt sec -#endif -{-# INLINE showbTimeOfDay #-} - --- | Convert a 'LocalTime' into a 'Builder'. -showbLocalTime :: LocalTime -> Builder -#if defined(TEXT_FORMAT) -showbLocalTime = build -#else -showbLocalTime (LocalTime d t) = showbGregorian d <> s ' ' <> showb t -#endif -{-# INLINE showbLocalTime #-} - --- | Convert a 'ZonedTime' into a 'Builder'. -showbZonedTime :: ZonedTime -> Builder -#if defined(TEXT_FORMAT) -showbZonedTime = build -#else -showbZonedTime (ZonedTime t zone) = showb t <> s ' ' <> showb zone -#endif -{-# INLINE showbZonedTime #-} - -#if !defined(TEXT_FORMAT) -pad1 :: NumericPadOption -> Builder -> Builder -pad1 (Just c) b = s c <> b -pad1 _ b = b -{-# INLINE pad1 #-} - -padN :: Int -> Char -> Builder -> Builder -padN i _ b | i <= 0 = b -padN i c b = replicateB (fromIntegral i) (s c) <> b -{-# INLINE padN #-} - -showb2 :: (Num t, Ord t, Show t) => NumericPadOption -> t -> Builder -showb2 = showbPaddedMin 2 -{-# INLINE showb2 #-} - -showb2Fixed :: NumericPadOption -> Pico -> Builder -showb2Fixed opt x | x < 10 = pad1 opt $ showbFixed True x -showb2Fixed _ x = showbFixed True x -{-# INLINE showb2Fixed #-} - -showb4 :: (Num t, Ord t, Show t) => NumericPadOption -> t -> Builder -showb4 = showbPaddedMin 4 -{-# INLINE showb4 #-} - -showbGregorian :: Day -> Builder -showbGregorian date = showb4 zeroOpt y - <> s '-' - <> showb2 zeroOpt m - <> s '-' - <> showb2 zeroOpt d - where - (y,m,d) = toGregorian date -{-# INLINE showbGregorian #-} - -showbPaddedMin :: (Num t, Ord t, Show t) => Int -> NumericPadOption -> t -> Builder -showbPaddedMin _ Nothing i = showb i -showbPaddedMin pl opt i | i < 0 = s '-' <> showbPaddedMin pl opt (negate i) -showbPaddedMin pl (Just c) i = - let b = showb i - in padN (pl - fromIntegral (lengthB b)) c b -{-# INLINE showbPaddedMin #-} - -showbT :: NumericPadOption -> Int -> Builder -showbT opt t = showb4 opt ((div t 60) * 100 + (mod t 60)) -{-# INLINE showbT #-} - -timeZoneOffsetBuilder' :: NumericPadOption -> TimeZone -> Builder -timeZoneOffsetBuilder' opt (TimeZone t _ _) | t < 0 = s '-' <> showbT opt (negate t) -timeZoneOffsetBuilder' opt (TimeZone t _ _) = s '+' <> showbT opt t -{-# INLINE timeZoneOffsetBuilder' #-} - -timeZoneOffsetBuilder :: TimeZone -> Builder -timeZoneOffsetBuilder = timeZoneOffsetBuilder' $ Just '0' -{-# INLINE timeZoneOffsetBuilder #-} - -zeroOpt :: NumericPadOption -zeroOpt = Just '0' -{-# INLINE zeroOpt #-} -#endif - -instance Show Day where - showb = showbDay - {-# INLINE showb #-} - -instance Show DiffTime where - showb = showbDiffTime - {-# INLINE showb #-} - -instance Show UTCTime where - showb = showbUTCTime - {-# INLINE showb #-} - -instance Show NominalDiffTime where - showb = showbNominalDiffTime - {-# INLINE showb #-} - -instance Show AbsoluteTime where - showb = showbAbsoluteTime - {-# INLINE showb #-} - -instance Show TimeZone where - showb = showbTimeZone - {-# INLINE showb #-} - -instance Show TimeOfDay where - showb = showbTimeOfDay - {-# INLINE showb #-} - -instance Show LocalTime where - showb = showbLocalTime - {-# INLINE showb #-} - -instance Show ZonedTime where - showb = showbZonedTime - {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Tuple.hs b/src/Text/Show/Text/Data/Tuple.hs --- a/src/Text/Show/Text/Data/Tuple.hs +++ b/src/Text/Show/Text/Data/Tuple.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Tuple --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for tuple types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Tuple +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for tuple types. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Tuple ( showbUnit , showb2Tuple @@ -33,301 +34,206 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) +#include "inline.h" + -- | Converts @()@ into a 'Builder'. +-- +-- /Since: 0.3/ showbUnit :: () -> Builder -showbUnit () = "()" +-- showbUnit () = "()" +showbUnit = showb {-# INLINE showbUnit #-} -- | Converts a 2-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb2Tuple :: (Show a, Show b) => (a, b) -> Builder -showb2Tuple (a, b) = - s '(' <> showb a <> - s ',' <> showb b <> - s ')' +showb2Tuple = showb {-# INLINE showb2Tuple #-} -- | Converts a 3-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb3Tuple :: (Show a, Show b, Show c) => (a, b, c) -> Builder -showb3Tuple (a, b, c) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ')' +showb3Tuple = showb {-# INLINE showb3Tuple #-} -- | Converts a 4-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb4Tuple :: (Show a, Show b, Show c, Show d) => (a, b, c, d) -> Builder -showb4Tuple (a, b, c, d) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ')' +showb4Tuple = showb {-# INLINE showb4Tuple #-} -- | Converts a 5-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb5Tuple :: (Show a, Show b, Show c, Show d, Show e) => (a, b, c, d, e) -> Builder -showb5Tuple (a, b, c, d, e) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ')' +showb5Tuple = showb {-# INLINE showb5Tuple #-} -- | Converts a 6-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb6Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f) => (a, b, c, d, e, f) -> Builder -showb6Tuple (a, b, c, d, e, f) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ')' +showb6Tuple = showb {-# INLINE showb6Tuple #-} -- | Converts a 7-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb7Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => (a, b, c, d, e, f, g) -> Builder -showb7Tuple (a, b, c, d, e, f, g) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ')' +showb7Tuple = showb {-# INLINE showb7Tuple #-} -- | Converts an 8-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb8Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h) => (a, b, c, d, e, f, g, h) -> Builder -showb8Tuple (a, b, c, d, e, f, g, h) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ')' +showb8Tuple = showb {-# INLINE showb8Tuple #-} -- | Converts a 9-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb9Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i) => (a, b, c, d, e, f, g, h, i) -> Builder -showb9Tuple (a, b, c, d, e, f, g, h, i) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ')' +showb9Tuple = showb {-# INLINE showb9Tuple #-} -- | Converts a 10-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb10Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j) => (a, b, c, d, e, f, g, h, i, j) -> Builder -showb10Tuple (a, b, c, d, e, f, g, h, i, j) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ',' <> showb j <> - s ')' +showb10Tuple = showb {-# INLINE showb10Tuple #-} -- | Converts an 11-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb11Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k) => (a, b, c, d, e, f, g, h, i, j, k) -> Builder -showb11Tuple (a, b, c, d, e, f, g, h, i, j, k) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ',' <> showb j <> - s ',' <> showb k <> - s ')' +showb11Tuple = showb {-# INLINE showb11Tuple #-} -- | Converts a 12-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb12Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l) => (a, b, c, d, e, f, g, h, i, j, k, l) -> Builder -showb12Tuple (a, b, c, d, e, f, g, h, i, j, k, l) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ',' <> showb j <> - s ',' <> showb k <> - s ',' <> showb l <> - s ')' +showb12Tuple = showb {-# INLINE showb12Tuple #-} -- | Converts a 13-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb13Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m) => (a, b, c, d, e, f, g, h, i, j, k, l, m) -> Builder -showb13Tuple (a, b, c, d, e, f, g, h, i, j, k, l, m) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ',' <> showb j <> - s ',' <> showb k <> - s ',' <> showb l <> - s ',' <> showb m <> - s ')' +showb13Tuple = showb {-# INLINE showb13Tuple #-} -- | Converts a 14-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb14Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m, Show n) => (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> Builder -showb14Tuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ',' <> showb j <> - s ',' <> showb k <> - s ',' <> showb l <> - s ',' <> showb m <> - s ',' <> showb n <> - s ')' +showb14Tuple = showb {-# INLINE showb14Tuple #-} -- | Converts a 15-tuple into a 'Builder'. +-- +-- /Since: 0.3/ showb15Tuple :: (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m, Show n, Show o) => (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> Builder -showb15Tuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ',' <> showb f <> - s ',' <> showb g <> - s ',' <> showb h <> - s ',' <> showb i <> - s ',' <> showb j <> - s ',' <> showb k <> - s ',' <> showb l <> - s ',' <> showb m <> - s ',' <> showb n <> - s ',' <> showb o <> - s ')' +showb15Tuple = showb {-# INLINE showb15Tuple #-} -instance Show () where - showb = showbUnit - {-# INLINE showb #-} +$(deriveShowPragmas defaultInlineShowb ''()) +$(deriveShowPragmas defaultInlineShowb ''(,)) +$(deriveShowPragmas defaultInlineShowb ''(,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,,,)) +$(deriveShowPragmas defaultInlineShowb ''(,,,,,,,,,,,,,,)) -instance (Show a, Show b) => Show (a, b) where - showb = showb2Tuple - {-# INLINE showb #-} +instance Show a => Show1 ((,) a) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c) => Show (a, b, c) where - showb = showb3Tuple - {-# INLINE showb #-} +instance (Show a, Show b) => Show1 ((,,) a b) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where - showb = showb4Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where - showb = showb5Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d) => Show1 ((,,,,) a b c d) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a, b, c, d, e, f) where - showb = showb6Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d, Show e) => Show1 ((,,,,,) a b c d e) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => - Show (a, b, c, d, e, f, g) where - showb = showb7Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show1 ((,,,,,,) a b c d e f) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) +instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => Show1 ((,,,,,,,) a b c d e f g) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h) => - Show (a, b, c, d, e, f, g, h) where - showb = showb8Tuple - {-# INLINE showb #-} + Show1 ((,,,,,,,,) a b c d e f g h) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i) => - Show (a, b, c, d, e, f, g, h, i) where - showb = showb9Tuple - {-# INLINE showb #-} + Show1 ((,,,,,,,,,) a b c d e f g h i) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j) => - Show (a, b, c, d, e, f, g, h, i, j) where - showb = showb10Tuple - {-# INLINE showb #-} - -instance (Show a, Show b, Show c, Show d, Show e, Show f, - Show g, Show h, Show i, Show j, Show k) => - Show (a, b, c, d, e, f, g, h, i, j, k) where - showb = showb11Tuple - {-# INLINE showb #-} + Show1 ((,,,,,,,,,,) a b c d e f g h i j) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e, Show f, - Show g, Show h, Show i, Show j, Show k, Show l) => - Show (a, b, c, d, e, f, g, h, i, j, k, l) where - showb = showb12Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k) => + Show1 ((,,,,,,,,,,,) a b c d e f g h i j k) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, - Show h, Show i, Show j, Show k, Show l, Show m) => - Show (a, b, c, d, e, f, g, h, i, j, k, l, m) where - showb = showb13Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l) => + Show1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, - Show h, Show i, Show j, Show k, Show l, Show m, Show n) => - Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where - showb = showb14Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m) => + Show1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) -instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, - Show i, Show j, Show k, Show l, Show m, Show n, Show o) => - Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where - showb = showb15Tuple - {-# INLINE showb #-} +instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m, Show n) => + Show1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Type/Coercion.hs b/src/Text/Show/Text/Data/Type/Coercion.hs --- a/src/Text/Show/Text/Data/Type/Coercion.hs +++ b/src/Text/Show/Text/Data/Type/Coercion.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE GADTs, NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE GADTs, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Type.Coercion --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for representational equality. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Type.Coercion +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for representational equality. +This module is only available with @base-4.7.0.0@ or later. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Type.Coercion (showbCoercion) where import Data.Text.Lazy.Builder (Builder) @@ -18,14 +20,22 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (mkShowbPrec) -- | Convert a representational equality value to a 'Builder'. +-- This function is only available with @base-4.7.0.0@ or later. +-- +-- /Since: 0.3/ showbCoercion :: Coercion a b -> Builder -showbCoercion Coercion = "Coercion" +showbCoercion = showb {-# INLINE showbCoercion #-} -- TODO: See why 'deriveShow' doesn't detect that b is a phantom type instance Show (Coercion a b) where - showb = showbCoercion + showbPrec = $(mkShowbPrec ''Coercion) {-# INLINE showb #-} + +instance Show1 (Coercion a) where + showbPrec1 = showbPrec + {-# INLINE showbPrec1 #-} diff --git a/src/Text/Show/Text/Data/Type/Equality.hs b/src/Text/Show/Text/Data/Type/Equality.hs --- a/src/Text/Show/Text/Data/Type/Equality.hs +++ b/src/Text/Show/Text/Data/Type/Equality.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE GADTs, NoImplicitPrelude, OverloadedStrings, TypeOperators #-} +{-# LANGUAGE GADTs, TemplateHaskell, TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Type.Equality --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for propositional equality. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Type.Equality +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for propositional equality. +This module is only available with @base-4.7.0.0@ or later. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Type.Equality (showbPropEquality) where import Data.Text.Lazy.Builder (Builder) @@ -18,14 +20,22 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +import Text.Show.Text.TH.Internal (mkShowbPrec) -- | Convert a propositional equality value to a 'Builder'. +-- This function is only available with @base-4.7.0.0@ or later. +-- +-- /Since: 0.3/ showbPropEquality :: (a :~: b) -> Builder -showbPropEquality Refl = "Refl" +showbPropEquality = showb {-# INLINE showbPropEquality #-} -- TODO: See why 'deriveShow' doesn't detect that b is a phantom type instance Show (a :~: b) where - showb = showbPropEquality + showbPrec = $(mkShowbPrec ''(:~:)) {-# INLINE showb #-} + +instance Show1 ((:~:) a) where + showbPrec1 = showbPrec + {-# INLINE showbPrec1 #-} diff --git a/src/Text/Show/Text/Data/Typeable.hs b/src/Text/Show/Text/Data/Typeable.hs --- a/src/Text/Show/Text/Data/Typeable.hs +++ b/src/Text/Show/Text/Data/Typeable.hs @@ -1,45 +1,39 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Typeable --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for data types in the @Typeable@ module. ----------------------------------------------------------------------------- -module Text.Show.Text.Data.Typeable ( - showbTypeRepPrec - , showbTyCon -#if MIN_VERSION_base(4,4,0) - , showbFingerprint -#endif - , showbProxy - ) where +{-| +Module: Text.Show.Text.Data.Typeable +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC -import Data.Monoid (mempty) -import Data.Proxy (Proxy(..)) +Monomorphic 'Show' functions for data types in the @Typeable@ module. + +/Since: 0.3/ +-} +module Text.Show.Text.Data.Typeable (showbTyCon, showbTypeRepPrec) where + import Data.Text.Lazy.Builder (Builder, fromString) import Data.Typeable (TypeRep, typeRepArgs, typeRepTyCon) #if MIN_VERSION_base(4,4,0) import Data.Typeable.Internal (TyCon(..), funTc, listTc) -import GHC.Fingerprint.Type (Fingerprint(..)) #else import Data.Typeable (TyCon, mkTyCon, tyConString, typeOf) #endif -import Data.Word (Word64) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) -import Text.Show.Text.Data.Integral (showbHex) +import Text.Show.Text.Classes (Show(showb, showbPrec), showbParen, showbSpace) import Text.Show.Text.Data.List () -import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) +import Text.Show.Text.Data.Typeable.Utils (showbArgs, showbTuple) +import Text.Show.Text.Utils ((<>), s) +#include "inline.h" + -- | Convert a 'TypeRep' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbTypeRepPrec :: Int -> TypeRep -> Builder showbTypeRepPrec p tyrep = case tys of @@ -52,8 +46,8 @@ xs | isTupleTyCon tycon -> showbTuple xs | otherwise -> showbParen (p > 9) $ showbPrec p tycon - <> s ' ' - <> showbArgs (s ' ') tys + <> showbSpace + <> showbArgs showbSpace tys where tycon = typeRepTyCon tyrep tys = typeRepArgs tyrep @@ -79,43 +73,16 @@ tyconStr = tyConString tycon {-# INLINE isTupleTyCon #-} --- | Helper function for showing a list of arguments, each separated by the given --- 'Builder'. -showbArgs :: Show a => Builder -> [a] -> Builder -showbArgs _ [] = mempty -showbArgs _ [a] = showbPrec 10 a -showbArgs sep (a:as) = showbPrec 10 a <> sep <> showbArgs sep as -{-# INLINE showbArgs #-} - --- | Helper function for showing a list of 'TypeRep's in a tuple. -showbTuple :: [TypeRep] -> Builder -showbTuple args = s '(' <> showbArgs (s ',') args <> s ')' -{-# INLINE showbTuple #-} - -- | Convert a 'TyCon' to a 'Builder'. +-- +-- /Since: 0.3/ showbTyCon :: TyCon -> Builder showbTyCon = fromString . tyConString {-# INLINE showbTyCon #-} --- | Convert a 'Proxy' type to a 'Builder'. -showbProxy :: Proxy s -> Builder -showbProxy _ = "Proxy" -{-# INLINE showbProxy #-} - #if MIN_VERSION_base(4,4,0) --- | Convert a 'Fingerprint' to a 'Builder'. -showbFingerprint :: Fingerprint -> Builder -showbFingerprint (Fingerprint w1 w2) = hex16 w1 <> hex16 w2 - where - hex16 :: Word64 -> Builder - hex16 i = let hex = showbHex i - in replicateB (16 - lengthB hex) (s '0') <> hex -{-# INLINE showbFingerprint #-} -#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'. +-- with base-4.3 and earlier, which use 'tyConString'. tyConString :: TyCon -> String tyConString = tyConName {-# INLINE tyConString #-} @@ -123,19 +90,8 @@ instance Show TypeRep where showbPrec = showbTypeRepPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show TyCon where showb = showbTyCon - {-# INLINE showb #-} - -#if MIN_VERSION_base(4,4,0) -instance Show Fingerprint where - showb = showbFingerprint - {-# INLINE showb #-} -#endif - --- TODO: See why 'deriveShow' can't detect Proxy's phantom type correctly -instance Show (Proxy s) where - showb = showbProxy - {-# INLINE showb #-} + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/Typeable/Utils.hs b/src/Text/Show/Text/Data/Typeable/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Typeable/Utils.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Text.Show.Text.Data.Typeable.Utils +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Utility functions for showing data types in the @Typeable@ (or @OldTypeable@) module. +-} +module Text.Show.Text.Data.Typeable.Utils (showbArgs, showbTuple) where + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mempty) +#endif +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showbPrec)) +import Text.Show.Text.Utils ((<>), s) + +-- | Helper function for showing a list of arguments, each separated by the given +-- 'Builder'. +showbArgs :: Show a => Builder -> [a] -> Builder +showbArgs _ [] = mempty +showbArgs _ [a] = showbPrec 10 a +showbArgs sep (a:as) = showbPrec 10 a <> sep <> showbArgs sep as +{-# INLINE showbArgs #-} + +-- | Helper function for showing a list of 'Show' instances in a tuple. +showbTuple :: Show a => [a] -> Builder +showbTuple args = s '(' <> showbArgs (s ',') args <> s ')' +{-# INLINE showbTuple #-} diff --git a/src/Text/Show/Text/Data/Version.hs b/src/Text/Show/Text/Data/Version.hs --- a/src/Text/Show/Text/Data/Version.hs +++ b/src/Text/Show/Text/Data/Version.hs @@ -1,34 +1,39 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Version --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Version'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Data.Version +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'Version'. + +/Since: 0.3/ +-} module Text.Show.Text.Data.Version ( showbVersionPrec , showbVersionConcrete ) where import Data.List (intersperse) +#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (mconcat) +#endif import Data.Text.Lazy.Builder (Builder, fromString) import Data.Version (Version(..)) -import Text.Show.Text.Class (showb, showbPrec) +import Text.Show.Text.Classes (showb, showbPrec) import Text.Show.Text.Data.Char () import Text.Show.Text.Data.Integral () import Text.Show.Text.Data.List () -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) import Text.Show.Text.Utils ((<>), s) -- | Convert a 'Version' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbVersionPrec :: Int -> Version -> Builder showbVersionPrec = showbPrec {-# INLINE showbVersionPrec #-} @@ -36,10 +41,12 @@ -- | Provides one possible concrete representation for 'Version'. For -- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' -- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@. +-- +-- /Since: 0.3/ showbVersionConcrete :: Version -> Builder showbVersionConcrete (Version branch tags) = mconcat (intersperse (s '.') $ map showb branch) <> mconcat (map ((s '-' <>) . fromString) tags) {-# INLINE showbVersionConcrete #-} -$(deriveShow ''Version) +$(deriveShowPragmas defaultInlineShowbPrec ''Version) diff --git a/src/Text/Show/Text/Data/Void.hs b/src/Text/Show/Text/Data/Void.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Void.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Void +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Void' values. + +/Since: 0.5/ +-} +module Text.Show.Text.Data.Void (showbVoid) where + +import Data.Text.Lazy.Builder (Builder) +import Data.Void (Void, absurd) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showb)) + +#include "inline.h" + +-- | Since 'Void' values logically don't exist, attempting to convert one to a +-- 'Builder' will never terminate. +-- +-- /Since: 0.5/ +showbVoid :: Void -> Builder +showbVoid = absurd +{-# INLINE showbVoid #-} + +instance Show Void where + showb = showbVoid + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Debug/Trace.hs b/src/Text/Show/Text/Debug/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Debug/Trace.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Text.Show.Text.Debug.Trace +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Functions for tracing and monitoring execution. + +These can be useful for investigating bugs or performance problems. +They should /not/ be used in production code. + +/Since: 0.5/ +-} +module Text.Show.Text.Debug.Trace ( + traceIO + , traceIOLazy + , trace + , traceLazy + , traceId + , traceIdLazy + , traceShow + , traceShowId + , traceM + , traceMLazy + , traceShowM +#if MIN_VERSION_base(4,5,0) + , traceStack + , traceStackLazy + , traceEvent + , traceEventLazy + , traceEventIO + , traceEventIOLazy +#endif +#if MIN_VERSION_base(4,7,0) + , traceMarker + , traceMarkerLazy + , traceMarkerIO + , traceMarkerIOLazy +#endif + ) where + +import qualified Data.Text as TS (Text, unpack) +import qualified Data.Text.Lazy as TL (Text, unpack) + +import qualified Debug.Trace as S + +import Prelude hiding (Show(show)) + +import Text.Show.Text.Classes (Show, showLazy) +import Text.Show.Text.Instances () + +-- | The 'traceIO' function outputs the trace message from the IO monad. +-- This sequences the output with respect to other IO actions. +-- +-- /Since: 0.5/ +traceIO :: TS.Text -> IO () +#if MIN_VERSION_base(4,5,0) +traceIO = S.traceIO . TS.unpack +#else +traceIO = S.putTraceMsg . TS.unpack +#endif +{-# INLINE traceIO #-} + +-- | Like 'traceIO' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceIOLazy :: TL.Text -> IO () +#if MIN_VERSION_base(4,5,0) +traceIOLazy = S.traceIO . TL.unpack +#else +traceIOLazy = S.putTraceMsg . TL.unpack +#endif +{-# INLINE traceIOLazy #-} + +{-| +The 'trace' function outputs the trace message given as its first argument, +before returning the second argument as its result. + +For example, this returns the value of @f x@ but first outputs the message. + +> trace ("calling f with x = " <> show x) (f x) + +The 'trace' function should /only/ be used for debugging, or for monitoring +execution. The function is not referentially transparent: its type indicates +that it is a pure function but it has the side effect of outputting the +trace message. + +/Since: 0.5/ +-} +trace :: TS.Text -> a -> a +trace text = S.trace $ TS.unpack text +{-# INLINE trace #-} + +-- | Like 'trace' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceLazy :: TL.Text -> a -> a +traceLazy text = S.trace $ TL.unpack text +{-# INLINE traceLazy #-} + +-- | Like 'trace' but returns the message instead of a third value. +-- +-- /Since: 0.5/ +traceId :: TS.Text -> TS.Text +traceId a = trace a a +{-# INLINE traceId #-} + +-- | Like 'traceId' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceIdLazy :: TL.Text -> TL.Text +traceIdLazy a = traceLazy a a +{-# INLINE traceIdLazy #-} + +{-| +Like 'trace', but uses 'show' on the argument to convert it to a 'TS.Text'. + +This makes it convenient for printing the values of interesting variables or +expressions inside a function. For example here we print the value of the +variables @x@ and @z@: + +> f x y = +> traceShow (x, z) $ result +> where +> z = ... +> ... + +/Since: 0.5/ +-} +traceShow :: Show a => a -> b -> b +traceShow = traceLazy . showLazy +{-# INLINE traceShow #-} + +-- | Like 'traceShow' but returns the shown value instead of a third value. +-- +-- /Since: 0.5/ +traceShowId :: Show a => a -> a +traceShowId a = traceLazy (showLazy a) a +{-# INLINE traceShowId #-} + +{-| +Like 'trace' but returning unit in an arbitrary monad. Allows for convenient +use in do-notation. Note that the application of 'trace' is not an action in the +monad, as 'traceIO' is in the 'IO' monad. + +> ... = do +> x <- ... +> traceM $ "x: " <> show x +> y <- ... +> traceM $ "y: " <> show y + +/Since: 0.5/ +-} +traceM :: Monad m => TS.Text -> m () +traceM text = trace text $ return () +{-# INLINE traceM #-} + +-- | Like 'traceM' but accepts a lazy 'TL.Text' argument. +traceMLazy :: Monad m => TL.Text -> m () +traceMLazy text = traceLazy text $ return () +{-# INLINE traceMLazy #-} + +{-| +Like 'traceM', but uses 'show' on the argument to convert it to a 'TS.Text'. + +> ... = do +> x <- ... +> traceMShow $ x +> y <- ... +> traceMShow $ x + y + +/Since: 0.5/ +-} +traceShowM :: (Show a, Monad m) => a -> m () +traceShowM = traceMLazy . showLazy +{-# INLINE traceShowM #-} + +#if MIN_VERSION_base(4,5,0) +-- | Like 'trace' but additionally prints a call stack if one is +-- available. +-- +-- In the current GHC implementation, the call stack is only +-- availble if the program was compiled with @-prof@; otherwise +-- 'traceStack' behaves exactly like 'trace'. Entries in the call +-- stack correspond to @SCC@ annotations, so it is a good idea to use +-- @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically. +-- +-- /Since: 0.5/ +traceStack :: TS.Text -> a -> a +traceStack text = S.traceStack $ TS.unpack text +{-# INLINE traceStack #-} + +-- | Like 'traceStack' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceStackLazy :: TL.Text -> a -> a +traceStackLazy text = S.traceStack $ TL.unpack text +{-# INLINE traceStackLazy #-} + +-- | The 'traceEvent' function behaves like 'trace' with the difference that +-- the message is emitted to the eventlog, if eventlog profiling is available +-- and enabled at runtime. +-- +-- It is suitable for use in pure code. In an IO context use 'traceEventIO' +-- instead. +-- +-- Note that when using GHC's SMP runtime, it is possible (but rare) to get +-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk +-- that uses 'traceEvent'. +-- +-- /Since: 0.5/ +traceEvent :: TS.Text -> a -> a +traceEvent msg = S.traceEvent $ TS.unpack msg +{-# INLINE traceEvent #-} + +-- | Like 'traceEvent' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceEventLazy :: TL.Text -> a -> a +traceEventLazy msg = S.traceEvent $ TL.unpack msg +{-# INLINE traceEventLazy #-} + +-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog +-- profiling is available and enabled at runtime. +-- +-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to +-- other IO actions. +-- +-- /Since: 0.5/ +traceEventIO :: TS.Text -> IO () +traceEventIO = S.traceEventIO . TS.unpack +{-# INLINE traceEventIO #-} + +-- | Like 'traceEventIO' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceEventIOLazy :: TL.Text -> IO () +traceEventIOLazy = S.traceEventIO . TL.unpack +{-# INLINE traceEventIOLazy #-} +#endif + +#if MIN_VERSION_base(4,7,0) +-- | The 'traceMarker' function emits a marker to the eventlog, if eventlog +-- profiling is available and enabled at runtime. The 'TS.Text' is the name of +-- the marker. The name is just used in the profiling tools to help you keep +-- clear which marker is which. +-- +-- This function is suitable for use in pure code. In an IO context use +-- 'traceMarkerIO' instead. +-- +-- Note that when using GHC's SMP runtime, it is possible (but rare) to get +-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk +-- that uses 'traceMarker'. +-- +-- /Since: 0.5/ +traceMarker :: TS.Text -> a -> a +traceMarker msg = S.traceMarker $ TS.unpack msg +{-# INLINE traceMarker #-} + +-- | Like 'traceMarker' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceMarkerLazy :: TL.Text -> a -> a +traceMarkerLazy msg = S.traceMarker $ TL.unpack msg +{-# INLINE traceMarkerLazy #-} + +-- | The 'traceMarkerIO' function emits a marker to the eventlog, if eventlog +-- profiling is available and enabled at runtime. +-- +-- Compared to 'traceMarker', 'traceMarkerIO' sequences the event with respect to +-- other IO actions. +-- +-- /Since: 0.5/ +traceMarkerIO :: TS.Text -> IO () +traceMarkerIO = S.traceMarkerIO . TS.unpack +{-# INLINE traceMarkerIO #-} + +-- | Like 'traceMarkerIO' but accepts a lazy 'TL.Text' argument. +-- +-- /Since: 0.5/ +traceMarkerIOLazy :: TL.Text -> IO () +traceMarkerIOLazy = S.traceMarkerIO . TL.unpack +{-# INLINE traceMarkerIOLazy #-} +#endif diff --git a/src/Text/Show/Text/Debug/Trace/TH.hs b/src/Text/Show/Text/Debug/Trace/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Debug/Trace/TH.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module: Text.Show.Text.Debug.Trace.TH +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Functions that splice traces into source code which take arbitrary @data@ types or +@newtypes@ as arguments (even if they are not instances of @Show@). You need to +enable the @TemplateHaskell@ language extension in order to use this module. + +/Since: 0.5/ +-} +module Text.Show.Text.Debug.Trace.TH ( + mkTraceShow + , mkTraceShowId + , mkTraceShowM + ) where + +import Language.Haskell.TH.Syntax (Name, Q, Exp) + +import Text.Show.Text.Debug.Trace (traceLazy, traceMLazy) +import Text.Show.Text.TH.Internal (mkShowLazy) + +-- | Generates a lambda expression which outputs the shown trace message of its first +-- argument before returning the second argument. +-- +-- /Since: 0.5/ +mkTraceShow :: Name -> Q Exp +mkTraceShow name = [| traceLazy . $(mkShowLazy name) |] + +-- | Generates a lambda expression which outputs the shown trace message of its +-- argument before returning that argument. +-- +-- /Since: 0.5/ +mkTraceShowId :: Name -> Q Exp +mkTraceShowId name = [| \a -> traceLazy ($(mkShowLazy name) a) a |] + +-- | Generates a lambda expression which outputs the shown trace message of its +-- argument in an arbitrary monad. +-- +-- /Since: 0.5/ +mkTraceShowM :: Name -> Q Exp +mkTraceShowM name = [| traceMLazy . $(mkShowLazy name) |] diff --git a/src/Text/Show/Text/Foreign.hs b/src/Text/Show/Text/Foreign.hs --- a/src/Text/Show/Text/Foreign.hs +++ b/src/Text/Show/Text/Foreign.hs @@ -1,14 +1,13 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Foreign --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' instances for @Foreign@ modules. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Foreign +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Foreign@ modules. +-} module Text.Show.Text.Foreign () where import Text.Show.Text.Foreign.C.Types () diff --git a/src/Text/Show/Text/Foreign/C/Types.hs b/src/Text/Show/Text/Foreign/C/Types.hs --- a/src/Text/Show/Text/Foreign/C/Types.hs +++ b/src/Text/Show/Text/Foreign/C/Types.hs @@ -1,17 +1,23 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, NoImplicitPrelude, StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,5,0) +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +#else +{-# LANGUAGE MagicHash #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Foreign.C.Types --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for Haskell newtypes corresponding to C --- types in the Foreign Function Interface (FFI). ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Foreign.C.Types +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for Haskell newtypes corresponding to C +types in the Foreign Function Interface (FFI). + +/Since: 0.3/ +-} module Text.Show.Text.Foreign.C.Types ( showbCCharPrec , showbCSCharPrec @@ -34,8 +40,10 @@ , showbCUIntMax , showbCClockPrec , showbCTimePrec +#if MIN_VERSION_base(4,4,0) , showbCUSeconds , showbCSUSecondsPrec +#endif , showbCFloatPrec , showbCDoublePrec ) where @@ -46,135 +54,307 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec)) -import Text.Show.Text.Data.Integral () +import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Data.Floating () +import Text.Show.Text.Data.Integral () +#if !(MIN_VERSION_base(4,5,0)) +import GHC.Prim (unsafeCoerce#) + +import Text.Show.Text.Data.Floating (showbDoublePrec, showbFloatPrec) +import Text.Show.Text.Data.Integral ( showbInt8Prec + , showbInt16Prec + , showbInt32Prec + , showbInt64Prec + , showbWord8 + , showbWord16 + , showbWord32 + , showbWord64 + ) + +# include "inline.h" +#endif + -- | Convert a 'CChar' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCCharPrec :: Int -> CChar -> Builder +#if MIN_VERSION_base(4,5,0) showbCCharPrec = showbPrec {-# INLINE showbCCharPrec #-} +#else +showbCCharPrec p c = showbInt8Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CSChar' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCSCharPrec :: Int -> CSChar -> Builder +#if MIN_VERSION_base(4,5,0) showbCSCharPrec = showbPrec {-# INLINE showbCSCharPrec #-} +#else +showbCSCharPrec p c = showbInt8Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CUChar' to a 'Builder'. +-- +-- /Since: 0.3/ showbCUChar :: CUChar -> Builder +#if MIN_VERSION_base(4,5,0) showbCUChar = showb {-# INLINE showbCUChar #-} +#else +showbCUChar c = showbWord8 $ unsafeCoerce# c +#endif -- | Convert a 'CShort' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCShortPrec :: Int -> CShort -> Builder +#if MIN_VERSION_base(4,5,0) showbCShortPrec = showbPrec {-# INLINE showbCShortPrec #-} +#else +showbCShortPrec p c = showbInt16Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CUShort' to a 'Builder'. +-- +-- /Since: 0.3/ showbCUShort :: CUShort -> Builder +#if MIN_VERSION_base(4,5,0) showbCUShort = showb {-# INLINE showbCUShort #-} +#else +showbCUShort c = showbWord16 $ unsafeCoerce# c +#endif -- | Convert a 'CInt' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCIntPrec :: Int -> CInt -> Builder +#if MIN_VERSION_base(4,5,0) showbCIntPrec = showbPrec {-# INLINE showbCIntPrec #-} +#else +showbCIntPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CUInt' to a 'Builder'. +-- +-- /Since: 0.3/ showbCUInt :: CUInt -> Builder +#if MIN_VERSION_base(4,5,0) showbCUInt = showb {-# INLINE showbCUInt #-} +#else +showbCUInt c = showbWord32 $ unsafeCoerce# c +#endif -- | Convert a 'CLong' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCLongPrec :: Int -> CLong -> Builder +#if MIN_VERSION_base(4,5,0) showbCLongPrec = showbPrec {-# INLINE showbCLongPrec #-} +#else +showbCLongPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CULong' to a 'Builder'. +-- +-- /Since: 0.3/ showbCULong :: CULong -> Builder +#if MIN_VERSION_base(4,5,0) showbCULong = showb {-# INLINE showbCULong #-} +#else +showbCULong c = showbWord32 $ unsafeCoerce# c +#endif -- | Convert a 'CPtrdiff' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCPtrdiffPrec :: Int -> CPtrdiff -> Builder +#if MIN_VERSION_base(4,5,0) showbCPtrdiffPrec = showbPrec {-# INLINE showbCPtrdiffPrec #-} +#else +showbCPtrdiffPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CSize' to a 'Builder'. +-- +-- /Since: 0.3/ showbCSize :: CSize -> Builder +#if MIN_VERSION_base(4,5,0) showbCSize = showb {-# INLINE showbCSize #-} +#else +showbCSize c = showbWord32 $ unsafeCoerce# c +#endif -- | Convert a 'CWchar' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCWcharPrec :: Int -> CWchar -> Builder +#if MIN_VERSION_base(4,5,0) showbCWcharPrec = showbPrec {-# INLINE showbCWcharPrec #-} +#else +showbCWcharPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CSigAtomic' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCSigAtomicPrec :: Int -> CSigAtomic -> Builder +#if MIN_VERSION_base(4,5,0) showbCSigAtomicPrec = showbPrec {-# INLINE showbCSigAtomicPrec #-} +#else +showbCSigAtomicPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CLLong' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCLLongPrec :: Int -> CLLong -> Builder +#if MIN_VERSION_base(4,5,0) showbCLLongPrec = showbPrec {-# INLINE showbCLLongPrec #-} +#else +showbCLLongPrec p c = showbInt64Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CULLong' to a 'Builder'. +-- +-- /Since: 0.3/ showbCULLong :: CULLong -> Builder +#if MIN_VERSION_base(4,5,0) showbCULLong = showb {-# INLINE showbCULLong #-} +#else +showbCULLong c = showbWord64 $ unsafeCoerce# c +#endif -- | Convert a 'CIntPtr' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCIntPtrPrec :: Int -> CIntPtr -> Builder +#if MIN_VERSION_base(4,5,0) showbCIntPtrPrec = showbPrec {-# INLINE showbCIntPtrPrec #-} +#else +showbCIntPtrPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CUIntPtr' to a 'Builder'. +-- +-- /Since: 0.3/ showbCUIntPtr :: CUIntPtr -> Builder +#if MIN_VERSION_base(4,5,0) showbCUIntPtr = showb {-# INLINE showbCUIntPtr #-} +#else +showbCUIntPtr c = showbWord32 $ unsafeCoerce# c +#endif -- | Convert a 'CIntMax' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCIntMaxPrec :: Int -> CIntMax -> Builder +#if MIN_VERSION_base(4,5,0) showbCIntMaxPrec = showbPrec {-# INLINE showbCIntMaxPrec #-} +#else +showbCIntMaxPrec p c = showbInt64Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CUIntMax' to a 'Builder'. +-- +-- /Since: 0.3/ showbCUIntMax :: CUIntMax -> Builder +#if MIN_VERSION_base(4,5,0) showbCUIntMax = showb {-# INLINE showbCUIntMax #-} +#else +showbCUIntMax c = showbWord64 $ unsafeCoerce# c +#endif -- | Convert a 'CClock' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCClockPrec :: Int -> CClock -> Builder +#if MIN_VERSION_base(4,5,0) showbCClockPrec = showbPrec {-# INLINE showbCClockPrec #-} +#else +showbCClockPrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif -- | Convert a 'CTime' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCTimePrec :: Int -> CTime -> Builder +#if MIN_VERSION_base(4,5,0) showbCTimePrec = showbPrec {-# INLINE showbCTimePrec #-} +#else +showbCTimePrec p c = showbInt32Prec p $ unsafeCoerce# c +#endif +#if MIN_VERSION_base(4,4,0) -- | Convert a 'CUSeconds' value to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbCUSeconds :: CUSeconds -> Builder +# if MIN_VERSION_base(4,5,0) showbCUSeconds = showb {-# INLINE showbCUSeconds #-} +# else +showbCUSeconds c = showbWord32 $ unsafeCoerce# c +# endif -- | Convert a 'CSUSeconds' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbCSUSecondsPrec :: Int -> CSUSeconds -> Builder +# if MIN_VERSION_base(4,5,0) showbCSUSecondsPrec = showbPrec {-# INLINE showbCSUSecondsPrec #-} +# else +showbCSUSecondsPrec p c = showbInt32Prec p $ unsafeCoerce# c +# endif +#endif -- | Convert a 'CFloat' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCFloatPrec :: Int -> CFloat -> Builder +#if MIN_VERSION_base(4,5,0) showbCFloatPrec = showbPrec {-# INLINE showbCFloatPrec #-} +#else +showbCFloatPrec p c = showbFloatPrec p $ unsafeCoerce# c +#endif -- | Convert a 'CDouble' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCDoublePrec :: Int -> CDouble -> Builder +#if MIN_VERSION_base(4,5,0) showbCDoublePrec = showbPrec {-# INLINE showbCDoublePrec #-} +#else +showbCDoublePrec p c = showbDoublePrec p $ unsafeCoerce# c +#endif +#if MIN_VERSION_base(4,5,0) deriving instance Show CChar deriving instance Show CSChar deriving instance Show CUChar @@ -196,7 +376,112 @@ deriving instance Show CUIntMax deriving instance Show CClock deriving instance Show CTime +# if MIN_VERSION_base(4,4,0) deriving instance Show CUSeconds deriving instance Show CSUSeconds +# endif deriving instance Show CFloat deriving instance Show CDouble +#else +instance Show CChar where + showbPrec = showbCCharPrec + INLINE_INST_FUN(showbPrec) + +instance Show CSChar where + showbPrec = showbCSCharPrec + INLINE_INST_FUN(showbPrec) + +instance Show CUChar where + showb = showbCUChar + INLINE_INST_FUN(showb) + +instance Show CShort where + showbPrec = showbCShortPrec + INLINE_INST_FUN(showbPrec) + +instance Show CUShort where + showb = showbCUShort + INLINE_INST_FUN(showb) + +instance Show CInt where + showbPrec = showbCIntPrec + INLINE_INST_FUN(showbPrec) + +instance Show CUInt where + showb = showbCUInt + INLINE_INST_FUN(showb) + +instance Show CLong where + showbPrec = showbCLongPrec + INLINE_INST_FUN(showbPrec) + +instance Show CULong where + showb = showbCULong + INLINE_INST_FUN(showb) + +instance Show CPtrdiff where + showbPrec = showbCPtrdiffPrec + INLINE_INST_FUN(showbPrec) + +instance Show CSize where + showb = showbCSize + INLINE_INST_FUN(showb) + +instance Show CWchar where + showbPrec = showbCWcharPrec + INLINE_INST_FUN(showbPrec) + +instance Show CSigAtomic where + showbPrec = showbCSigAtomicPrec + INLINE_INST_FUN(showbPrec) + +instance Show CLLong where + showbPrec = showbCLLongPrec + INLINE_INST_FUN(showbPrec) + +instance Show CULLong where + showb = showbCULLong + INLINE_INST_FUN(showb) + +instance Show CIntPtr where + showbPrec = showbCIntPtrPrec + INLINE_INST_FUN(showbPrec) + +instance Show CUIntPtr where + showb = showbCUIntPtr + INLINE_INST_FUN(showb) + +instance Show CIntMax where + showbPrec = showbCIntMaxPrec + INLINE_INST_FUN(showbPrec) + +instance Show CUIntMax where + showb = showbCUIntMax + INLINE_INST_FUN(showb) + +instance Show CClock where + showbPrec = showbCClockPrec + INLINE_INST_FUN(showbPrec) + +instance Show CTime where + showbPrec = showbCTimePrec + INLINE_INST_FUN(showbPrec) + +# if MIN_VERSION_base(4,4,0) +instance Show CUSeconds where + showb = showbCUSeconds + INLINE_INST_FUN(showb) + +instance Show CSUSeconds where + showbPrec = showbCSUSecondsPrec + INLINE_INST_FUN(showbPrec) +# endif + +instance Show CFloat where + showbPrec = showbCFloatPrec + INLINE_INST_FUN(showbPrec) + +instance Show CDouble where + showbPrec = showbCDoublePrec + INLINE_INST_FUN(showbPrec) +#endif diff --git a/src/Text/Show/Text/Foreign/Ptr.hs b/src/Text/Show/Text/Foreign/Ptr.hs --- a/src/Text/Show/Text/Foreign/Ptr.hs +++ b/src/Text/Show/Text/Foreign/Ptr.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} +{-# LANGUAGE CPP, MagicHash #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Foreign.Ptr --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for pointer types used in the Haskell --- Foreign Function Interface (FFI). ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Foreign.Ptr +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for pointer types used in the Haskell +Foreign Function Interface (FFI). + +/Since: 0.3/ +-} module Text.Show.Text.Foreign.Ptr ( showbPtr , showbFunPtr @@ -20,26 +21,29 @@ , showbForeignPtr ) where -import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder (Builder) -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Ptr (FunPtr, IntPtr, WordPtr, castFunPtrToPtr) +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (FunPtr, IntPtr, WordPtr, castFunPtrToPtr) -import GHC.Num (wordToInteger) -import GHC.Ptr (Ptr(..)) -import GHC.Prim (addr2Int#, int2Word#, unsafeCoerce#) +import GHC.ForeignPtr (unsafeForeignPtrToPtr) +import GHC.Num (wordToInteger) +import GHC.Ptr (Ptr(..)) +import GHC.Prim (addr2Int#, int2Word#, unsafeCoerce#) -import Prelude hiding (Show) +import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec)) -import Text.Show.Text.Data.Integral (showbHex, showbIntPrec, showbWord) -import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +import Text.Show.Text.Data.Integral (showbHex, showbIntPrec, showbWord) +import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) #include "MachDeps.h" +#include "inline.h" -- | Convert a 'Ptr' to a 'Builder'. Note that this does not require the parameterized --- type to be an instance of 'Show' itself. +-- type to be an instance of 'Show' itself. +-- +-- /Since: 0.3/ showbPtr :: Ptr a -> Builder showbPtr (Ptr a) = padOut . showbHex $ wordToInteger (int2Word# (addr2Int# a)) where @@ -49,41 +53,61 @@ <> ls -- | Convert a 'FunPtr' to a 'Builder'. Note that this does not require the --- parameterized type to be an instance of 'Show' itself. +-- parameterized type to be an instance of 'Show' itself. +-- +-- /Since: 0.3/ showbFunPtr :: FunPtr a -> Builder showbFunPtr = showb . castFunPtrToPtr {-# INLINE showbFunPtr #-} -- | Convert an 'IntPtr' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbIntPtrPrec :: Int -> IntPtr -> Builder -showbIntPtrPrec k ip = showbIntPrec k $ unsafeCoerce# ip +showbIntPtrPrec p ip = showbIntPrec p $ unsafeCoerce# ip -- | Convert a 'WordPtr' to a 'Builder'. +-- +-- /Since: 0.3/ showbWordPtr :: WordPtr -> Builder showbWordPtr wp = showbWord $ unsafeCoerce# wp -- | Convert a 'ForeignPtr' to a 'Builder'. Note that this does not require the --- parameterized type to be an instance of 'Show' itself. +-- parameterized type to be an instance of 'Show' itself. +-- +-- /Since: 0.3/ showbForeignPtr :: ForeignPtr a -> Builder showbForeignPtr = showb . unsafeForeignPtrToPtr {-# INLINE showbForeignPtr #-} instance Show (Ptr a) where showb = showbPtr - {-# INLINE showb #-} + INLINE_INST_FUN(showb) +instance Show1 Ptr where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + instance Show (FunPtr a) where showb = showbFunPtr - {-# INLINE showb #-} + INLINE_INST_FUN(showb) +instance Show1 FunPtr where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) + instance Show IntPtr where showbPrec = showbIntPtrPrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) instance Show WordPtr where showb = showbWordPtr - {-# INLINE showb #-} + INLINE_INST_FUN(showb) instance Show (ForeignPtr a) where showb = showbForeignPtr - {-# INLINE showb #-} + INLINE_INST_FUN(showb) + +instance Show1 ForeignPtr where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Functions.hs b/src/Text/Show/Text/Functions.hs --- a/src/Text/Show/Text/Functions.hs +++ b/src/Text/Show/Text/Functions.hs @@ -1,27 +1,36 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Functions --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Optional 'Show' instance for functions. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Functions +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Optional 'Show' and 'Show1' instances for functions. + +/Since: 0.3/ +-} module Text.Show.Text.Functions (showbFunction) where import Data.Text.Lazy.Builder (Builder) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) +#include "inline.h" + -- | Convert a function to a 'Builder'. +-- +-- /Since: 0.3/ showbFunction :: (a -> b) -> Builder -showbFunction = const "" +showbFunction _ = "" {-# INLINE showbFunction #-} instance Show (a -> b) where showb = showbFunction - {-# INLINE showb #-} + INLINE_INST_FUN(showb) + +instance Show1 ((->) a) where + showbPrec1 = showbPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/GHC.hs b/src/Text/Show/Text/GHC.hs --- a/src/Text/Show/Text/GHC.hs +++ b/src/Text/Show/Text/GHC.hs @@ -1,21 +1,33 @@ {-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.GHC --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' instances for @GHC@ modules. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.GHC +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @GHC@ modules. +-} module Text.Show.Text.GHC () where +#if defined(mingw32_HOST_OS) +import Text.Show.Text.GHC.Conc.Windows () +#endif #if MIN_VERSION_base(4,4,0) -import Text.Show.Text.GHC.Event () -import Text.Show.Text.GHC.Generics () +# if !defined(mingw32_HOST_OS) +import Text.Show.Text.GHC.Event () +# endif +import Text.Show.Text.GHC.Fingerprint () +import Text.Show.Text.GHC.Generics () #endif +#if MIN_VERSION_base(4,8,0) +import Text.Show.Text.GHC.RTS.Flags () +import Text.Show.Text.GHC.StaticPtr () +#endif #if MIN_VERSION_base(4,5,0) -import Text.Show.Text.GHC.Stats () +import Text.Show.Text.GHC.Stats () +#endif +#if MIN_VERSION_base(4,6,0) +import Text.Show.Text.GHC.TypeLits () #endif diff --git a/src/Text/Show/Text/GHC/Conc/Windows.hs b/src/Text/Show/Text/GHC/Conc/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/Conc/Windows.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +#if !defined(__GHCJS__) +{-# LANGUAGE TemplateHaskell #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.GHC.Conc.Windows +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'ConsoleEvent'. +This module is only available on Windows. + +Note that this module does not export anything on GHCJS. + +/Since: 0.5/ +-} +module Text.Show.Text.GHC.Conc.Windows ( +#if defined(__GHCJS__) + ) where +#else + showbConsoleEvent + ) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.Conc.Windows (ConsoleEvent) + +import Text.Show.Text.Classes (showb) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb) + +-- | Convert a 'ConsoleEvent' to a 'Builder'. +-- +-- /Since: 0.5/ +showbConsoleEvent :: ConsoleEvent -> Builder +showbConsoleEvent = showb +{-# INLINE showbConsoleEvent #-} + +$(deriveShowPragmas defaultInlineShowb ''ConsoleEvent) +#endif diff --git a/src/Text/Show/Text/GHC/Event.hs b/src/Text/Show/Text/GHC/Event.hs --- a/src/Text/Show/Text/GHC/Event.hs +++ b/src/Text/Show/Text/GHC/Event.hs @@ -1,35 +1,50 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.GHC.Stats --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for data types in the @Event@ module. ----------------------------------------------------------------------------- -module Text.Show.Text.GHC.Event (showbEvent, showbFdKeyPrec) where +{-| +Module: Text.Show.Text.GHC.Event +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC -import Data.Text.Lazy.Builder (Builder, fromString) +Monomorphic 'Show' functions for data types in the @Event@ module. +This module is only available with @base-4.4.0.0@ or later and is not available +on Windows. -import GHC.Event (Event, FdKey) +Note that this module does not export anything on GHCJS. -import qualified Prelude as P -import Prelude hiding (Show) +/Since: 0.3/ +-} +module Text.Show.Text.GHC.Event ( +#if defined(__GHCJS__) + ) where +#else + showbEvent + , showbFdKeyPrec + ) where -import Text.Show.Text.Class (Show(showb, showbPrec)) +import Data.Text.Lazy.Builder (Builder) +import GHC.Event (Event, FdKey) +import Prelude hiding (Show) +import Text.Show.Text.Classes (Show(showb, showbPrec), FromStringShow(..)) -- | Convert an 'Event' to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later and is not available +-- on Windows. +-- +-- /Since: 0.3/ showbEvent :: Event -> Builder -showbEvent = fromString . P.show +showbEvent = showb . FromStringShow {-# INLINE showbEvent #-} -- | Convert an 'FdKey' to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later and is not available +-- on Windows. +-- +-- /Since: 0.3/ showbFdKeyPrec :: Int -> FdKey -> Builder -showbFdKeyPrec p fdKey = fromString $ P.showsPrec p fdKey "" +showbFdKeyPrec p = showbPrec p . FromStringShow {-# INLINE showbFdKeyPrec #-} instance Show Event where @@ -39,3 +54,4 @@ instance Show FdKey where showbPrec = showbFdKeyPrec {-# INLINE showbPrec #-} +#endif diff --git a/src/Text/Show/Text/GHC/Fingerprint.hs b/src/Text/Show/Text/GHC/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/Fingerprint.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.GHC.Fingerprint +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Fingerprint' values. +This module is only available with @base-4.4.0.0@ or later. + +/Since: 0.5/ +-} +module Text.Show.Text.GHC.Fingerprint (showbFingerprint) where + +import Data.Text.Lazy.Builder (Builder) +import Data.Word (Word64) + +import GHC.Fingerprint.Type (Fingerprint(..)) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showb)) +import Text.Show.Text.Data.Integral (showbHex) +import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) + +-- | Convert a 'Fingerprint' to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.5/ +showbFingerprint :: Fingerprint -> Builder +showbFingerprint (Fingerprint w1 w2) = hex16 w1 <> hex16 w2 + where + hex16 :: Word64 -> Builder + hex16 i = let hex = showbHex i + in replicateB (16 - lengthB hex) (s '0') <> hex +{-# INLINE showbFingerprint #-} + +instance Show Fingerprint where + showb = showbFingerprint + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/GHC/Generics.hs b/src/Text/Show/Text/GHC/Generics.hs --- a/src/Text/Show/Text/GHC/Generics.hs +++ b/src/Text/Show/Text/GHC/Generics.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, OverloadedStrings, - TemplateHaskell, TypeOperators #-} +{-# LANGUAGE FlexibleContexts, TemplateHaskell, TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.GHC.Generics --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for generics-related data types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.GHC.Generics +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for generics-related data types. +This module is only available with @base-4.4.0.0@ or later. + +/Since: 0.3/ +-} module Text.Show.Text.GHC.Generics ( showbU1 , showbPar1Prec @@ -31,112 +32,144 @@ import GHC.Generics (U1(..), Par1, Rec1(..), K1(..), M1(..), (:+:)(..), (:*:)(..), (:.:)(..), Fixity, Associativity, Arity) -import GHC.Show (appPrec, appPrec1) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Classes (Show(showb, showbPrec), Show1(showbPrec1)) import Text.Show.Text.Data.Integral () -import Text.Show.Text.TH.Internal (deriveShow) -import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb, + defaultInlineShowbPrec, mkShowbPrec) -- | Convert a 'U1' value to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbU1 :: U1 p -> Builder -showbU1 U1 = "U1" +showbU1 = showb {-# INLINE showbU1 #-} -- | Convert a 'Par1' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbPar1Prec :: Show p => Int -> Par1 p -> Builder showbPar1Prec = showbPrec {-# INLINE showbPar1Prec #-} -- | Convert a 'Rec1' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbRec1Prec :: Show (f p) => Int -> Rec1 f p -> Builder -showbRec1Prec p (Rec1 ur) = showbParen (p > appPrec) $ - "Rec1 {unRec1 = " <> showb ur <> s '}' +showbRec1Prec = showbPrec {-# INLINE showbRec1Prec #-} -- | Convert a 'K1' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbK1Prec :: Show c => Int -> K1 i c p -> Builder -showbK1Prec p (K1 uk) = showbParen (p > appPrec) $ - "K1 {unK1 = " <> showb uk <> s '}' +showbK1Prec = showbPrec {-# INLINE showbK1Prec #-} -- | Convert an 'M1' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbM1Prec :: Show (f p) => Int -> M1 i c f p -> Builder -showbM1Prec p (M1 um) = showbParen (p > appPrec) $ - "M1 {unM1 = " <> showb um <> s '}' +showbM1Prec = showbPrec {-# INLINE showbM1Prec #-} -- | Convert a '(:+:)' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbSumTypePrec :: (Show (f p), Show (g p)) => Int -> (f :+: g) p -> Builder -showbSumTypePrec p (L1 l) = showbParen (p > appPrec) $ "L1 " <> showbPrec appPrec1 l -showbSumTypePrec p (R1 r) = showbParen (p > appPrec) $ "R1 " <> showbPrec appPrec1 r +showbSumTypePrec = showbPrec {-# INLINE showbSumTypePrec #-} --- | Convert an '(:*:)' value to a 'Builder' with the given precedence. +-- | Convert a '(:*:)' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbProductTypePrec :: (Show (f p), Show (g p)) => Int -> (f :*: g) p -> Builder -showbProductTypePrec p (l :*: r) = showbParen (p > prec) $ - showbPrec (prec + 1) l - <> " :*: " - <> showbPrec (prec + 1) r - where - prec :: Int - prec = 6 +showbProductTypePrec = showbPrec {-# INLINE showbProductTypePrec #-} --- | Convert an '(:.:)' value to a 'Builder' with the given precedence. +-- | Convert a '(:.:)' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbCompFunctorsPrec :: Show (f (g p)) => Int -> (f :.: g) p -> Builder -showbCompFunctorsPrec p (Comp1 uc) = showbParen (p > appPrec) $ - "Comp1 {unComp1 = " <> showb uc <> s '}' +showbCompFunctorsPrec = showbPrec {-# INLINE showbCompFunctorsPrec #-} -- | Convert a 'Fixity' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbFixityPrec :: Int -> Fixity -> Builder showbFixityPrec = showbPrec {-# INLINE showbFixityPrec #-} -- | Convert an 'Associativity' value to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbAssociativity :: Associativity -> Builder showbAssociativity = showb {-# INLINE showbAssociativity #-} -- | Convert an 'Arity' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbArityPrec :: Int -> Arity -> Builder showbArityPrec = showbPrec {-# INLINE showbArityPrec #-} instance Show (U1 p) where - showb = showbU1 + showbPrec = $(mkShowbPrec ''U1) {-# INLINE showb #-} -$(deriveShow ''Par1) +instance Show1 U1 where + showbPrec1 = showbPrec + {-# INLINE showbPrec1 #-} --- TODO: 'deriveShow' is not smart enough to derive higher-kinded type contexts +$(deriveShowPragmas defaultInlineShowbPrec ''Par1) + +instance Show1 Par1 where + showbPrec1 = showbPrec + {-# INLINE showbPrec1 #-} + instance Show (f p) => Show (Rec1 f p) where - showbPrec = showbRec1Prec + showbPrec = $(mkShowbPrec ''Rec1) {-# INLINE showbPrec #-} instance Show c => Show (K1 i c p) where - showbPrec = showbK1Prec + showbPrec = $(mkShowbPrec ''K1) {-# INLINE showbPrec #-} +instance Show c => Show1 (K1 i c) where + showbPrec1 = showbPrec + {-# INLINE showbPrec1 #-} + instance Show (f p) => Show (M1 i c f p) where - showbPrec = showbM1Prec + showbPrec = $(mkShowbPrec ''M1) {-# INLINE showbPrec #-} instance (Show (f p), Show (g p)) => Show ((f :+: g) p) where - showbPrec = showbSumTypePrec + showbPrec = $(mkShowbPrec ''(:+:)) {-# INLINE showbPrec #-} instance (Show (f p), Show (g p)) => Show ((f :*: g) p) where - showbPrec = showbProductTypePrec + showbPrec = $(mkShowbPrec ''(:*:)) {-# INLINE showbPrec #-} instance Show (f (g p)) => Show ((f :.: g) p) where - showbPrec = showbCompFunctorsPrec + showbPrec = $(mkShowbPrec ''(:.:)) {-# INLINE showbPrec #-} -$(deriveShow ''Fixity) -$(deriveShow ''Associativity) -$(deriveShow ''Arity) +$(deriveShowPragmas defaultInlineShowbPrec ''Fixity) +$(deriveShowPragmas defaultInlineShowb ''Associativity) +$(deriveShowPragmas defaultInlineShowbPrec ''Arity) diff --git a/src/Text/Show/Text/GHC/RTS/Flags.hs b/src/Text/Show/Text/GHC/RTS/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/RTS/Flags.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.GHC.RTS.Flags +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the 'GHC.RTS.Flags' module. +This module is only available with @base-4.8.0.0@ or later. + +/Since: 0.5/ +-} +module Text.Show.Text.GHC.RTS.Flags ( + showbRTSFlagsPrec + , showbGCFlagsPrec + , showbConcFlagsPrec + , showbMiscFlagsPrec + , showbDebugFlagsPrec + , showbCCFlagsPrec + , showbProfFlagsPrec + , showbTraceFlagsPrec + , showbTickyFlagsPrec + ) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.RTS.Flags +import GHC.Show (appPrec) + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showb, showbPrec), showbParen, FromStringShow(..)) +import Text.Show.Text.Data.Bool (showbBool) +import Text.Show.Text.Data.Char () +import Text.Show.Text.Data.Floating (showbDoublePrec) +import Text.Show.Text.Data.Integral (showbIntPrec, showbWord, showbWord64) +import Text.Show.Text.Data.List () +import Text.Show.Text.Data.Maybe (showbMaybePrec) +import Text.Show.Text.Utils ((<>), s) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) + +-- | Convert an 'RTSFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbRTSFlagsPrec :: Int -> RTSFlags -> Builder +showbRTSFlagsPrec = showbPrec +{-# INLINE showbRTSFlagsPrec #-} + +-- | Convert a 'GCFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbGCFlagsPrec :: Int -> GCFlags -> Builder +showbGCFlagsPrec p gcfs = showbParen (p > appPrec) $ + "GCFlags {statsFile = " + <> showbMaybePrec 0 (statsFile gcfs) + <> ", giveStats = " + <> showb (FromStringShow $ giveStats gcfs) + <> ", maxStkSize = " + <> showb (maxStkSize gcfs) + <> ", initialStkSize = " + <> showb (initialStkSize gcfs) + <> ", stkChunkSize = " + <> showb (stkChunkSize gcfs) + <> ", stkChunkBufferSize = " + <> showb (stkChunkBufferSize gcfs) + <> ", maxHeapSize = " + <> showb (maxHeapSize gcfs) + <> ", minAllocAreaSize = " + <> showb (minAllocAreaSize gcfs) + <> ", minOldGenSize = " + <> showb (minOldGenSize gcfs) + <> ", heapSizeSuggestion = " + <> showb (heapSizeSuggestion gcfs) + <> ", heapSizeSuggesionAuto = " + <> showbBool (heapSizeSuggesionAuto gcfs) + <> ", oldGenFactor = " + <> showbDoublePrec 0 (oldGenFactor gcfs) + <> ", pcFreeHeap = " + <> showbDoublePrec 0 (pcFreeHeap gcfs) + <> ", generations = " + <> showb (generations gcfs) + <> ", steps = " + <> showb (steps gcfs) + <> ", squeezeUpdFrames = " + <> showbBool (squeezeUpdFrames gcfs) + <> ", compact = " + <> showbBool (compact gcfs) + <> ", compactThreshold = " + <> showbDoublePrec 0 (compactThreshold gcfs) + <> ", sweep = " + <> showbBool (sweep gcfs) + <> ", ringBell = " + <> showbBool (ringBell gcfs) + <> ", frontpanel = " + <> showbBool (frontpanel gcfs) + <> ", idleGCDelayTime = " + <> showbWord64 (idleGCDelayTime gcfs) + <> ", doIdleGC = " + <> showbBool (doIdleGC gcfs) + <> ", heapBase = " + <> showbWord (heapBase gcfs) + <> ", allocLimitGrace = " + <> showbWord (allocLimitGrace gcfs) + <> s '}' +{-# INLINE showbGCFlagsPrec #-} + +-- | Convert a 'ConcFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbConcFlagsPrec :: Int -> ConcFlags -> Builder +showbConcFlagsPrec = showbPrec +{-# INLINE showbConcFlagsPrec #-} + +-- | Convert a 'MiscFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbMiscFlagsPrec :: Int -> MiscFlags -> Builder +showbMiscFlagsPrec = showbPrec +{-# INLINE showbMiscFlagsPrec #-} + +-- | Convert a 'DebugFlags' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.5/ +showbDebugFlagsPrec :: Int -> DebugFlags -> Builder +showbDebugFlagsPrec = showbPrec +{-# INLINE showbDebugFlagsPrec #-} + +-- | Convert a 'CCFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbCCFlagsPrec :: Int -> CCFlags -> Builder +showbCCFlagsPrec p ccfs = showbParen (p > appPrec) $ + "CCFlags {doCostCentres = " + <> showb (FromStringShow $ doCostCentres ccfs) + <> ", profilerTicks = " + <> showbIntPrec 0 (profilerTicks ccfs) + <> ", msecsPerTick = " + <> showbIntPrec 0 (msecsPerTick ccfs) + <> s '}' +{-# INLINE showbCCFlagsPrec #-} + +-- | Convert a 'ProfFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbProfFlagsPrec :: Int -> ProfFlags -> Builder +showbProfFlagsPrec p pfs = showbParen (p > appPrec) $ + "ProfFlags {doHeapProfile = " + <> showb (FromStringShow $ doHeapProfile pfs) + <> ", heapProfileInterval = " + <> showbWord64 (heapProfileInterval pfs) + <> ", heapProfileIntervalTicks = " + <> showbWord (heapProfileIntervalTicks pfs) + <> ", includeTSOs = " + <> showbBool (includeTSOs pfs) + <> ", showCCSOnException = " + <> showbBool (showCCSOnException pfs) + <> ", maxRetainerSetSize = " + <> showbWord (maxRetainerSetSize pfs) + <> ", ccsLength = " + <> showbWord (ccsLength pfs) + <> ", modSelector = " + <> showbMaybePrec 0 (modSelector pfs) + <> ", descrSelector = " + <> showbMaybePrec 0 (descrSelector pfs) + <> ", typeSelector = " + <> showbMaybePrec 0 (typeSelector pfs) + <> ", ccSelector = " + <> showbMaybePrec 0 (ccSelector pfs) + <> ", ccsSelector = " + <> showbMaybePrec 0 (ccsSelector pfs) + <> ", retainerSelector = " + <> showbMaybePrec 0 (retainerSelector pfs) + <> ", bioSelector = " + <> showbMaybePrec 0 (bioSelector pfs) + <> s '}' +{-# INLINE showbProfFlagsPrec #-} + +-- | Convert a 'TraceFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbTraceFlagsPrec :: Int -> TraceFlags -> Builder +showbTraceFlagsPrec p tfs = showbParen (p > appPrec) $ + "TraceFlags {tracing = " + <> showb (FromStringShow $ tracing tfs) + <> ", timestamp = " + <> showbBool (timestamp tfs) + <> ", traceScheduler = " + <> showbBool (traceScheduler tfs) + <> ", traceGc = " + <> showbBool (traceGc tfs) + <> ", sparksSampled = " + <> showbBool (sparksSampled tfs) + <> ", sparksFull = " + <> showbBool (sparksFull tfs) + <> ", user = " + <> showbBool (user tfs) + <> s '}' +{-# INLINE showbTraceFlagsPrec #-} + +-- | Convert a 'TickyFlags' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbTickyFlagsPrec :: Int -> TickyFlags -> Builder +showbTickyFlagsPrec = showbPrec +{-# INLINE showbTickyFlagsPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''RTSFlags) + +instance Show GCFlags where + showbPrec = showbGCFlagsPrec + {-# INLINE showbPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''ConcFlags) + +$(deriveShowPragmas defaultInlineShowbPrec ''MiscFlags) + +$(deriveShowPragmas defaultInlineShowbPrec ''DebugFlags) + +instance Show CCFlags where + showbPrec = showbCCFlagsPrec + {-# INLINE showbPrec #-} + +instance Show ProfFlags where + showbPrec = showbProfFlagsPrec + {-# INLINE showbPrec #-} + +instance Show TraceFlags where + showbPrec = showbTraceFlagsPrec + {-# INLINE showbPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''TickyFlags) diff --git a/src/Text/Show/Text/GHC/StaticPtr.hs b/src/Text/Show/Text/GHC/StaticPtr.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/StaticPtr.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.GHC.StaticPtr +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'StaticPtrInfo' values. +This module is only available with @base-4.8.0.0@ or later. + +/Since: 0.5/ +-} +module Text.Show.Text.GHC.StaticPtr (showbStaticPtrInfoPrec) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.StaticPtr (StaticPtrInfo) + +import Text.Show.Text.Classes (showbPrec) +import Text.Show.Text.Data.Char () +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.List () +import Text.Show.Text.Data.Tuple () +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) + +-- | Conver a 'StaticPtrInfo' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.8.0.0@ or later. +-- +-- /Since: 0.5/ +showbStaticPtrInfoPrec :: Int -> StaticPtrInfo -> Builder +showbStaticPtrInfoPrec = showbPrec +{-# INLINE showbStaticPtrInfoPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''StaticPtrInfo) diff --git a/src/Text/Show/Text/GHC/Stats.hs b/src/Text/Show/Text/GHC/Stats.hs --- a/src/Text/Show/Text/GHC/Stats.hs +++ b/src/Text/Show/Text/GHC/Stats.hs @@ -1,30 +1,35 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.GHC.Stats --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'GCStats'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.GHC.Stats +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'GCStats'. +This module is only available with @base-4.5.0.0@ or later. + +/Since: 0.3/ +-} module Text.Show.Text.GHC.Stats (showbGCStatsPrec) where import Data.Text.Lazy.Builder (Builder) import GHC.Stats (GCStats) -import Text.Show.Text.Class (showbPrec) +import Text.Show.Text.Classes (showbPrec) import Text.Show.Text.Data.Integral () import Text.Show.Text.Data.Floating () -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) -- | Convert a 'GCStats' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.5.0.0@ or later. +-- +-- /Since: 0.3/ showbGCStatsPrec :: Int -> GCStats -> Builder showbGCStatsPrec = showbPrec {-# INLINE showbGCStatsPrec #-} -$(deriveShow ''GCStats) +$(deriveShowPragmas defaultInlineShowbPrec ''GCStats) diff --git a/src/Text/Show/Text/GHC/TypeLits.hs b/src/Text/Show/Text/GHC/TypeLits.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/TypeLits.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +#if !(MIN_VERSION_base(4,7,0)) +{-# LANGUAGE FlexibleContexts, GADTs, KindSignatures, + OverloadedStrings, PolyKinds, UndecidableInstances #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.GHC.TypeLits +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @GHC.TypeLits@ module. +This module is only available with @base-4.6.0.0@ or later. + +/Since: 0.5/ +-} +module Text.Show.Text.GHC.TypeLits ( +#if MIN_VERSION_base(4,7,0) + showbSomeNatPrec + , showbSomeSymbol +#else + showbIsEven + , showbIsZero +#endif + ) where + +import Data.Text.Lazy.Builder (Builder) +import Prelude hiding (Show) +import Text.Show.Text.Classes (Show(showb, showbPrec)) + +#if MIN_VERSION_base(4,7,0) +import GHC.TypeLits (SomeNat(..), SomeSymbol(..), natVal, symbolVal) +import Text.Show.Text.Data.Char (showbString) +import Text.Show.Text.Data.Integral (showbIntegerPrec) +#else +import GHC.TypeLits (IsEven(..), IsZero(..), Kind, Sing, SingE(fromSing)) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Utils ((<>), s) +#endif + +#if MIN_VERSION_base(4,7,0) +-- | Convert a 'SomeNat' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.7.0.0@ or later. +-- +-- /Since: 0.5/ +showbSomeNatPrec :: Int -> SomeNat -> Builder +showbSomeNatPrec p (SomeNat x) = showbIntegerPrec p $ natVal x +{-# INLINE showbSomeNatPrec #-} + +-- | Convert a 'SomeSymbol' value to a 'Builder' with the given precedence. +-- This function is only available with @base-4.7.0.0@ or later. +-- +-- /Since: 0.5/ +showbSomeSymbol :: SomeSymbol -> Builder +showbSomeSymbol (SomeSymbol x) = showbString $ symbolVal x +{-# INLINE showbSomeSymbol #-} +#else +-- | Convert an 'IsEven' value to a 'Builder'. +-- This function is only available with @base-4.6@. +-- +-- /Since: 0.5/ +showbIsEven :: IsEven n -> Builder +showbIsEven IsEvenZero = s '0' +showbIsEven (IsEven x) = "(2 * " <> showb x <> s ')' +showbIsEven (IsOdd x) = "(2 * " <> showb x <> " + 1)" +{-# INLINE showbIsEven #-} + +-- | Convert an 'IsZero' value to a 'Builder'. +-- This function is only available with @base-4.6@. +-- +-- /Since: 0.5/ +showbIsZero :: IsZero n -> Builder +showbIsZero IsZero = s '0' +showbIsZero (IsSucc n) = s '(' <> showb n <> " + 1)" +{-# INLINE showbIsZero #-} +#endif + +#if MIN_VERSION_base(4,7,0) +instance Show SomeNat where + showbPrec = showbSomeNatPrec + {-# INLINE showbPrec #-} + +instance Show SomeSymbol where + showb = showbSomeSymbol + {-# INLINE showb #-} +#else +instance Show (IsEven n) where + showb = showbIsEven + {-# INLINE showb #-} + +instance Show (IsZero n) where + showb = showbIsZero + {-# INLINE showb #-} + +instance (SingE (Kind :: k) rep, Show rep) => Show (Sing (a :: k)) where + showbPrec p = showbPrec p . fromSing + {-# INLINE showbPrec #-} +#endif diff --git a/src/Text/Show/Text/Instances.hs b/src/Text/Show/Text/Instances.hs --- a/src/Text/Show/Text/Instances.hs +++ b/src/Text/Show/Text/Instances.hs @@ -1,19 +1,19 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Instances --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' instances for all data types covered by @text-show@. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Instances +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for all data types covered by @text-show@. +-} module Text.Show.Text.Instances () where import Text.Show.Text.Control () import Text.Show.Text.Data () import Text.Show.Text.Foreign () import Text.Show.Text.GHC () +import Text.Show.Text.Numeric () import Text.Show.Text.System () import Text.Show.Text.Text () diff --git a/src/Text/Show/Text/Numeric.hs b/src/Text/Show/Text/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Numeric.hs @@ -0,0 +1,13 @@ +{-| +Module: Text.Show.Text.Numeric +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Numeric@ modules. +-} +module Text.Show.Text.Numeric () where + +import Text.Show.Text.Numeric.Natural () diff --git a/src/Text/Show/Text/Numeric/Natural.hs b/src/Text/Show/Text/Numeric/Natural.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Numeric/Natural.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} + +#if defined(MIN_VERSION_integer_gmp) +# define HAVE_GMP_BIGNAT MIN_VERSION_integer_gmp(1,0,0) +#else +# define HAVE_GMP_BIGNAT 0 +#endif + +#if HAVE_GMP_BIGNAT +{-# LANGUAGE MagicHash #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Numeric.Natural +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Natural's. + +/Since: 0.5/ +-} +module Text.Show.Text.Numeric.Natural (showbNaturalPrec) where + +import Data.Text.Lazy.Builder (Builder) + +#if HAVE_GMP_BIGNAT +import GHC.Integer.GMP.Internals (Integer(..)) +import GHC.Types (Word(..)) + +import Text.Show.Text.Data.Integral (showbWord) +#endif + +#if MIN_VERSION_base(4,8,0) +import GHC.Natural (Natural(..)) +#else +import Numeric.Natural (Natural) +#endif + +import Prelude hiding (Show) + +import Text.Show.Text.Classes (Show(showbPrec)) +import Text.Show.Text.Data.Integral (showbIntegerPrec) + +#include "inline.h" + +-- | Convert a 'Natural' to a 'Builder' with the given precedence. +-- +-- /Since: 0.5/ +showbNaturalPrec :: Int -> Natural -> Builder +#if MIN_VERSION_base(4,8,0) +# if HAVE_GMP_BIGNAT +showbNaturalPrec _ (NatS# w#) = showbWord $ W# w# +showbNaturalPrec p (NatJ# bn) = showbIntegerPrec p $ Jp# bn +# else +showbNaturalPrec p (Natural i) = showbIntegerPrec p i +{-# INLINE showbNaturalPrec #-} +# endif +#else +showbNaturalPrec p = showbIntegerPrec p . toInteger +{-# INLINE showbNaturalPrec #-} +#endif + +instance Show Natural where + showbPrec = showbNaturalPrec + INLINE_INST_FUN(showbPrec) diff --git a/src/Text/Show/Text/System.hs b/src/Text/Show/Text/System.hs --- a/src/Text/Show/Text/System.hs +++ b/src/Text/Show/Text/System.hs @@ -1,14 +1,13 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.System --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' functions for @System@ modules. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.System +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @System@ modules. +-} module Text.Show.Text.System () where import Text.Show.Text.System.Exit () diff --git a/src/Text/Show/Text/System/Exit.hs b/src/Text/Show/Text/System/Exit.hs --- a/src/Text/Show/Text/System/Exit.hs +++ b/src/Text/Show/Text/System/Exit.hs @@ -1,29 +1,32 @@ {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Data.Monoid --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'ExitCode'. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.System.Exit +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'ExitCode'. + +/Since: 0.3/ +-} module Text.Show.Text.System.Exit (showbExitCodePrec) where import Data.Text.Lazy.Builder (Builder) import System.Exit (ExitCode) -import Text.Show.Text.Class (showbPrec) +import Text.Show.Text.Classes (showbPrec) import Text.Show.Text.Data.Integral () -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowbPrec) -- | Convert an 'ExitCode' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbExitCodePrec :: Int -> ExitCode -> Builder showbExitCodePrec = showbPrec {-# INLINE showbExitCodePrec #-} -$(deriveShow ''ExitCode) +$(deriveShowPragmas defaultInlineShowbPrec ''ExitCode) diff --git a/src/Text/Show/Text/System/IO.hs b/src/Text/Show/Text/System/IO.hs --- a/src/Text/Show/Text/System/IO.hs +++ b/src/Text/Show/Text/System/IO.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, TemplateHaskell #-} +{-# LANGUAGE CPP, OverloadedStrings, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.System.IO --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for 'IO'-related data types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.System.IO +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'IO'-related data types. + +/Since: 0.3/ +-} module Text.Show.Text.System.IO ( showbHandle , showbIOMode @@ -30,6 +31,8 @@ import Data.Text.Lazy.Builder (Builder, fromString) +#include "inline.h" + #if MIN_VERSION_base(4,3,0) import GHC.IO.Encoding.Types (TextEncoding(textEncodingName)) #endif @@ -44,13 +47,16 @@ import System.IO (BufferMode, IOMode, Newline, NewlineMode, SeekMode) -import Text.Show.Text.Class (Show(showb, showbPrec)) +import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Data.Integral (showbIntegerPrec) import Text.Show.Text.Data.Maybe () -import Text.Show.Text.TH.Internal (deriveShow) +import Text.Show.Text.TH.Internal (deriveShowPragmas, defaultInlineShowb, + defaultInlineShowbPrec) import Text.Show.Text.Utils ((<>), s) -- | Convert a 'Handle' to a 'Builder'. +-- +-- /Since: 0.3/ showbHandle :: Handle -> Builder showbHandle (FileHandle file _) = showbHandleFilePath file showbHandle (DuplexHandle file _ _) = showbHandleFilePath file @@ -62,28 +68,39 @@ {-# INLINE showbHandleFilePath #-} -- | Convert an 'IOMode' to a 'Builder'. +-- +-- /Since: 0.3/ showbIOMode :: IOMode -> Builder showbIOMode = showb {-# INLINE showbIOMode #-} -- | Convert a 'BufferMode' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbBufferModePrec :: Int -> BufferMode -> Builder showbBufferModePrec = showbPrec {-# INLINE showbBufferModePrec #-} -- | Convert a 'HandlePosn' to a 'Builder'. +-- +-- /Since: 0.3/ showbHandlePosn :: HandlePosn -> Builder showbHandlePosn (HandlePosn h pos) = showbHandle h <> " at position " <> showbIntegerPrec 0 pos {-# INLINE showbHandlePosn #-} -- | Convert a 'SeekMode' to a 'Builder'. +-- +-- /Since: 0.3/ showbSeekMode :: SeekMode -> Builder showbSeekMode = showb {-# INLINE showbSeekMode #-} #if MIN_VERSION_base(4,3,0) -- | Convert a 'TextEncoding' to a 'Builder'. +-- This function is only available with @base-4.3.0.0@ or later. +-- +-- /Since: 0.3/ showbTextEncoding :: TextEncoding -> Builder showbTextEncoding = fromString . textEncodingName {-# INLINE showbTextEncoding #-} @@ -91,49 +108,59 @@ #if MIN_VERSION_base(4,4,0) -- | Convert a 'CodingProgress' to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbCodingProgress :: CodingProgress -> Builder showbCodingProgress = showb {-# INLINE showbCodingProgress #-} -- | Convert a 'CodingFailureMode' value to a 'Builder'. +-- This function is only available with @base-4.4.0.0@ or later. +-- +-- /Since: 0.3/ showbCodingFailureMode :: CodingFailureMode -> Builder showbCodingFailureMode = showb {-# INLINE showbCodingFailureMode #-} #endif -- | Convert a 'Newline' to a 'Builder'. +-- +-- /Since: 0.3/ showbNewline :: Newline -> Builder showbNewline = showb {-# INLINE showbNewline #-} -- | Convert a 'NewlineMode' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbNewlineModePrec :: Int -> NewlineMode -> Builder showbNewlineModePrec = showbPrec {-# INLINE showbNewlineModePrec #-} instance Show Handle where showb = showbHandle - {-# INLINE showb #-} + INLINE_INST_FUN(showb) -$(deriveShow ''IOMode) -$(deriveShow ''BufferMode) +$(deriveShowPragmas defaultInlineShowb ''IOMode) +$(deriveShowPragmas defaultInlineShowbPrec ''BufferMode) instance Show HandlePosn where showb = showbHandlePosn - {-# INLINE showb #-} + INLINE_INST_FUN(showb) -$(deriveShow ''SeekMode) +$(deriveShowPragmas defaultInlineShowb ''SeekMode) #if MIN_VERSION_base(4,3,0) instance Show TextEncoding where showb = showbTextEncoding - {-# INLINE showb #-} + INLINE_INST_FUN(showb) #endif #if MIN_VERSION_base(4,4,0) -$(deriveShow ''CodingProgress) -$(deriveShow ''CodingFailureMode) +$(deriveShowPragmas defaultInlineShowb ''CodingProgress) +$(deriveShowPragmas defaultInlineShowb ''CodingFailureMode) #endif -$(deriveShow ''Newline) -$(deriveShow ''NewlineMode) +$(deriveShowPragmas defaultInlineShowb ''Newline) +$(deriveShowPragmas defaultInlineShowbPrec ''NewlineMode) diff --git a/src/Text/Show/Text/System/Posix/Types.hs b/src/Text/Show/Text/System/Posix/Types.hs --- a/src/Text/Show/Text/System/Posix/Types.hs +++ b/src/Text/Show/Text/System/Posix/Types.hs @@ -1,31 +1,66 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, NoImplicitPrelude, StandaloneDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, StandaloneDeriving #-} +#if !(MIN_VERSION_base(4,5,0)) +{-# LANGUAGE MagicHash #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.System.Posix.Types --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' functions for Haskell equivalents of POSIX data types. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.System.Posix.Types +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for Haskell equivalents of POSIX data types. +Note that these functions are only available if the operating system supports them, +so some OSes (e.g., Windows) will not be able to use all of the functions in this +module. + +/Since: 0.3/ +-} +#include "HsBaseConfig.h" + module Text.Show.Text.System.Posix.Types ( - showbCDev + showbFdPrec +#if defined(HTYPE_DEV_T) + , showbCDev +#endif +#if defined(HTYPE_INO_T) , showbCIno +#endif +#if defined(HTYPE_MODE_T) , showbCMode +#endif +#if defined(HTYPE_OFF_T) , showbCOffPrec +#endif +#if defined(HTYPE_PID_T) , showbCPidPrec +#endif +#if defined(HTYPE_SSIZE_T) , showbCSsizePrec +#endif +#if defined(HTYPE_GID_T) , showbCGid +#endif +#if defined(HTYPE_NLINK_T) , showbCNlink +#endif +#if defined(HTYPE_UID_T) , showbCUid +#endif +#if defined(HTYPE_CC_T) , showbCCc +#endif +#if defined(HTYPE_SPEED_T) , showbCSpeed +#endif +#if defined(HTYPE_TCFLAG_T) , showbCTcflag +#endif +#if defined(HTYPE_RLIM_T) , showbCRLim - , showbFdPrec +#endif ) where import Data.Text.Lazy.Builder (Builder) @@ -34,91 +69,329 @@ import System.Posix.Types -import Text.Show.Text.Class (Show(showb, showbPrec)) +import Text.Show.Text.Classes (Show(showb, showbPrec)) import Text.Show.Text.Data.Integral () import Text.Show.Text.Foreign.C.Types () +#if !(MIN_VERSION_base(4,5,0)) +import GHC.Prim (unsafeCoerce#) + +import Text.Show.Text.Data.Integral ( showbInt32Prec + , showbInt64Prec + , showbWord8 + , showbWord32 + , showbWord64 + ) + +# include "inline.h" +#endif + +#if defined(HTYPE_DEV_T) -- | Convert a 'CDev' to a 'Builder'. +-- +-- /Since: 0.3/ showbCDev :: CDev -> Builder +# if MIN_VERSION_base(4,5,0) showbCDev = showb {-# INLINE showbCDev #-} +# else +showbCDev c = showbWord64 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_INO_T) -- | Convert a 'CIno' to a 'Builder'. +-- +-- /Since: 0.3/ showbCIno :: CIno -> Builder +# if MIN_VERSION_base(4,5,0) showbCIno = showb {-# INLINE showbCIno #-} +# else +showbCIno c = showbWord64 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_MODE_T) -- | Convert a 'CMode' to a 'Builder'. +-- +-- /Since: 0.3/ showbCMode :: CMode -> Builder +# if MIN_VERSION_base(4,5,0) showbCMode = showb {-# INLINE showbCMode #-} +# else +showbCMode c = showbWord32 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_OFF_T) -- | Convert a 'COff' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCOffPrec :: Int -> COff -> Builder +# if MIN_VERSION_base(4,5,0) showbCOffPrec = showbPrec {-# INLINE showbCOffPrec #-} +# else +showbCOffPrec p c = showbInt64Prec p $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_PID_T) -- | Convert a 'CPid' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCPidPrec :: Int -> CPid -> Builder +# if MIN_VERSION_base(4,5,0) showbCPidPrec = showbPrec {-# INLINE showbCPidPrec #-} +# else +showbCPidPrec p c = showbInt32Prec p $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_SSIZE_T) -- | Convert a 'CSsize' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbCSsizePrec :: Int -> CSsize -> Builder +# if MIN_VERSION_base(4,5,0) showbCSsizePrec = showbPrec {-# INLINE showbCSsizePrec #-} +# else +showbCSsizePrec p c = showbInt32Prec p $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_GID_T) -- | Convert a 'CGid' to a 'Builder'. +-- +-- /Since: 0.3/ showbCGid :: CGid -> Builder +# if MIN_VERSION_base(4,5,0) showbCGid = showb {-# INLINE showbCGid #-} +# else +showbCGid c = showbWord32 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_NLINK_T) -- | Convert a 'CNlink' to a 'Builder'. +-- +-- /Since: 0.3/ showbCNlink :: CNlink -> Builder +# if MIN_VERSION_base(4,5,0) showbCNlink = showb {-# INLINE showbCNlink #-} +# else +showbCNlink c = showbWord32 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_UID_T) -- | Convert a 'CUid' to a 'Builder'. +-- +-- /Since: 0.3/ showbCUid :: CUid -> Builder +# if MIN_VERSION_base(4,5,0) showbCUid = showb {-# INLINE showbCUid #-} +# else +showbCUid c = showbWord32 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_CC_T) -- | Convert a 'CCc' to a 'Builder'. +-- +-- /Since: 0.3/ showbCCc :: CCc -> Builder +# if MIN_VERSION_base(4,5,0) showbCCc = showb {-# INLINE showbCCc #-} +# else +showbCCc c = showbWord8 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_SPEED_T) -- | Convert a 'CSpeed' to a 'Builder'. +-- +-- /Since: 0.3/ showbCSpeed :: CSpeed -> Builder +# if MIN_VERSION_base(4,5,0) showbCSpeed = showb {-# INLINE showbCSpeed #-} +# else +showbCSpeed c = showbWord32 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_TCFLAG_T) -- | Convert a 'CTcflag' to a 'Builder'. +-- +-- /Since: 0.3/ showbCTcflag :: CTcflag -> Builder +# if MIN_VERSION_base(4,5,0) showbCTcflag = showb {-# INLINE showbCTcflag #-} +# else +showbCTcflag c = showbWord32 $ unsafeCoerce# c +# endif +#endif +#if defined(HTYPE_RLIM_T) -- | Convert a 'CRLim' to a 'Builder'. +-- +-- /Since: 0.3/ showbCRLim :: CRLim -> Builder +# if MIN_VERSION_base(4,5,0) showbCRLim = showb {-# INLINE showbCRLim #-} +# else +showbCRLim c = showbWord64 $ unsafeCoerce# c +# endif +#endif -- | Convert an 'Fd' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbFdPrec :: Int -> Fd -> Builder showbFdPrec = showbPrec {-# INLINE showbFdPrec #-} +#if MIN_VERSION_base(4,5,0) +# if defined(HTYPE_DEV_T) deriving instance Show CDev +# endif + +# if defined(HTYPE_INO_T) deriving instance Show CIno +# endif + +# if defined(HTYPE_MODE_T) deriving instance Show CMode +# endif + +# if defined(HTYPE_OFF_T) deriving instance Show COff +# endif + +# if defined(HTYPE_PID_T) deriving instance Show CPid +# endif + +# if defined(HTYPE_SSIZE_T) deriving instance Show CSsize +# endif + +# if defined(HTYPE_GID_T) deriving instance Show CGid +# endif + +# if defined(HTYPE_NLINK_T) deriving instance Show CNlink +# endif + +# if defined(HTYPE_UID_T) deriving instance Show CUid +# endif + +# if defined(HTYPE_CC_T) deriving instance Show CCc +# endif + +# if defined(HTYPE_SPEED_T) deriving instance Show CSpeed +# endif + +# if defined(HTYPE_TCFLAG_T) deriving instance Show CTcflag +# endif + +# if defined(HTYPE_RLIM_T) deriving instance Show CRLim +# endif +#else +# if defined(HTYPE_DEV_T) +instance Show CDev where + showb = showbCDev + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_INO_T) +instance Show CIno where + showb = showbCIno + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_MODE_T) +instance Show CMode where + showb = showbCMode + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_OFF_T) +instance Show COff where + showbPrec = showbCOffPrec + INLINE_INST_FUN(showbPrec) +# endif + +# if defined(HTYPE_PID_T) +instance Show CPid where + showbPrec = showbCPidPrec + INLINE_INST_FUN(showbPrec) +# endif + +# if defined(HTYPE_SSIZE_T) +instance Show CSsize where + showbPrec = showbCSsizePrec + INLINE_INST_FUN(showbPrec) +# endif + +# if defined(HTYPE_GID_T) +instance Show CGid where + showb = showbCGid + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_NLINK_T) +instance Show CNlink where + showb = showbCNlink + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_UID_T) +instance Show CUid where + showb = showbCUid + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_CC_T) +instance Show CCc where + showb = showbCCc + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_SPEED_T) +instance Show CSpeed where + showb = showbCSpeed + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_TCFLAG_T) +instance Show CTcflag where + showb = showbCTcflag + INLINE_INST_FUN(showb) +# endif + +# if defined(HTYPE_RLIM_T) +instance Show CRLim where + showb = showbCRLim + INLINE_INST_FUN(showb) +# endif +#endif + deriving instance Show Fd diff --git a/src/Text/Show/Text/TH.hs b/src/Text/Show/Text/TH.hs --- a/src/Text/Show/Text/TH.hs +++ b/src/Text/Show/Text/TH.hs @@ -1,16 +1,17 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.TH --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Functions to mechanically derive 'Show' instances or splice --- 'show'-related expressions into Haskell source code. You need to enable --- the @TemplateHaskell@ language extension in order to use this module. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.TH +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Functions to mechanically derive @Show@ instances or splice +@show@-related expressions into Haskell source code. You need to enable +the @TemplateHaskell@ language extension in order to use this module. + +/Since: 0.3/ +-} module Text.Show.Text.TH (module Text.Show.Text.TH.Internal) where import Text.Show.Text.Instances () diff --git a/src/Text/Show/Text/TH/Internal.hs b/src/Text/Show/Text/TH/Internal.hs --- a/src/Text/Show/Text/TH/Internal.hs +++ b/src/Text/Show/Text/TH/Internal.hs @@ -1,45 +1,51 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.TH.Internal --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Functions to mechanically derive 'Show' instances or splice --- 'show'-related expressions into Haskell source code. You need to enable --- the @TemplateHaskell@ language extension in order to use this module. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP, TemplateHaskell #-} +{-| +Module: Text.Show.Text.TH.Internal +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Functions to mechanically derive 'T.Show' instances or splice +@show@-related expressions into Haskell source code. You need to enable +the @TemplateHaskell@ language extension in order to use this module. +-} module Text.Show.Text.TH.Internal ( -- * @deriveShow@ -- $deriveShow deriveShow + , deriveShowPragmas -- * @mk@ functions -- $mk , mkShow , mkShowLazy , mkShowPrec , mkShowPrecLazy --- , mkShowList --- , mkShowListLazy + , mkShowList + , mkShowListLazy , mkShowb , mkShowbPrec --- , mkShowbList + , mkShowbList , mkPrint , mkPrintLazy , mkHPrint , mkHPrintLazy + -- * Advanced pragma options + , PragmaOptions(..) + , defaultPragmaOptions + , defaultInlineShowbPrec + , defaultInlineShowb + , defaultInlineShowbList ) where import Control.Applicative ((<$>)) -import Data.List (foldl') +import Data.List (foldl', intersperse, isPrefixOf) 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, toLazyText) +import Data.Text.Lazy.Builder (fromString, toLazyText) import qualified Data.Text.Lazy as TL () import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn) @@ -47,15 +53,20 @@ import Language.Haskell.TH -import qualified Prelude as P import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import qualified Text.Show as S (Show(show)) +import qualified Text.Show.Text.Classes as T (Show) +import Text.Show.Text.Classes (showb, showbPrec, showbListDefault, + showbParen, showbSpace) +#if __GLASGOW_HASKELL__ >= 702 +import Text.Show.Text.Classes (showbList) +#endif import Text.Show.Text.Utils ((<>), s) {- $deriveShow -'deriveShow' automatically generates a 'Show' instance declaration for a @data@ +'deriveShow' automatically generates a 'T.Show' instance declaration for a @data@ type or @newtype@. As an example: @ @@ -69,46 +80,142 @@ , testTwo :: Bool , testThree :: D a } -$(deriveShow ''D) +$('deriveShow' 'defaultOptions' ''D) @ -@D@ now has a 'Show' instance equivalent to that which would be generated -by a @deriving Show@ clause. +@D@ now has a 'T.Show' instance analogous to what would be generated by a +@deriving Show@ clause. -Note that at the moment, 'deriveShow' does not support data families, -so it is impossible to use 'deriveShow' with @data instance@s or @newtype -instance@s. Also, 'deriveShow' lacks the ability to properly detect data types -with higher-kinded type parameters (e.g., @data HK f a = HK (f a)@), so it cannot -create instances for them either. +Note that at the moment, there are a number of limitations to this approach: +* 'deriveShow' does not support data families, so it is impossible to use + 'deriveShow' with @data instance@s or @newtype instance@s. + +* 'deriveShow' lacks the ability to properly detect data types with higher-kinded + type parameters (e.g., @data HK f a = HK (f a)@). If you wish to derive 'T.Show' + instances for these data types, you will need to use 'mkShowbPrec' (see the + documentation of the 'mk' functions for more information). + +* Some data constructors have arguments whose 'T.Show' instance depends on a + typeclass besides 'T.Show'. For example, consider @newtype MyRatio a = MyRatio + (Ratio a)@. @'Ratio' a@ is a 'T.Show' instance only if @a@ is an instance of both + 'Integral' and 'T.Show'. Unfortunately, 'deriveShow' cannot infer that 'a' must + be an instance of 'Integral', so it cannot create a 'T.Show' instance for @MyRatio@. However, you can use 'mkShowbPrec' to get around this (see the documentation of the + 'mk' functions for more information). + -} --- | Generates a 'Show' instance declaration for the given @data@ type or @newtype@. -deriveShow :: Name -> Q [Dec] -deriveShow name = withType name $ \tvbs cons -> (:[]) <$> fromCons tvbs cons +-- | Generates a 'T.Show' instance declaration for the given @data@ type or @newtype@. +-- +-- /Since: 0.3/ +deriveShow :: Name -- ^ Name of the data type to make an instance of 'T.Show' + -> Q [Dec] +deriveShow = deriveShowPragmas defaultPragmaOptions + +-- | Generates a 'T.Show' instance declaration for the given @data@ type or @newtype@. +-- You shouldn't need to use this function unless you know what you are doing. +-- +-- Unlike 'deriveShow', this function allows configuration of whether to inline +-- 'showbPrec', 'showb', or 'showbList'. It also allows for specializing instances +-- certain types. For example: +-- +-- @ +-- data ADT a = ADT a +-- $(deriveShowPragmas 'defaultInlineShowbPrec' { +-- specializeTypes = [t| Int |] +-- } +-- ''ADT) +-- @ +-- +-- This declararation would produce code like this: +-- +-- @ +-- instance Show a => Show (ADT a) where +-- {-# INLINE showbPrec #-} +-- {-# SPECIALIZE instance Show (ADT Int) #-} +-- showbPrec = ... +-- @ +-- +-- /Since: 0.5/ +deriveShowPragmas :: PragmaOptions -- ^ Specifies what pragmas to generate with this instance + -> Name -- ^ Name of the data type to make an instance of 'T.Show' + -> Q [Dec] +#if __GLASGOW_HASKELL__ >= 702 +deriveShowPragmas opts dataName = +#else +deriveShowPragmas _ dataName = +#endif + withType dataName $ \tvbs cons -> (:[]) <$> fromCons tvbs cons where fromCons :: [TyVarBndr] -> [Con] -> Q Dec - fromCons tvbs cons = instanceD cxt' - (appT classType type') - [ funD 'showbPrec [ clause [] (normalB $ consToShow cons) [] - ] - ] + fromCons tvbs cons = + instanceD (applyCon ''T.Show typeNames dataName) + (appT classType instanceType) + ([ funD 'showbPrec [ clause [] + (normalB $ consToShow cons) + [] + ] + ] ++ inlineShowbPrecDec + ++ inlineShowbDec + ++ inlineShowbListDec + ++ specializeDecs + ) + where + typeNames :: [Name] + typeNames = map tvbName tvbs + + instanceType :: Q Type + instanceType = foldl' appT (conT dataName) $ map varT typeNames + classType :: Q Type - classType = conT ''Show + classType = conT ''T.Show - cxt' :: Q Cxt - type' :: Q Type - (cxt', type') = instanceCtxType name tvbs + inlineShowbPrecDec, inlineShowbDec, inlineShowbListDec :: [Q Dec] +#if __GLASGOW_HASKELL__ >= 702 + inlineShowbPrecDec = inline inlineShowbPrec 'showbPrec + inlineShowbDec = inline inlineShowb 'showb + inlineShowbListDec = inline inlineShowbList 'showbList +#else + inlineShowbPrecDec = [] + inlineShowbDec = [] + inlineShowbListDec = [] +#endif + +#if __GLASGOW_HASKELL__ >= 702 + inline :: (PragmaOptions -> Bool) -> Name -> [Q Dec] + inline isInlining funName + | isInlining opts = [ pragInlD funName +# if MIN_VERSION_template_haskell(2,8,0) + Inline FunLike AllPhases +# else + (inlineSpecNoPhase True False) +# endif + ] + | otherwise = [] +#endif + + specializeDecs :: [Q Dec] +#if MIN_VERSION_template_haskell(2,8,0) + specializeDecs = (fmap . fmap) (PragmaD + . SpecialiseInstP + . AppT (ConT ''T.Show) + ) + (specializeTypes opts) +#else + -- There doesn't appear to be an equivalent of SpecialiseInstP in early + -- versions Template Haskell. + specializeDecs = [] +#endif {- $mk There may be scenarios in which you want to show an arbitrary @data@ type or @newtype@ -without having to make the type an instance of 'Show'. For these cases, +without having to make the type an instance of 'T.Show'. For these cases, "Text.Show.Text.TH" provide several functions (all prefixed with @mk@) that splice the appropriate lambda expression into your source code. -As an example, suppose you have @data ADT = ADTCon@, which is not an instance of 'Show'. +As an example, suppose you have @data ADT = ADTCon@, which is not an instance of 'T.Show'. With @mkShow@, you can still convert it to 'Text': @ @@ -118,130 +225,219 @@ whichADT = $(mkShow ''ADT) ADTCon == \"ADT\" @ -Note that due the order in which Template Haskell executes splices, the above code -may fail to compile if @ADT@ is located in the same module and @whichADT@. To get -around this, you can use the following hack: +'mk' functions are also useful for creating 'T.Show' instances for data types with +sophisticated type parameters. For example, 'deriveShow' cannot infer the correct type +context for @newtype HigherKinded f a = HigherKinded (f a)@, since @f@ is a +higher-kinded type parameter. However, it is still possible to derive a 'T.Show' +instance for @HigherKinded@ without too much trouble using 'mkShowbPrec': @ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} - -data ADT = ADTCon -$(return []) +{-# LANGUAGE TemplateHaskell #-} -whichADT :: Bool -whichADT = $(mkShow ''ADT) ADTCon == \"ADT\" +instance Show (f a) => Show (HigherKinded f a) where + showbPrec = $(mkShowbPrec ''HigherKinded) @ -} --- | --- Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given @data@ type or @newtype@ -- to a strict 'TS.Text'. +-- +-- /Since: 0.3.1/ mkShow :: Name -> Q Exp mkShow name = [| toStrict . $(mkShowLazy name) |] --- | --- Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given @data@ type or @newtype@ -- to a lazy 'TL.Text'. +-- +-- /Since: 0.3.1/ mkShowLazy :: Name -> Q Exp mkShowLazy name = [| toLazyText . $(mkShowb name) |] --- | --- Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given @data@ type or @newtype@ -- to a strict 'TS.Text' with the given precedence. +-- +-- /Since: 0.3.1/ mkShowPrec :: Name -> Q Exp mkShowPrec name = [| \p -> toStrict . $(mkShowPrecLazy name) p |] --- | --- Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given @data@ type or @newtype@ -- to a lazy 'TL.Text' with the given precedence. +-- +-- /Since: 0.3.1/ mkShowPrecLazy :: Name -> Q Exp mkShowPrecLazy name = [| \p -> toLazyText . $(mkShowbPrec name) p |] --- | --- Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given list of @data@ types or +-- @newtype@s to a strict 'TS.Text' in which the values are surrounded by square +-- brackets and each value is separated by a comma. +-- +-- /Since: 0.5/ +mkShowList :: Name -> Q Exp +mkShowList name = [| toStrict . $(mkShowListLazy name) |] + +-- | Generates a lambda expression which converts the given list of @data@ types or +-- @newtype@s to a lazy 'TL.Text' in which the values are surrounded by square +-- brackets and each value is separated by a comma. +-- +-- /Since: 0.5/ +mkShowListLazy :: Name -> Q Exp +mkShowListLazy name = [| toLazyText . $(mkShowbList name) |] + +-- | Generates a lambda expression which converts the given @data@ type or @newtype@ -- to a 'Builder'. +-- +-- /Since: 0.3.1/ mkShowb :: Name -> Q Exp mkShowb name = mkShowbPrec name `appE` [| 0 :: Int |] --- | --- Generates a lambda expression which converts the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given @data@ type or @newtype@ -- to a 'Builder' with the given precedence. +-- +-- /Since: 0.3.1/ mkShowbPrec :: Name -> Q Exp -mkShowbPrec name = withType name $ \tvbs cons -> fromCons tvbs cons - where - fromCons :: [TyVarBndr] -> [Con] -> Q Exp - fromCons tvbs cons = sigE (consToShow cons) - $ forallT tvbs - cxt' - [t| Int -> $(type') -> Builder |] - where - cxt' :: Q Cxt - type' :: Q Type - (cxt', type') = instanceCtxType name tvbs +mkShowbPrec name = withType name $ const consToShow --- | --- Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which converts the given list of @data@ types or +-- @newtype@s to a 'Builder' in which the values are surrounded by square brackets +-- and each value is separated by a comma. +-- +-- /Since: 0.5/ +mkShowbList :: Name -> Q Exp +mkShowbList name = [| showbListDefault $(mkShowb name) |] + +-- | Generates a lambda expression which writes the given @data@ type or @newtype@ -- argument's strict 'TS.Text' output to the standard output, followed by a newline. +-- +-- /Since: 0.3.1/ mkPrint :: Name -> Q Exp mkPrint name = [| TS.putStrLn . $(mkShow name) |] --- | --- Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given @data@ type or @newtype@ -- argument's lazy 'TL.Text' output to the standard output, followed by a newline. +-- +-- /Since: 0.3.1/ mkPrintLazy :: Name -> Q Exp mkPrintLazy name = [| TL.putStrLn . $(mkShowLazy name) |] --- | --- Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given @data@ type or @newtype@ -- argument's strict 'TS.Text' output to the given file handle, followed by a newline. +-- +-- /Since: 0.3.1/ mkHPrint :: Name -> Q Exp mkHPrint name = [| \h -> TS.hPutStrLn h . $(mkShow name) |] --- | --- Generates a lambda expression which writes the given @data@ type or @newtype@ +-- | Generates a lambda expression which writes the given @data@ type or @newtype@ -- argument's lazy 'TL.Text' output to the given file handle, followed by a newline. +-- +-- /Since: 0.3.1/ mkHPrintLazy :: Name -> Q Exp mkHPrintLazy name = [| \h -> TL.hPutStrLn h . $(mkShowLazy name) |] --- | Generates code to generate the 'Show' encoding of a number of constructors. --- All constructors must be from the same type. +-- | Options that specify what @INLINE@ or @SPECIALIZE@ pragmas to generate with +-- a 'T.Show' instance. +-- +-- /Since: 0.5/ +data PragmaOptions = PragmaOptions { + inlineShowbPrec :: Bool -- ^ Whether to inline 'showbPrec' + , inlineShowb :: Bool -- ^ Whether to inline 'showb' + , inlineShowbList :: Bool -- ^ Whether to inline 'showbList' + , specializeTypes :: [Q Type] -- ^ Types for which to create specialized instance declarations +} + +-- | Do not generate any pragmas with a 'T.Show' instance. +-- +-- /Since: 0.5/ +defaultPragmaOptions :: PragmaOptions +defaultPragmaOptions = PragmaOptions False False False [] + +-- | Inline the 'showbPrec' function in a 'T.Show' instance. +-- +-- /Since: 0.5/ +defaultInlineShowbPrec :: PragmaOptions +defaultInlineShowbPrec = defaultPragmaOptions { inlineShowbPrec = True } + +-- | Inline the 'showb' function in a 'T.Show' instance. +-- +-- /Since: 0.5/ +defaultInlineShowb :: PragmaOptions +defaultInlineShowb = defaultPragmaOptions { inlineShowb = True } + +-- | Inline the 'showbList' function in a 'T.Show' instance. +-- +-- /Since: 0.5/ +defaultInlineShowbList :: PragmaOptions +defaultInlineShowbList = defaultPragmaOptions { inlineShowbList = True } + +-- | Generates code to generate the 'T.Show' encoding of a number of constructors. +-- All constructors must be from the same type. consToShow :: [Con] -> Q Exp consToShow [] = error $ "Text.Show.Text.TH.consToShow: Not a single constructor given!" consToShow cons = do p <- newName "p" value <- newName "value" - lam1E (if all isNullary cons then wildP else varP p) + lam1E (varP p) . lam1E (varP value) - $ caseE (varE value) [encodeArgs p con | con <- cons] + . caseE (varE value) + $ map (encodeArgs p) cons --- | Generates code to generate the 'Show' encoding of a single constructor. +-- | Generates code to generate the 'T.Show' encoding of a single constructor. encodeArgs :: Name -> Con -> Q Match -encodeArgs _ (NormalC conName []) +encodeArgs p (NormalC conName []) = match (conP conName []) - (normalB [| fromString $(stringE (nameBase conName)) |]) + (normalB [| intConst (fromString $(stringE (nameBase conName))) $(varE p) |]) [] -encodeArgs p (NormalC conName ts) = do - args <- mapM newName ["arg" ++ P.show n | (_, n) <- zip ts [1 :: Int ..]] +encodeArgs p (NormalC conName [_]) = do + arg <- newName "arg" - let showArgs = map (appE [| showbPrec appPrec1 |] . varE) args - mappendArgs = foldr1 (\v q -> [| $(v) <> s ' ' <> $(q) |]) showArgs - namedArgs = [| fromString $(stringE (nameBase conName)) <> s ' ' <> $(mappendArgs) |] + let showArg = [| showbPrec appPrec1 $(varE arg) |] + namedArg = [| fromString $(stringE (nameBase conName)) <> showbSpace <> $(showArg) |] - match (conP conName $ map varP args) - (normalB $ appE [| showbParen ($(varE p) > appPrec) |] namedArgs) + match (conP conName [varP arg]) + (normalB [| showbParen ($(varE p) > appPrec) $(namedArg) |]) [] +encodeArgs p (NormalC conName ts) = do + args <- mapM newName ["arg" ++ S.show n | (_, n) <- zip ts [1 :: Int ..]] + + if isNonUnitTuple conName + then do + let showArgs = map (appE [| showb |] . varE) args + parenCommaArgs = [| s '(' |] : intersperse [| s ',' |] showArgs + mappendArgs = foldr (flip infixApp [| (<>) |]) + [| s ')' |] + parenCommaArgs + + match (conP conName $ map varP args) + (normalB [| intConst $(mappendArgs) $(varE p) |]) + [] + else do + let showArgs = map (appE [| showbPrec appPrec1 |] . varE) args + mappendArgs = foldr1 (\v q -> [| $(v) <> showbSpace <> $(q) |]) showArgs + namedArgs = [| fromString $(stringE (nameBase conName)) <> showbSpace <> $(mappendArgs) |] + + match (conP conName $ map varP args) + (normalB [| showbParen ($(varE p) > appPrec) $(namedArgs) |]) + [] encodeArgs p (RecC conName []) = encodeArgs p $ NormalC conName [] encodeArgs p (RecC conName ts) = do - args <- mapM newName ["arg" ++ P.show n | (_, n) <- zip ts [1 :: Int ..]] + args <- mapM newName ["arg" ++ S.show n | (_, n) <- zip ts [1 :: Int ..]] - let showArgs = map (\(arg, (argName, _, _)) -> [| fromString $(stringE (nameBase argName)) <> fromString " = " <> showb $(varE arg) |]) - $ zip args ts - mappendArgs = foldr1 (\v q -> [| $(v) <> fromString ", " <> $(q) |]) showArgs - namedArgs = [| fromString $(stringE (nameBase conName)) <> s ' ' <> showbBraces $(mappendArgs) |] + let showArgs = concatMap (\(arg, (argName, _, _)) + -> [ [| fromString $(stringE (nameBase argName)) |] + , [| fromString " = " |] + , [| showb $(varE arg) |] + , [| fromString ", " |] + ] + ) + (zip args ts) + braceCommaArgs = [| s '{' |] : take (length showArgs - 1) showArgs + mappendArgs = foldr (flip infixApp [| (<>) |]) + [| s '}' |] + braceCommaArgs + namedArgs = [| fromString $(stringE (nameBase conName)) <> showbSpace <> $(mappendArgs) |] match (conP conName $ map varP args) - (normalB $ appE [| showbParen ($(varE p) > appPrec) |] namedArgs) + (normalB [| showbParen ($(varE p) > appPrec) $(namedArgs) |]) [] encodeArgs p (InfixC _ conName _) = do al <- newName "argL" @@ -250,14 +446,14 @@ let conPrec = case info of DataConI _ _ _ (Fixity prec _) -> prec - other -> error $ "Text.Show.Text.TH.encodeArgs: Unsupported type: " ++ P.show other + other -> error $ "Text.Show.Text.TH.encodeArgs: Unsupported type: " ++ S.show other match (infixP (varP al) conName (varP ar)) (normalB $ appE [| showbParen ($(varE p) > conPrec) |] [| showbPrec (conPrec + 1) $(varE al) - <> s ' ' + <> showbSpace <> fromString $(stringE (nameBase conName)) - <> s ' ' + <> showbSpace <> showbPrec (conPrec + 1) $(varE ar) |] ) @@ -268,27 +464,26 @@ -- Utility functions ------------------------------------------------------------------------------- -instanceCtxType :: Name -> [TyVarBndr] -> (Q Cxt, Q Type) -instanceCtxType name tvbs - = let typeNames :: [Name] - typeNames = map tvbName tvbs - - instanceType :: Q Type - instanceType = foldl' appT (conT name) $ map varT typeNames - in (applyCon ''Show typeNames name, instanceType) - --- | If constructor is nullary. -isNullary :: Con -> Bool -isNullary (NormalC _ []) = True -isNullary (RecC _ []) = True -isNullary _ = False +-- TODO: There's got to be a better way of doing this. +-- | Checks if a 'Name' represents a tuple type constructor (other than '()')/ +isNonUnitTuple :: Name -> Bool +isNonUnitTuple = isPrefixOf "(," . nameBase --- | Surrounds a 'Builder' with braces. -showbBraces :: Builder -> Builder -showbBraces b = s '{' <> b <> s '}' +-- | A type-restricted version of 'const'. This is useful when generating the lambda +-- expression in 'mkShowbPrec' for a data type with only nullary constructors (since +-- the expression wouldn't depend on the precedence). For example, if you had @data +-- Nullary = Nullary@ and attempted to run @$(mkShowbPrec ''Nullary) Nullary@, simply +-- ignoring the precedence argument would cause the type signature of @$(mkShowbPrec +-- ''Nullary)@ to be @a -> Nullary -> Builder@, not @Int -> Nullary -> Builder@. +-- +-- To avoid this problem, after computing the 'Builder' @b@, we call @intConst b p@, +-- where @p@ is the precedence argument. This forces @p :: Int@. +intConst :: a -> Int -> a +intConst = const +{-# INLINE intConst #-} -- | Boilerplate for top level splices. --- +-- -- The given 'Name' must be from a type constructor. Furthermore, the -- type constructor must be either a data type or a newtype. Any other -- value will result in an exception. @@ -306,20 +501,26 @@ case dec of DataD _ _ tvbs cons _ -> f tvbs cons NewtypeD _ _ tvbs con _ -> f tvbs [con] - other -> error $ "Text.Show.Text.TH.withType: Unsupported type: " - ++ P.show other - _ -> error "Text.Show.Text.TH.withType: I need the name of a type." + other -> error $ "Text.Show.Text.TH.withType: Unsupported type " + ++ S.show other ++ ". Must be a data type or newtype." + ClassI{} -> error "Text.Show.Text.TH.withType: Cannot use a typeclass name." +#if MIN_VERSION_template_haskell(2,7,0) + FamilyI (FamilyD DataFam _ _ _) _ -> + error "Text.Show.Text.TH.withType: Data families are not supported as of now." + FamilyI (FamilyD TypeFam _ _ _) _ -> + error "Text.Show.Text.TH.withType: Cannot use a type family name." +#endif + _ -> error "Text.Show.Text.TH.withType: I need the name of a plain type constructor." -- | Extracts the name from a type variable binder. tvbName :: TyVarBndr -> Name tvbName (PlainTV name) = name tvbName (KindedTV name _) = name --- | --- Applies a typeclass to several type parameters to produce the type predicate of an --- instance declaration. If a recent version of Template Haskell is used, this function --- will filter type parameters that have phantom roles (since they have no effect on --- the instance declaration. +-- | Applies a typeclass to several type parameters to produce the type predicate of +-- an instance declaration. If a recent version of Template Haskell is used, this +-- function will filter type parameters that have phantom roles (since they have no +-- effect on the instance declaration. applyCon :: Name -> [Name] -> Name -> Q [Pred] #if MIN_VERSION_template_haskell(2,9,0) applyCon con typeNames targetData @@ -330,7 +531,12 @@ #endif where apply :: Name -> Pred - apply t = ClassP con [VarT t] + apply t = +#if MIN_VERSION_template_haskell(2,10,0) + AppT (ConT con) (VarT t) +#else + ClassP con [VarT t] +#endif #if MIN_VERSION_template_haskell(2,9,0) -- Filters a list of tycon names based on their type roles. diff --git a/src/Text/Show/Text/Text.hs b/src/Text/Show/Text/Text.hs --- a/src/Text/Show/Text/Text.hs +++ b/src/Text/Show/Text/Text.hs @@ -1,14 +1,13 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Text --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Imports 'Show' instances for @Text@ modules. ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Text +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Text@ modules. +-} module Text.Show.Text.Text () where import Text.Show.Text.Text.Read () diff --git a/src/Text/Show/Text/Text/Read.hs b/src/Text/Show/Text/Text/Read.hs --- a/src/Text/Show/Text/Text/Read.hs +++ b/src/Text/Show/Text/Text/Read.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Text.Read --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Monomorphic 'Show' function for 'Lexeme' (and 'Number', if using a --- recent-enough version of @base@). ----------------------------------------------------------------------------- +{-| +Module: Text.Show.Text.Text.Read +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Lexeme' (and 'Number', if using a +recent-enough version of @base@). + +/Since: 0.3/ +-} module Text.Show.Text.Text.Read ( showbLexemePrec #if MIN_VERSION_base(4,7,0) @@ -19,50 +20,56 @@ #endif ) where -import Data.Text.Lazy.Builder (Builder, fromString) - -import GHC.Show (appPrec, appPrec1) +import Data.Text.Lazy.Builder (Builder) -import qualified Prelude as P -import Prelude hiding (Show) +import Prelude hiding (Show) -import Text.Read.Lex (Lexeme(..)) +import Text.Read.Lex (Lexeme(..)) #if MIN_VERSION_base(4,7,0) -import Text.Read.Lex (Number) +import Text.Read.Lex (Number) #endif -import Text.Show.Text.Class (Show(showbPrec), showbParen) -import Text.Show.Text.Data.Char (showbLitChar) -#if !(MIN_VERSION_base(4,6,0)) -import Text.Show.Text.Data.Integral (showbIntegerPrec, showbRatioPrec) +import Text.Show.Text.Classes (Show(showbPrec), showbUnary) +#if MIN_VERSION_base(4,6,0) +import Text.Show.Text.Classes (FromStringShow(..)) +#else +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.Ratio () #endif -import Text.Show.Text.Utils ((<>)) +import Text.Show.Text.Data.Char (LitChar(..), LitString(..)) +#include "inline.h" + -- | Convert a 'Lexeme' to a 'Builder' with the given precedence. +-- +-- /Since: 0.3/ showbLexemePrec :: Int -> Lexeme -> Builder -showbLexemePrec p (Char c) = showbParen (p > appPrec) $ "Char " <> showbLitChar c -showbLexemePrec p (String s) = showbParen (p > appPrec) $ "String " <> fromString s -showbLexemePrec p (Punc pun) = showbParen (p > appPrec) $ "Punc " <> fromString pun -showbLexemePrec p (Ident i) = showbParen (p > appPrec) $ "Ident " <> fromString i -showbLexemePrec p (Symbol s) = showbParen (p > appPrec) $ "Symbol " <> fromString s +showbLexemePrec p (Char c) = showbUnary "Char" p $ LitChar c +showbLexemePrec p (String s) = showbUnary "String" p $ LitString s +showbLexemePrec p (Punc pun) = showbUnary "Punc" p $ LitString pun +showbLexemePrec p (Ident i) = showbUnary "Ident" p $ LitString i +showbLexemePrec p (Symbol s) = showbUnary "Symbol" p $ LitString s #if MIN_VERSION_base(4,6,0) -showbLexemePrec p (Number n) = showbParen (p > appPrec) $ "Number " <> fromString (P.showsPrec appPrec1 n "") +showbLexemePrec p (Number n) = showbUnary "Number" p $ FromStringShow n #else -showbLexemePrec p (Int i) = showbParen (p > appPrec) $ "Int " <> showbIntegerPrec appPrec1 i -showbLexemePrec p (Rat r) = showbParen (p > appPrec) $ "Rat " <> showbRatioPrec appPrec1 r +showbLexemePrec p (Int i) = showbUnary "Int" p i +showbLexemePrec p (Rat r) = showbUnary "Rat" p r #endif showbLexemePrec _ EOF = "EOF" {-# INLINE showbLexemePrec #-} #if MIN_VERSION_base(4,7,0) -- | Convert a 'Number' to a 'Builder' with the given precedence. +-- This function is only available with @base-4.7.0.0@ or later. +-- +-- /Since: 0.3/ showbNumberPrec :: Int -> Number -> Builder -showbNumberPrec p n = fromString $ P.showsPrec p n "" +showbNumberPrec p = showbPrec p . FromStringShow {-# INLINE showbNumberPrec #-} #endif instance Show Lexeme where showbPrec = showbLexemePrec - {-# INLINE showbPrec #-} + INLINE_INST_FUN(showbPrec) #if MIN_VERSION_base(4,7,0) instance Show Number where diff --git a/src/Text/Show/Text/Utils.hs b/src/Text/Show/Text/Utils.hs --- a/src/Text/Show/Text/Utils.hs +++ b/src/Text/Show/Text/Utils.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE MagicHash, NoImplicitPrelude #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Show.Text.Utils --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Miscellaneous 'Builder' utility functions. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP, MagicHash #-} +{-| +Module: Text.Show.Text.Utils +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Miscellaneous utility functions. +-} module Text.Show.Text.Utils where import Data.Int (Int64) +#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(mappend, mempty)) +#endif import Data.Text (Text) import Data.Text.Lazy (length, replicate, toStrict, unpack) import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText) @@ -23,54 +24,64 @@ import Prelude hiding (length, replicate) -infixr 6 <> - -- | Unsafe conversion for decimal digits. i2d :: Int -> Char i2d (I# i#) = C# (chr# (ord# '0'# +# i#)) {-# INLINE i2d #-} +infixr 6 <> -- | Infix 'mappend', defined here for backwards-compatibility with older versions --- of base. +-- of @base@. (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} --- | --- A shorter name for 'singleton' for convenience's sake (since it tends to be used +-- | A shorter name for 'singleton' for convenience's sake (since it tends to be used -- pretty often in @text-show@). s :: Char -> Builder s = singleton {-# INLINE s #-} -- | Computes the length of a 'Builder'. +-- +-- /Since: 0.3/ lengthB :: Builder -> Int64 lengthB = length . toLazyText {-# INLINE lengthB #-} -- | @'replicateB' n b@ yields a 'Builder' containing @b@ repeated @n@ times. +-- +-- /Since: 0.3/ replicateB :: Int64 -> Builder -> Builder replicateB n = fromLazyText . replicate n . toLazyText {-# INLINE replicateB #-} -- | Convert a 'Builder' to a 'String' (without surrounding it with double quotes, --- as 'show' would). +-- as 'show' would). +-- +-- /Since: 0.4.1/ toString :: Builder -> String toString = unpack . toLazyText {-# INLINE toString #-} -- | Convert a 'Builder' to a strict 'Text'. +-- +-- /Since: 0.4.1/ toText :: Builder -> Text toText = toStrict . toLazyText {-# INLINE toText #-} -- | Merges several 'Builder's, separating them by newlines. +-- +-- /Since: 0.1/ unlinesB :: [Builder] -> Builder unlinesB (b:bs) = b <> s '\n' <> unlinesB bs unlinesB [] = mempty {-# INLINE unlinesB #-} -- | Merges several 'Builder's, separating them by spaces. +-- +-- /Since: 0.1/ unwordsB :: [Builder] -> Builder unwordsB (b:bs@(_:_)) = b <> s ' ' <> unwordsB bs unwordsB [b] = b diff --git a/tests/Derived.hs b/tests/Derived.hs new file mode 100644 --- /dev/null +++ b/tests/Derived.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP, ExistentialQuantification, FlexibleContexts, + GADTs, GeneralizedNewtypeDeriving, StandaloneDeriving, + TypeOperators, UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 706 +-- GHC 7.4 also supports PolyKinds, but Template Haskell doesn't seem to play +-- nicely with it for some reason. +{-# LANGUAGE PolyKinds #-} +#endif +{-| +Module: Derived +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Defines data types with derived 'Show' instances (using "Text.Show.Text.TH") +for testing purposes, including 'Arbitrary' instances. +-} +module Derived ( + Nullary(..) + , PhantomNullary(..) + , MonomorphicUnary(..) + , PolymorphicUnary(..) + , MonomorphicNewtype(..) + , PolymorphicNewtype(..) + , MonomorphicProduct(..) + , PolymorphicProduct(..) + , MonomorphicRecord(..) + , PolymorphicRecord(..) + , MonomorphicInfix(..) + , PolymorphicInfix(..) + , MonomorphicForall(..) + , PolymorphicForall(..) + , AllAtOnce(..) + , GADT(..) + , LeftAssocTree(..) + , RightAssocTree(..) + , (:?:)(..) + , HigherKindedTypeParams(..) + , Restriction(..) + , RestrictedContext(..) + , Fix(..) + ) where + +import Prelude hiding (Show) + +import Test.Tasty.QuickCheck (Arbitrary) + +import qualified Text.Show as S (Show) +import qualified Text.Show.Text as T (Show) + +data Nullary = Nullary deriving S.Show + +data PhantomNullary a = PhantomNullary deriving S.Show + +data MonomorphicUnary = MonomorphicUnary Int deriving S.Show + +data PolymorphicUnary a b = PolymorphicUnary a deriving S.Show + +newtype MonomorphicNewtype = MonomorphicNewtype Int deriving (Arbitrary, S.Show) + +newtype PolymorphicNewtype a b = PolymorphicNewtype a deriving (Arbitrary, S.Show) + +data MonomorphicProduct = MonomorphicProduct Char Double Int deriving S.Show + +data PolymorphicProduct a b c d = PolymorphicProduct a b c deriving S.Show + +data MonomorphicRecord = MonomorphicRecord { + monomorphicRecord1 :: Char + , monomorphicRecord2 :: Double + , monomorphicRecord3 :: Int +} deriving S.Show + +data PolymorphicRecord a b c d = PolymorphicRecord { + polymorphicRecord1 :: a + , polymorphicRecord2 :: b + , polymorphicRecord3 :: c +} deriving S.Show + +infix 7 :/: +data MonomorphicInfix = Int :/: Double deriving S.Show + +infix 8 :\: +data PolymorphicInfix a b c = a :\: b deriving S.Show + +data MonomorphicForall = forall a. (Arbitrary a, S.Show a, T.Show a) => MonomorphicForall a +deriving instance S.Show MonomorphicForall + +data PolymorphicForall a b = forall c. (Arbitrary c, S.Show c, T.Show c) => PolymorphicForall a c +deriving instance S.Show a => S.Show (PolymorphicForall a b) + +infix 3 :/\: +data AllAtOnce a b c d = AAONullary + | AAOUnary a + | AAOProduct a b c + | AAORecord { + aaoRecord1 :: a + , aaoRecord2 :: b + , aaoRecord3 :: c + } + | a :/\: b + | forall e. (Arbitrary e, S.Show e, T.Show e) => AAOForall a c e +deriving instance (S.Show a, S.Show b, S.Show c) => S.Show (AllAtOnce a b c d) + +data GADT a b c where + GADTCon1 :: GADT Char b c + GADTCon2 :: Double -> GADT Double Double c + GADTCon3 :: Int -> GADT Int String c + GADTCon4 :: a -> GADT a b c + GADTCon5 :: b -> GADT b b c +deriving instance (S.Show a, S.Show b) => S.Show (GADT a b c) + +infixl 5 :<: +data LeftAssocTree a = LeftAssocLeaf a + | LeftAssocTree a :<: LeftAssocTree a + deriving S.Show + +infixl 5 :>: +data RightAssocTree a = RightAssocLeaf a + | RightAssocTree a :>: RightAssocTree a + deriving S.Show + +infix 4 :?: +data a :?: b = a :?: b deriving S.Show + +data HigherKindedTypeParams f a = HigherKindedTypeParams (f a) deriving S.Show + +data Restriction a = Restriction a +deriving instance (Read a, S.Show a) => S.Show (Restriction a) + +data RestrictedContext a = RestrictedContext (Restriction a) deriving S.Show + +newtype Fix f = Fix (f (Fix f)) +deriving instance S.Show (f (Fix f)) => S.Show (Fix f) + +-- TODO: Test data family instances, once they're supported +-- +-- data family DataFamily a b c :: * +-- data instance DataFamily [a] [b] c = DataInstance1 a +-- | DataInstance2 [b] +-- deriving Show +-- newtype instance DataFamily Int Int c = NewtypeInstance Int deriving Show diff --git a/tests/Instances/BaseAndFriends.hs b/tests/Instances/BaseAndFriends.hs --- a/tests/Instances/BaseAndFriends.hs +++ b/tests/Instances/BaseAndFriends.hs @@ -4,25 +4,30 @@ #endif #if MIN_VERSION_base(4,7,0) {-# LANGUAGE TypeFamilies #-} +# if !(MIN_VERSION_base(4,8,0)) +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +# endif #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Instances.BaseAndFriends --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- Provides 'Arbitrary' instances for data types located in @base@ and other --- common libraries. This module also defines 'Show' instances for some data --- types as well (e.g., those which do not derive 'Show' in older versions --- of GHC). ----------------------------------------------------------------------------- +{-| +Module: Instances.BaseAndFriends +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types located in @base@ and other +common libraries. This module also defines 'Show' instances for some data +types as well (e.g., those which do not derive 'Show' in older versions +of GHC). +-} module Instances.BaseAndFriends () where -import Control.Applicative (ZipList(..), (<$>), (<*>), pure) +import Control.Applicative (ZipList(..)) +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif import Control.Exception import Control.Monad.ST (ST, fixST) @@ -34,8 +39,16 @@ import Data.Data (Constr, ConstrRep(..), DataRep(..), DataType, mkConstr, mkDataType) import Data.Dynamic (Dynamic, toDyn) +import Data.Functor ((<$>)) +import Data.Functor.Identity (Identity(..)) import Data.Monoid (All(..), Any(..), Dual(..), First(..), Last(..), Product(..), Sum(..)) +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt(..)) +#endif +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) +import qualified Data.OldTypeable.Internal as OldT (TyCon(..)) +#endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) #endif @@ -47,7 +60,7 @@ import Data.Type.Equality ((:~:)(..)) #endif #if MIN_VERSION_base(4,4,0) -import Data.Typeable.Internal (TyCon(..)) +import qualified Data.Typeable.Internal as NewT (TyCon(..)) import GHC.Fingerprint.Type (Fingerprint(..)) #if !(MIN_VERSION_base(4,7,0)) @@ -63,6 +76,9 @@ ptrToIntPtr, ptrToWordPtr) import GHC.Conc (BlockReason(..), ThreadStatus(..)) +#if defined(mingw32_HOST_OS) +import GHC.Conc.Windows (ConsoleEvent(..)) +#endif #if MIN_VERSION_base(4,4,0) import GHC.IO.Encoding.Failure (CodingFailureMode(..)) import GHC.IO.Encoding.Types (CodingProgress(..)) @@ -71,17 +87,32 @@ M1(..), (:+:)(..), (:*:)(..), (:.:)(..), Associativity(..), Arity(..)) #endif +#if MIN_VERSION_base(4,8,0) +import GHC.RTS.Flags +import GHC.StaticPtr (StaticPtrInfo(..)) +#endif #if MIN_VERSION_base(4,5,0) import GHC.Stats (GCStats(..)) #endif +#if MIN_VERSION_base(4,7,0) +import GHC.TypeLits (SomeNat, SomeSymbol, someNatVal, someSymbolVal) +#endif +import Numeric.Natural (Natural) + import System.Exit (ExitCode(..)) import System.IO (BufferMode(..), IOMode(..), Newline(..), NewlineMode(..), SeekMode(..)) import System.Posix.Types -import Test.QuickCheck +import Test.Tasty.QuickCheck (Arbitrary(arbitrary), Gen, + arbitraryBoundedEnum, oneof, suchThat) +#include "HsBaseConfig.h" + +instance Arbitrary Natural where + arbitrary = fromInteger <$> arbitrary `suchThat` (>= 0) + instance Arbitrary Builder where arbitrary = fromString <$> arbitrary @@ -105,37 +136,7 @@ -- TODO: instance Arbitrary (ForeignPtr a) instance Arbitrary GeneralCategory where - arbitrary = oneof $ map pure [ UppercaseLetter - , LowercaseLetter - , TitlecaseLetter - , ModifierLetter - , OtherLetter - , NonSpacingMark - , SpacingCombiningMark - , EnclosingMark - , DecimalNumber - , LetterNumber - , OtherNumber - , ConnectorPunctuation - , DashPunctuation - , OpenPunctuation - , ClosePunctuation - , InitialQuote - , FinalQuote - , OtherPunctuation - , MathSymbol - , CurrencySymbol - , ModifierSymbol - , OtherSymbol - , Space - , LineSeparator - , ParagraphSeparator - , Control - , Format - , Surrogate - , PrivateUse - , NotAssigned - ] + arbitrary = arbitraryBoundedEnum instance Arbitrary Version where arbitrary = Version <$> arbitrary <*> arbitrary @@ -190,6 +191,11 @@ instance Arbitrary BlockedIndefinitelyOnSTM where arbitrary = pure BlockedIndefinitelyOnSTM +#if MIN_VERSION_base(4,8,0) +instance Arbitrary AllocationLimitExceeded where + arbitrary = pure AllocationLimitExceeded +#endif + instance Arbitrary Deadlock where arbitrary = pure Deadlock @@ -229,12 +235,20 @@ instance Arbitrary (Proxy s) where arbitrary = pure Proxy +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) +-- TODO: Come up with an instance of TypeRep that doesn't take forever +-- instance Arbitrary OldT.TypeRep where + +instance Arbitrary OldT.TyCon where + arbitrary = OldT.TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +#endif + #if MIN_VERSION_base(4,4,0) -- TODO: Come up with an instance of TypeRep that doesn't take forever --- instance Arbitrary TypeRep where +-- instance Arbitrary NewT.TypeRep where -instance Arbitrary TyCon where - arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance Arbitrary NewT.TyCon where + arbitrary = NewT.TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Fingerprint where arbitrary = Fingerprint <$> arbitrary <*> arbitrary @@ -304,6 +318,16 @@ , pure ThreadDied ] +#if defined(mingw32_HOST_OS) +instance Arbitrary ConsoleEvent where + arbitrary = oneof $ map pure [ ControlC + , Break + , Close + , Logoff + , Shutdown + ] +#endif + instance Arbitrary (ST s a) where arbitrary = pure $ fixST undefined @@ -420,6 +444,51 @@ #endif #endif +#if MIN_VERSION_base(4,8,0) +-- instance Arbitrary RTSFlags +-- instance Arbitrary GCFlags + +instance Arbitrary ConcFlags where + arbitrary = ConcFlags <$> arbitrary <*> arbitrary + +instance Arbitrary MiscFlags where + arbitrary = MiscFlags <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary DebugFlags where + arbitrary = DebugFlags <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +-- instance Arbitrary CCFlags where +-- instance Arbitrary ProfFlags where +-- instance Arbitrary TraceFlags where + +instance Arbitrary TickyFlags where + arbitrary = TickyFlags <$> arbitrary <*> arbitrary + +instance Arbitrary StaticPtrInfo where + arbitrary = StaticPtrInfo <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +#endif + +-- #if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,7,0)) +-- instance Arbitrary (IsZero n) +-- instance Arbitrary (IsEven n) +-- #endif + +#if MIN_VERSION_base(4,7,0) +instance Arbitrary SomeNat where + arbitrary = do + nat <- arbitrary `suchThat` (>= 0) + case someNatVal nat of + Just sn -> pure sn + Nothing -> fail "Negative natural number" + +instance Arbitrary SomeSymbol where + arbitrary = someSymbolVal <$> arbitrary +#endif + deriving instance Arbitrary CChar deriving instance Arbitrary CSChar deriving instance Arbitrary CUChar @@ -449,19 +518,45 @@ instance Arbitrary ExitCode where arbitrary = oneof [pure ExitSuccess, ExitFailure <$> arbitrary] +#if defined(HTYPE_DEV_T) deriving instance Arbitrary CDev +#endif +#if defined(HTYPE_INO_T) deriving instance Arbitrary CIno +#endif +#if defined(HTYPE_MODE_T) deriving instance Arbitrary CMode +#endif +#if defined(HTYPE_OFF_T) deriving instance Arbitrary COff +#endif +#if defined(HTYPE_PID_T) deriving instance Arbitrary CPid +#endif +#if defined(HTYPE_SSIZE_T) deriving instance Arbitrary CSsize +#endif +#if defined(HTYPE_GID_T) deriving instance Arbitrary CGid +#endif +#if defined(HTYPE_NLINK_T) deriving instance Arbitrary CNlink +#endif +#if defined(HTYPE_UID_T) deriving instance Arbitrary CUid +#endif +#if defined(HTYPE_CC_T) deriving instance Arbitrary CCc +#endif +#if defined(HTYPE_SPEED_T) deriving instance Arbitrary CSpeed +#endif +#if defined(HTYPE_TCFLAG_T) deriving instance Arbitrary CTcflag +#endif +#if defined(HTYPE_RLIM_T) deriving instance Arbitrary CRLim +#endif deriving instance Arbitrary Fd deriving instance Arbitrary All @@ -471,7 +566,10 @@ deriving instance Arbitrary a => Arbitrary (Last a) deriving instance Arbitrary a => Arbitrary (Product a) deriving instance Arbitrary a => Arbitrary (Sum a) - +#if MIN_VERSION_base(4,8,0) +deriving instance Arbitrary (f a) => Arbitrary (Alt f a) +#endif + deriving instance Arbitrary a => Arbitrary (ZipList a) #if !(MIN_VERSION_base(4,7,0)) deriving instance Show a => Show (ZipList a) @@ -483,3 +581,5 @@ deriving instance Show a => Show (Down a) #endif #endif + +deriving instance Arbitrary a => Arbitrary (Identity a) diff --git a/tests/Instances/Derived.hs b/tests/Instances/Derived.hs --- a/tests/Instances/Derived.hs +++ b/tests/Instances/Derived.hs @@ -1,171 +1,132 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TemplateHaskell, TypeOperators #-} +{-# LANGUAGE CPP, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, + StandaloneDeriving, TemplateHaskell, + TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Instances.Derived --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- This module defines data types that have derived 'Show' instances (using --- "Text.Show.Text.TH") for testing purposes, including 'Arbitrary' --- instances. ----------------------------------------------------------------------------- -module Instances.Derived ( - Nullary(..) - , PhantomNullary(..) - , MonomorphicUnary(..) - , PolymorphicUnary(..) - , MonomorphicNewtype(..) - , PolymorphicNewtype(..) - , MonomorphicProduct(..) - , PolymorphicProduct(..) - , MonomorphicRecord(..) - , PolymorphicRecord(..) - , MonomorphicInfix(..) - , PolymorphicInfix(..) - , AllAtOnce(..) - , GADT(..) - , LeftAssocTree(..) - , RightAssocTree(..) - , (:?:)(..) - ) where +{-| +Module: Instances.Derived +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC -import Control.Applicative ((<$>), (<*>), pure) -import GHC.Show (appPrec, appPrec1) -import Test.QuickCheck -import Text.Show.Text.TH (deriveShow) +Defines data types with derived 'Show' instances (using "Text.Show.Text.TH") +for testing purposes, including 'Arbitrary' instances. +-} +module Instances.Derived () where -data Nullary = Nullary deriving Show +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif + +import Data.Functor ((<$>)) + +import Derived + +import Prelude hiding (Show) + +import Test.Tasty.QuickCheck (Arbitrary(arbitrary), Gen, oneof) + +import Text.Show.Text (Show(showbPrec)) +import Text.Show.Text.TH (deriveShow, mkShowbPrec) + $(deriveShow ''Nullary) instance Arbitrary Nullary where arbitrary = pure Nullary -data PhantomNullary a = PhantomNullary deriving Show $(deriveShow ''PhantomNullary) instance Arbitrary (PhantomNullary a) where arbitrary = pure PhantomNullary -data MonomorphicUnary = MonomorphicUnary Int deriving Show $(deriveShow ''MonomorphicUnary) instance Arbitrary MonomorphicUnary where arbitrary = MonomorphicUnary <$> arbitrary -data PolymorphicUnary a b = PolymorphicUnary a deriving Show $(deriveShow ''PolymorphicUnary) instance Arbitrary a => Arbitrary (PolymorphicUnary a b) where arbitrary = PolymorphicUnary <$> arbitrary -newtype MonomorphicNewtype = MonomorphicNewtype Int deriving (Arbitrary, Show) $(deriveShow ''MonomorphicNewtype) -newtype PolymorphicNewtype a b = PolymorphicNewtype a deriving (Arbitrary, Show) $(deriveShow ''PolymorphicNewtype) -data MonomorphicProduct = MonomorphicProduct Char Double Int deriving Show $(deriveShow ''MonomorphicProduct) instance Arbitrary MonomorphicProduct where arbitrary = MonomorphicProduct <$> arbitrary <*> arbitrary <*> arbitrary -data PolymorphicProduct a b c d = PolymorphicProduct a b c deriving Show $(deriveShow ''PolymorphicProduct) instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (PolymorphicProduct a b c d) where arbitrary = PolymorphicProduct <$> arbitrary <*> arbitrary <*> arbitrary -data MonomorphicRecord = MonomorphicRecord { - monomorphicRecord1 :: Char - , monomorphicRecord2 :: Double - , monomorphicRecord3 :: Int -} deriving Show $(deriveShow ''MonomorphicRecord) instance Arbitrary MonomorphicRecord where arbitrary = MonomorphicRecord <$> arbitrary <*> arbitrary <*> arbitrary -data PolymorphicRecord a b c d = PolymorphicRecord { - polymorphicRecord1 :: a - , polymorphicRecord2 :: b - , polymorphicRecord3 :: c -} deriving Show $(deriveShow ''PolymorphicRecord) instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (PolymorphicRecord a b c d) where arbitrary = PolymorphicRecord <$> arbitrary <*> arbitrary <*> arbitrary -infix 7 :/: -data MonomorphicInfix = Int :/: Double deriving Show $(deriveShow ''MonomorphicInfix) instance Arbitrary MonomorphicInfix where arbitrary = (:/:) <$> arbitrary <*> arbitrary -infix 8 :\: -data PolymorphicInfix a b c = a :\: b deriving Show $(deriveShow ''PolymorphicInfix) instance (Arbitrary a, Arbitrary b) => Arbitrary (PolymorphicInfix a b c) where arbitrary = (:\:) <$> arbitrary <*> arbitrary -infix 3 :/\: -data AllAtOnce a b c d = AAONullary - | AAOUnary a - | AAOProduct a b c - | AAORecord { - aaoRecord1 :: a - , aaoRecord2 :: b - , aaoRecord3 :: c - } - | a :/\: b - deriving Show +$(deriveShow ''MonomorphicForall) +instance Arbitrary MonomorphicForall where + arbitrary = MonomorphicForall <$> (arbitrary :: Gen Int) + +$(deriveShow ''PolymorphicForall) +instance Arbitrary a => Arbitrary (PolymorphicForall a b) where + arbitrary = PolymorphicForall <$> arbitrary <*> (arbitrary :: Gen Int) + $(deriveShow ''AllAtOnce) instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (AllAtOnce a b c d) where arbitrary = oneof [ pure AAONullary - , AAOUnary <$> arbitrary + , AAOUnary <$> arbitrary , AAOProduct <$> arbitrary <*> arbitrary <*> arbitrary - , AAORecord <$> arbitrary <*> arbitrary <*> arbitrary - , (:/\:) <$> arbitrary <*> arbitrary + , AAORecord <$> arbitrary <*> arbitrary <*> arbitrary + , (:/\:) <$> arbitrary <*> arbitrary + , AAOForall <$> arbitrary <*> arbitrary <*> (arbitrary :: Gen Int) ] -data GADT a b where - GADTCon1 :: GADT Char b - GADTCon2 :: Double -> GADT Double Double - GADTCon3 :: Int -> GADT Int String -instance Show a => Show (GADT a b) where - showsPrec _ GADTCon1 = showString "GADTCon1" - showsPrec p (GADTCon2 d) - = showParen (p > appPrec) $ showString "GADTCon2 " . showsPrec appPrec1 d - showsPrec p (GADTCon3 i) - = showParen (p > appPrec) $ showString "GADTCon3 " . showsPrec appPrec1 i $(deriveShow ''GADT) -infixl 5 :<: -data LeftAssocTree a = LeftAssocLeaf a - | LeftAssocTree a :<: LeftAssocTree a - deriving Show $(deriveShow ''LeftAssocTree) instance Arbitrary a => Arbitrary (LeftAssocTree a) where arbitrary = oneof [ LeftAssocLeaf <$> arbitrary , (:<:) <$> arbitrary <*> arbitrary ] -infixl 5 :>: -data RightAssocTree a = RightAssocLeaf a - | RightAssocTree a :>: RightAssocTree a - deriving Show $(deriveShow ''RightAssocTree) instance Arbitrary a => Arbitrary (RightAssocTree a) where arbitrary = oneof [ RightAssocLeaf <$> arbitrary , (:>:) <$> arbitrary <*> arbitrary ] -infix 4 :?: -data a :?: b = a :?: b deriving Show $(deriveShow ''(:?:)) instance (Arbitrary a, Arbitrary b) => Arbitrary (a :?: b) where arbitrary = (:?:) <$> arbitrary <*> arbitrary +instance Show (f a) => Show (HigherKindedTypeParams f a) where + showbPrec = $(mkShowbPrec ''HigherKindedTypeParams) +instance Arbitrary (f a) => Arbitrary (HigherKindedTypeParams f a) where + arbitrary = HigherKindedTypeParams <$> arbitrary + +instance (Read a, Show a) => Show (Restriction a) where + showbPrec = $(mkShowbPrec ''Restriction) +instance Arbitrary a => Arbitrary (Restriction a) where + arbitrary = Restriction <$> arbitrary + +instance (Read a, Show a) => Show (RestrictedContext a) where + showbPrec = $(mkShowbPrec ''RestrictedContext) +instance Arbitrary a => Arbitrary (RestrictedContext a) where + arbitrary = RestrictedContext <$> arbitrary + +instance Show (f (Fix f)) => Show (Fix f) where + showbPrec = $(mkShowbPrec ''Fix) +deriving instance Arbitrary (f (Fix f)) => Arbitrary (Fix f) + -- TODO: Test data family instances, once they're supported --- --- data family DataFamily a b c :: * --- data instance DataFamily [a] [b] c = DataInstance1 a --- | DataInstance2 [b] --- deriving Show --- newtype instance DataFamily Int Int c = NewtypeInstance Int deriving Show diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,14 +1,13 @@ ------------------------------------------------------------------------------ --- | --- Module : Properties --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- @QuickCheck@ tests for @text-show@. ----------------------------------------------------------------------------- +{-| +Module: Properties +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ tests for @text-show@. +-} module Main (main) where import Properties.BaseAndFriends (baseAndFriendsTests) diff --git a/tests/Properties/BaseAndFriends.hs b/tests/Properties/BaseAndFriends.hs --- a/tests/Properties/BaseAndFriends.hs +++ b/tests/Properties/BaseAndFriends.hs @@ -1,26 +1,31 @@ -{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,4,0) {-# LANGUAGE FlexibleContexts, TypeOperators #-} #endif ------------------------------------------------------------------------------ --- | --- Module : Properties.BaseAndFriends --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- @QuickCheck@ properties for data types located in @base@ and other --- common libraries. ----------------------------------------------------------------------------- +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +#endif +{-| +Module: Properties.BaseAndFriends +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types located in @base@ and other +common libraries. +-} module Properties.BaseAndFriends (baseAndFriendsTests) where import Control.Applicative (ZipList(..), liftA2) import Control.Exception import Control.Monad.ST +#if !defined(mingw32_HOST_OS) import Data.Array (Array) +#endif +import Data.Array (elems) import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) #if MIN_VERSION_bytestring(0,10,4) @@ -32,41 +37,44 @@ import Data.Data (Constr, ConstrRep, DataRep, DataType) import Data.Dynamic (Dynamic) import Data.Fixed (Fixed, E0, E1, E2, E3, E6, E9, E12, showFixed) +import Data.Functor.Identity (Identity) import Data.Int (Int8, Int16, Int32, Int64) -import Data.IntMap (IntMap) -import Data.IntSet (IntSet) -import Data.Map (Map) import Data.Monoid (All(..), Any(..), Dual(..), First(..), Last(..), Product(..), Sum(..)) +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt(..)) +#endif +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) +import qualified Data.OldTypeable as OldT (TyCon) +#endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) #endif import Data.Proxy (Proxy) import Data.Ratio (Ratio) -import Data.Sequence (Seq) -import Data.Set (Set) import qualified Data.Text as TS import qualified Data.Text as TL -import Data.Time.Calendar (Day) -import Data.Time.Clock (DiffTime, UTCTime, NominalDiffTime) -import Data.Time.Clock.TAI (AbsoluteTime) -import Data.Time.LocalTime (TimeZone, TimeOfDay, LocalTime, ZonedTime) -import Data.Tree (Tree) #if MIN_VERSION_base(4,7,0) import Data.Type.Coercion (Coercion) import Data.Type.Equality ((:~:)) #endif #if MIN_VERSION_base(4,4,0) -import Data.Typeable.Internal (TyCon) +import qualified Data.Typeable as NewT (TyCon) import GHC.Fingerprint.Type (Fingerprint) #endif -import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Word (Word8, Word16, Word32, Word64) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Word (Word) +#endif import Data.Version (Version, showVersion) import Foreign.C.Types import Foreign.Ptr (FunPtr, IntPtr, Ptr, WordPtr) import GHC.Conc (BlockReason, ThreadStatus) +#if defined(mingw32_HOST_OS) +import GHC.Conc.Windows (ConsoleEvent) +#endif import qualified GHC.Generics as G (Fixity) import GHC.Generics (U1, Par1, Rec1, K1, M1, (:+:), (:*:), (:.:), Associativity, Arity) @@ -74,10 +82,17 @@ import GHC.IO.Encoding.Failure (CodingFailureMode) import GHC.IO.Encoding.Types (CodingProgress) #endif +#if MIN_VERSION_base(4,8,0) +import GHC.RTS.Flags +import GHC.StaticPtr (StaticPtrInfo) +#endif #if MIN_VERSION_base(4,5,0) import GHC.Stats (GCStats) #endif -import GHC.Show (showList__) +import GHC.Show (asciiTab, showList__) +#if MIN_VERSION_base(4,7,0) +import GHC.TypeLits (SomeNat, SomeSymbol) +#endif import Instances.BaseAndFriends () @@ -85,6 +100,7 @@ #if MIN_VERSION_base(4,7,0) import Numeric (showFFloatAlt, showGFloatAlt) #endif +import Numeric.Natural (Natural) import Prelude hiding (Show) @@ -94,14 +110,15 @@ import System.IO (BufferMode, IOMode, Newline, NewlineMode, SeekMode) import System.Posix.Types -import Test.QuickCheck hiding (Fixed) import Test.QuickCheck.Instances () import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.HUnit ((@=?), testCase) +import Test.Tasty.QuickCheck (Gen, arbitrary, suchThat, testProperty) import Text.Show.Functions () import Text.Show.Text hiding (Show) import Text.Show.Text.Functions () +import Text.Show.Text.Data.Char (asciiTabB) import Text.Show.Text.Data.Fixed (showbFixed) import Text.Show.Text.Data.Floating (showbEFloat, showbFFloat, showbGFloat) #if MIN_VERSION_base(4,7,0) @@ -111,25 +128,31 @@ import Text.Show.Text.Data.List (showbListDefault) import Text.Show.Text.Data.Version (showbVersionConcrete) +#include "HsBaseConfig.h" + -- | Verifies 'showFixed' and 'showbFixed' generate the same output. prop_showFixed :: Bool -> Fixed E12 -> Bool prop_showFixed b f = fromString (showFixed b f) == showbFixed b f -- | Verifies 'showIntAtBase' and 'showbIntAtBase' generate the same output. +#if !defined(mingw32_HOST_OS) prop_showIntAtBase :: Gen Bool prop_showIntAtBase = do base <- arbitrary `suchThat` (liftA2 (&&) (> 1) (<= 16)) i <- arbitrary `suchThat` (>= 0) :: Gen Int return $ fromString (showIntAtBase base intToDigit i "") == showbIntAtBase base intToDigit i +#endif -- | Verifies 'showList__' and 'showbListDefault' generate the same output. prop_showListDefault :: [Char] -> Bool prop_showListDefault str = fromString (showList__ shows str "") == showbListDefault showb str -- | Verifies @showXFloat@ and @showbXFloat@ generate the same output (where @X@ --- is one of E, F, or G). -prop_showXFloat :: (Maybe Int -> Double -> ShowS) -> (Maybe Int -> Double -> Builder) -> Maybe Int -> Double -> Bool -prop_showXFloat f1 f2 digs val = fromString (f1 digs val "") == f2 digs val +-- is one of E, F, or G). +prop_showXFloat :: (Maybe Int -> Double -> ShowS) -> (Maybe Int -> Double -> Builder) -> Double -> Gen Bool +prop_showXFloat f1 f2 val = do + digs <- arbitrary `suchThat` (<= 10) + return $ fromString (f1 (Just digs) val "") == f2 (Just digs) val -- | Verifies 'showVersion' and 'showbVersion' generate the same output. prop_showVersion :: Version -> Bool @@ -159,6 +182,9 @@ , testProperty "NestedAtomically instance" (prop_matchesShow :: Int -> NestedAtomically -> Bool) , testProperty "BlockedIndefinitelyOnMVar instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnMVar -> Bool) , testProperty "BlockedIndefinitelyOnSTM instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnSTM -> Bool) +#if MIN_VERSION_base(4,8,0) + , testProperty "AllocationLimitExceeded instance" (prop_matchesShow :: Int -> AllocationLimitExceeded -> Bool) +#endif , testProperty "Deadlock instance" (prop_matchesShow :: Int -> Deadlock -> Bool) , testProperty "NoMethodError instance" (prop_matchesShow :: Int -> NoMethodError -> Bool) , testProperty "PatternMatchFail instance" (prop_matchesShow :: Int -> PatternMatchFail -> Bool) @@ -171,9 +197,12 @@ , testGroup "Text.Show.Text.Control.Monad.ST" [ testProperty "ST instance" (prop_matchesShow :: Int -> ST Int Int -> Bool) ] +#if !defined(mingw32_HOST_OS) +-- TODO: Figure out why this test diverges on Windows , testGroup "Text.Show.Text.Data.Array" [ testProperty "Array Int Int instance" (prop_matchesShow :: Int -> Array Int Int -> Bool) ] +#endif , testGroup "Text.Show.Text.Data.Bool" [ testProperty "Bool instance" (prop_matchesShow :: Int -> Bool -> Bool) ] @@ -187,14 +216,10 @@ , testGroup "Text.Show.Text.Data.Char" [ testProperty "Char instance" (prop_matchesShow :: Int -> Char -> Bool) , testProperty "GeneralCategory instance" (prop_matchesShow :: Int -> GeneralCategory -> Bool) + , testCase "asciiTab = asciiTabB" $ map fromString asciiTab @=? elems (asciiTabB) ] - , testGroup "Text.Show.Text.Data.Containers" - [ testProperty "IntMap Char instance" (prop_matchesShow :: Int -> IntMap Char -> Bool) - , testProperty "IntSet instance" (prop_matchesShow :: Int -> IntSet -> Bool) - , testProperty "Map Char Char instance" (prop_matchesShow :: Int -> Map Char Char -> Bool) - , testProperty "Sequence Char" (prop_matchesShow :: Int -> Seq Char -> Bool) - , testProperty "Set Char instance" (prop_matchesShow :: Int -> Set Char -> Bool) - , testProperty "Tree Char instance" (prop_matchesShow :: Int -> Tree Char -> Bool) + , testGroup "Text.Show.Text.Data.Complex" + [ testProperty "Complex Double instance" (prop_matchesShow :: Int -> Complex Double -> Bool) ] , testGroup "Text.Show.Text.Data.Data" [ testProperty "Constr instance" (prop_matchesShow :: Int -> Constr -> Bool) @@ -222,7 +247,6 @@ , testGroup "Text.Show.Text.Data.Floating" [ testProperty "Float instance" (prop_matchesShow :: Int -> Float -> Bool) , testProperty "Double instance" (prop_matchesShow :: Int -> Double -> Bool) - , testProperty "Complex Double instance" (prop_matchesShow :: Int -> Complex Double -> Bool) , testProperty "showbEFloat output" $ prop_showXFloat showEFloat showbEFloat , testProperty "showbFFloat output" $ prop_showXFloat showFFloat showbFFloat , testProperty "showbGFloat output" $ prop_showXFloat showGFloat showbGFloat @@ -234,6 +258,9 @@ , testGroup "Text.Show.Text.Data.Functions" [ testProperty "Int -> Int instance" (prop_matchesShow :: Int -> (Int -> Int) -> Bool) ] + , testGroup "Text.Show.Text.Data.Functor.Identity" + [ testProperty "Identity Int instance" (prop_matchesShow :: Int -> Identity Int -> Bool) + ] , testGroup "Text.Show.Text.Data.Integral" [ testProperty "Int instance" (prop_matchesShow :: Int -> Int -> Bool) , testProperty "Int8 instance" (prop_matchesShow :: Int -> Int8 -> Bool) @@ -246,8 +273,10 @@ , testProperty "Word16 instance" (prop_matchesShow :: Int -> Word16 -> Bool) , testProperty "Word32 instance" (prop_matchesShow :: Int -> Word32 -> Bool) , testProperty "Word64 instance" (prop_matchesShow :: Int -> Word64 -> Bool) - , testProperty "Ratio Int instance" (prop_matchesShow :: Int -> Ratio Int -> Bool) +#if !defined(mingw32_HOST_OS) +-- TODO: Figure out why this diverges on Windows , testProperty "showbIntAtBase output" prop_showIntAtBase +#endif ] , testGroup "Text.Show.Text.Data.List" [ testProperty "String instance" (prop_matchesShow :: Int -> String -> Bool) @@ -266,29 +295,33 @@ , testProperty "Last (Maybe Int) instance" (prop_matchesShow :: Int -> Last (Maybe Int) -> Bool) , testProperty "Product Int instance" (prop_matchesShow :: Int -> Product Int -> Bool) , testProperty "Sum Int instance" (prop_matchesShow :: Int -> Sum Int -> Bool) +#if MIN_VERSION_base(4,8,0) + , testProperty "Alt Maybe Int instance" (prop_matchesShow :: Int -> Alt Maybe Int -> Bool) +#endif ] +#if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,8,0)) + , testGroup "Text.Show.Text.Data.OldTypeable" + [ -- testProperty "TypeRep instance" (prop_matchesShow :: Int -> OldT.TypeRep -> Bool) + testProperty "TyCon instance" (prop_matchesShow :: Int -> OldT.TyCon -> Bool) + ] +#endif , testGroup "Text.Show.Text.Data.Ord" [ testProperty "Ordering instance" (prop_matchesShow :: Int -> Ordering -> Bool) #if MIN_VERSION_base(4,6,0) , testProperty "Down Int instance" (prop_matchesShow :: Int -> Down Int -> Bool) #endif ] + , testGroup "Text.Show.Text.Data.Proxy" + [ testProperty "Proxy Int instance" (prop_matchesShow :: Int -> Proxy Int -> Bool) + ] + , testGroup "Text.Show.Text.Data.Ratio" + [ testProperty "Ratio Int instance" (prop_matchesShow :: Int -> Ratio Int -> Bool) + ] , testGroup "Text.Show.Text.Data.Text" [ testProperty "Builder instance" (prop_matchesShow :: Int -> Builder -> Bool) , testProperty "strict Text instance" (prop_matchesShow :: Int -> TS.Text -> Bool) , testProperty "lazy Text instance" (prop_matchesShow :: Int -> TL.Text -> Bool) ] - , testGroup "Text.Show.Text.Data.Time" - [ testProperty "Day instance" (prop_matchesShow :: Int -> Day -> Bool) - , testProperty "DiffTime instance" (prop_matchesShow :: Int -> DiffTime -> Bool) - , testProperty "UTCTime instance" (prop_matchesShow :: Int -> UTCTime -> Bool) - , testProperty "NominalDiffTime instance" (prop_matchesShow :: Int -> NominalDiffTime -> Bool) - , testProperty "AbsoluteTime instance" (prop_matchesShow :: Int -> AbsoluteTime -> Bool) - , testProperty "TimeZone instance" (prop_matchesShow :: Int -> TimeZone -> Bool) - , testProperty "TimeOfDay instance" (prop_matchesShow :: Int -> TimeOfDay -> Bool) - , testProperty "LocalTime instance" (prop_matchesShow :: Int -> LocalTime -> Bool) - , testProperty "ZonedTime instance" (prop_matchesShow :: Int -> ZonedTime -> Bool) - ] , testGroup "Text.Show.Text.Data.Tuple" [ testProperty "() instance" (prop_matchesShow :: Int -> () -> Bool) , testProperty "(Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int) -> Bool) @@ -306,12 +339,10 @@ #endif #if MIN_VERSION_base(4,4,0) , testGroup "Text.Show.Text.Data.Typeable" - [ -- testProperty "TypeRep instance" (prop_matchesShow :: Int -> TypeRep -> Bool) - testProperty "TyCon instance" (prop_matchesShow :: Int -> TyCon -> Bool) - , testProperty "Fingerprint instance" (prop_matchesShow :: Int -> Fingerprint -> Bool) -#endif - , testProperty "Proxy Int instance" (prop_matchesShow :: Int -> Proxy Int -> Bool) + [ -- testProperty "TypeRep instance" (prop_matchesShow :: Int -> NewT.TypeRep -> Bool) + testProperty "TyCon instance" (prop_matchesShow :: Int -> NewT.TyCon -> Bool) ] +#endif , testGroup "Text.Show.Text.Data.Version" [ testProperty "Version instance" (prop_matchesShow :: Int -> Version -> Bool) , testProperty "showbVersionConcrete output" prop_showVersion @@ -340,8 +371,10 @@ , testProperty "CUIntMax instance" (prop_matchesShow :: Int -> CUIntMax -> Bool) , testProperty "CClock instance" (prop_matchesShow :: Int -> CClock -> Bool) , testProperty "CTime instance" (prop_matchesShow :: Int -> CTime -> Bool) +#if MIN_VERSION_base(4,4,0) , testProperty "CUSeconds instance" (prop_matchesShow :: Int -> CUSeconds -> Bool) , testProperty "CSUSeconds instance" (prop_matchesShow :: Int -> CSUSeconds -> Bool) +#endif , testProperty "CFloat instance" (prop_matchesShow :: Int -> CFloat -> Bool) , testProperty "CDouble instance" (prop_matchesShow :: Int -> CUChar -> Bool) ] @@ -352,12 +385,22 @@ , testProperty "WordPtr instance" (prop_matchesShow :: Int -> WordPtr -> Bool) -- , testProperty "ForeignPtr instance" (prop_matchesShow :: Int -> ForeignPtr Int -> Bool) ] --- #if MIN_VERSION_base(4,4,0) +-- #if MIN_VERSION_base(4,4,0) && !defined(mingw32_HOST_OS) -- , testGroup "Text.Show.Text.GHC.Event" -- [ testProperty "Event instance" (prop_matchesShow :: Int -> Event -> Bool) -- , testProperty "FdKey instance" (prop_matchesShow :: Int -> FdKey -> Bool) -- ] -- #endif +#if defined(mingw32_HOST_OS) + , testGroup "Text.Show.Text.GHC.Conc.Windows" + [ testProperty "ConsoleEvent instance" (prop_matchesShow :: Int -> ConsoleEvent -> Bool) + ] +#endif +#if MIN_VERSION_base(4,4,0) + , testGroup "Text.Show.Text.GHC.Fingerprint" + [ testProperty "Fingerprint instance" (prop_matchesShow :: Int -> Fingerprint -> Bool) + ] +#endif , testGroup "Text.Show.Text.GHC.Generics" [ testProperty "U1 Int instance" (prop_matchesShow :: Int -> U1 Int -> Bool) , testProperty "Par1 Int instance" (prop_matchesShow :: Int -> Par1 Int -> Bool) @@ -371,9 +414,42 @@ , testProperty "Associativity instance" (prop_matchesShow :: Int -> Associativity -> Bool) , testProperty "Arity instance" (prop_matchesShow :: Int -> Arity -> Bool) ] +#if MIN_VERSION_base(4,8,0) + , testGroup "Text.Show.Text.GHC.RTS.Flags" + [ -- testProperty "RTSFlags instance" (prop_matchesShow :: Int -> RTSFlags -> Bool) +-- , testProperty "GCFlags instance" (prop_matchesShow :: Int -> GCFlags -> Bool) + testProperty "ConcFlags instance" (prop_matchesShow :: Int -> ConcFlags -> Bool) + , testProperty "MiscFlags instance" (prop_matchesShow :: Int -> MiscFlags -> Bool) + , testProperty "DebugFlags instance" (prop_matchesShow :: Int -> DebugFlags -> Bool) +-- , testProperty "CCFlags instance" (prop_matchesShow :: Int -> CCFlags -> Bool) +-- , testProperty "ProfFlags instance" (prop_matchesShow :: Int -> ProfFlags -> Bool) +-- , testProperty "TraceFlags instance" (prop_matchesShow :: Int -> TraceFlags -> Bool) + , testProperty "TickyFlags instance" (prop_matchesShow :: Int -> TickyFlags -> Bool) + ] + , testGroup "Text.Show.Text.GHC.StaticPtr" + [ testProperty "StaticPtrInfo instance" (prop_matchesShow :: Int -> StaticPtrInfo -> Bool) + ] +#endif +#if MIN_VERSION_base(4,5,0) , testGroup "Text.Show.Text.GHC.Stats" [ testProperty "GCStats instance" (prop_matchesShow :: Int -> GCStats -> Bool) ] +#endif +#if MIN_VERSION_base(4,6,0) + , testGroup "Text.Show.Text.GHC.TypeLits" + [ +# if MIN_VERSION_base(4,7,0) + testProperty "SomeNat instance" (prop_matchesShow :: Int -> SomeNat -> Bool) + , testProperty "SomeSymbol instance" (prop_matchesShow :: Int -> SomeSymbol -> Bool) +-- # else +-- testProperty "IsEven instance" (prop_matchesShow :: Int -> IsEven -> Bool) +-- , testProperty "IsZero instance" (prop_matchesShow :: Int -> IsZero -> Bool) +# endif + ] +#endif + , testGroup "Text.Show.Text.Numeric.Natural" + [ testProperty "Natural instance" (prop_matchesShow :: Int -> Natural -> Bool) + ] , testGroup "Text.Show.Text.System.Exit" [ testProperty "ExitCode instance" (prop_matchesShow :: Int -> ExitCode -> Bool) ] @@ -394,19 +470,46 @@ , testProperty "NewlineMode instance" (prop_matchesShow :: Int -> NewlineMode -> Bool) ] , testGroup "Text.Show.Text.System.Posix.Types" - [ testProperty "CDev instance" (prop_matchesShow :: Int -> CDev -> Bool) + [ +#if defined(HTYPE_DEV_T) + testProperty "CDev instance" (prop_matchesShow :: Int -> CDev -> Bool) +#endif +#if defined(HTYPE_INO_T) , testProperty "CIno instance" (prop_matchesShow :: Int -> CIno -> Bool) +#endif +#if defined(HTYPE_MODE_T) , testProperty "CMode instance" (prop_matchesShow :: Int -> CMode -> Bool) +#endif +#if defined(HTYPE_OFF_T) , testProperty "COff instance" (prop_matchesShow :: Int -> COff -> Bool) +#endif +#if defined(HTYPE_PID_T) , testProperty "CPid instance" (prop_matchesShow :: Int -> CPid -> Bool) +#endif +#if defined(HTYPE_SSIZE_T) , testProperty "CSsize instance" (prop_matchesShow :: Int -> CSsize -> Bool) +#endif +#if defined(HTYPE_GID_T) , testProperty "CGid instance" (prop_matchesShow :: Int -> CGid -> Bool) +#endif +#if defined(HTYPE_NLINK_T) , testProperty "CNlink instance" (prop_matchesShow :: Int -> CNlink -> Bool) +#endif +#if defined(HTYPE_UID_T) , testProperty "CUid instance" (prop_matchesShow :: Int -> CUid -> Bool) +#endif +#if defined(HTYPE_CC_T) , testProperty "CCc instance" (prop_matchesShow :: Int -> CCc -> Bool) +#endif +#if defined(HTYPE_SPEED_T) , testProperty "CSpeed instance" (prop_matchesShow :: Int -> CSpeed -> Bool) +#endif +#if defined(HTYPE_TCFLAG_T) , testProperty "CTcflag instance" (prop_matchesShow :: Int -> CTcflag -> Bool) +#endif +#if defined(HTYPE_RLIM_T) , testProperty "CRLim instance" (prop_matchesShow :: Int -> CRLim -> Bool) +#endif , testProperty "Fd instance" (prop_matchesShow :: Int -> Fd -> Bool) ] -- , testGroup "Text.Show.Text.Text.Read.Lex" diff --git a/tests/Properties/Builder.hs b/tests/Properties/Builder.hs --- a/tests/Properties/Builder.hs +++ b/tests/Properties/Builder.hs @@ -1,14 +1,14 @@ ------------------------------------------------------------------------------ --- | --- Module : Properties --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- @QuickCheck@ properties for functions that manipulate 'Builder's. ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-| +Module: Properties.Builder +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for functions that manipulate 'Builder's. +-} module Properties.Builder (builderTests) where import Instances.BaseAndFriends () @@ -16,16 +16,21 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Text.Show.Text (Builder, fromString, fromText, lengthB, replicateB, - singleton, toString, toText, unlinesB, unwordsB) +import Text.Show.Text (Builder, fromString, fromText, lengthB, + toString, toText, unlinesB, unwordsB) +#if !defined(mingw32_HOST_OS) +import Text.Show.Text (replicateB, singleton) +#endif -- | Verifies 'lengthB' and 'length' produce the same output. prop_lengthB :: String -> Bool prop_lengthB s = fromIntegral (lengthB $ fromString s) == length s +#if !defined(mingw32_HOST_OS) -- | Verifies 'replicateB' and 'replicate' produce the same output. prop_replicateB :: Int -> Char -> Bool prop_replicateB i c = replicateB (fromIntegral i) (singleton c) == fromString (replicate i c) +#endif -- | Verifies @fromText . toText = id@. prop_toText :: Builder -> Bool @@ -47,7 +52,10 @@ builderTests = [ testGroup "Builder-related functions" [ testProperty "lengthB output" prop_lengthB +#if !defined(mingw32_HOST_OS) +-- TODO: Figure out why this diverges on Windows , testProperty "replicateB output" prop_replicateB +#endif , testProperty "fromString . toString = id" prop_toString , testProperty "fromText . toText = id" prop_toText , testProperty "unlinesB output" prop_unlinesB diff --git a/tests/Properties/Derived.hs b/tests/Properties/Derived.hs --- a/tests/Properties/Derived.hs +++ b/tests/Properties/Derived.hs @@ -1,46 +1,55 @@ {-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Properties.BaseAndFriends --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- @QuickCheck@ properties for data types that have derived 'Show' instances --- (using "Text.Show.Text.TH"). ----------------------------------------------------------------------------- +{-| +Module: Properties.BaseAndFriends +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types that have derived 'Show' instances +(using "Text.Show.Text.TH"). +-} module Properties.Derived (derivedTests) where -import Data.Text.Lazy.Builder (fromString) +import Derived -import Instances.Derived +import Instances.Derived () import Properties.Utils (prop_matchesShow) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Text.Show.Text (showb, showbPrec) +import Text.Show.Text (showb, showbPrec, FromStringShow(..)) -- | Verifies that the two 'Show' instances of 'GADT' coincide. -prop_showGADT :: Int -- The precedence to show with - -> Double -- The argument to 'GADTCon2' - -> Int -- The argument to 'GADTCon3' +prop_showGADT :: Int -- ^ The precedence to show with + -> Double -- ^ The argument to 'GADTCon2' + -> Int -- ^ The argument to 'GADTCon3' + -> Char -- ^ The argument to 'GADTCon4' + -> String -- ^ The argument to 'GADTCon5' -> Bool -prop_showGADT p d i - = let gc1 :: GADT Char Int +prop_showGADT p d i c s + = let gc1 :: GADT Char Int Int gc1 = GADTCon1 - gc2 :: GADT Double Double + gc2 :: GADT Double Double Int gc2 = GADTCon2 d - gc3 :: GADT Int String + gc3 :: GADT Int String Int gc3 = GADTCon3 i - in fromString (show gc1) == showb gc1 - && fromString (showsPrec p gc2 "") == showbPrec p gc2 - && fromString (showsPrec p gc3 "") == showbPrec p gc3 + + gc4 :: GADT Char String Int + gc4 = GADTCon4 c + + gc5 :: GADT String String Int + gc5 = GADTCon5 s + in showb (FromStringShow gc1) == showb gc1 + && showbPrec p (FromStringShow gc2) == showbPrec p gc2 + && showbPrec p (FromStringShow gc3) == showbPrec p gc3 + && showbPrec p (FromStringShow gc4) == showbPrec p gc4 + && showbPrec p (FromStringShow gc5) == showbPrec p gc5 derivedTests :: [TestTree] derivedTests = @@ -57,11 +66,16 @@ , testProperty "PolymorphicRecord Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicRecord Int Int Int Int -> Bool) , testProperty "MonomorphicInfix instance" (prop_matchesShow :: Int -> MonomorphicInfix -> Bool) , testProperty "PolymorphicInfix Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicInfix Int Int Int -> Bool) + , testProperty "MonomorphicForall instance" (prop_matchesShow :: Int -> MonomorphicForall -> Bool) + , testProperty "PolymorphicForall Int Int instance" (prop_matchesShow :: Int -> PolymorphicForall Int Int -> Bool) , testProperty "AllAtOnce Int Int Int Int instance" (prop_matchesShow :: Int -> AllAtOnce Int Int Int Int -> Bool) , testProperty "GADT instance" prop_showGADT -- TODO: These tests take forever. Look at quickcheck-instances (specifically, at the Tree instance) to see how to fix this. -- , testProperty "LeftAssocTree Int instance" (prop_matchesShow :: Int -> LeftAssocTree Int -> Bool) -- , testProperty "RightAssocTree Int instance" (prop_matchesShow :: Int -> RightAssocTree Int -> Bool) , testProperty "Int :?: Int instance" (prop_matchesShow :: Int -> Int :?: Int -> Bool) + , testProperty "HigherKindedTypeParams Maybe Int instance" (prop_matchesShow :: Int -> HigherKindedTypeParams Maybe Int -> Bool) + , testProperty "RestrictedContext Int instance" (prop_matchesShow :: Int -> RestrictedContext Int -> Bool) + , testProperty "Fix Maybe instance" (prop_matchesShow :: Int -> Fix Maybe -> Bool) ] ] diff --git a/tests/Properties/MkShow.hs b/tests/Properties/MkShow.hs --- a/tests/Properties/MkShow.hs +++ b/tests/Properties/MkShow.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Properties.BaseAndFriends --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- @QuickCheck@ properties for 'mkShow' and related functions in --- "Text.Show.Text.TH". ----------------------------------------------------------------------------- +{-# LANGUAGE CPP, TemplateHaskell #-} +#if __GLASGOW_HASKELL__ < 706 +-- Template Haskell's name generation didn't name-mangle very well prior to GHC +-- 7.6 and can cause name shadowing warnings, so suppress them. +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#endif +{-| +Module: Properties.MkShow +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'mkShow' and related functions in "Text.Show.Text.TH". +-} module Properties.MkShow (mkShowTests) where import qualified Data.Text as TS (pack) import qualified Data.Text.Lazy as TL (pack) import Data.Text.Lazy.Builder (fromString) -import Instances.Derived +import Derived -import Test.QuickCheck.Modifiers (Large) +import Instances.Derived () + +import Test.Tasty.QuickCheck (NonZero) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -38,14 +43,14 @@ -- | Verifies 'mkShow' (and related functions) produce the same output as their -- 'String' counterparts. This uses a data type that is not a 'Show' instance. -prop_mkShowIsNotInstance :: Int -> Large Int -> Bool +prop_mkShowIsNotInstance :: Int -> NonZero Int -> Bool prop_mkShowIsNotInstance p a = - TS.pack (show a ) == $(mkShow ''Large) a - && TL.pack (show a ) == $(mkShowLazy ''Large) a - && TS.pack (showsPrec p a "") == $(mkShowPrec ''Large) p a - && TL.pack (showsPrec p a "") == $(mkShowPrecLazy ''Large) p a - && fromString (show a ) == $(mkShowb ''Large) a - && fromString (showsPrec p a "") == $(mkShowbPrec ''Large) p a + TS.pack (show a ) == $(mkShow ''NonZero) a + && TL.pack (show a ) == $(mkShowLazy ''NonZero) a + && TS.pack (showsPrec p a "") == $(mkShowPrec ''NonZero) p a + && TL.pack (showsPrec p a "") == $(mkShowPrecLazy ''NonZero) p a + && fromString (show a ) == $(mkShowb ''NonZero) a + && fromString (showsPrec p a "") == $(mkShowbPrec ''NonZero) p a -- prop_mkPrintIsInstance -- prop_mkPrintIsNotInstance @@ -53,9 +58,9 @@ mkShowTests :: [TestTree] mkShowTests = [ testGroup "mkShow and related functions" - [ testProperty "$(mkShow ''AllAtOnce) (a Show instance)" prop_mkShowIsInstance - , testProperty "$(mkShow ''Large) (not a Show instance)" prop_mkShowIsNotInstance --- , testProperty "$(mkPrint ''AllAtOnce) (a Show instance)" prop_mkPrintIsInstance --- , testProperty "$(mkPrint ''Large) (not a Show instance)" prop_mkPrintIsNotInstance + [ testProperty "$(mkShow ''AllAtOnce) (a Show instance)" prop_mkShowIsInstance + , testProperty "$(mkShow ''NonZero) (not a Show instance)" prop_mkShowIsNotInstance +-- , testProperty "$(mkPrint ''AllAtOnce) (a Show instance)" prop_mkPrintIsInstance +-- , testProperty "$(mkPrint ''NonZero) (not a Show instance)" prop_mkPrintIsNotInstance ] ] diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs --- a/tests/Properties/Utils.hs +++ b/tests/Properties/Utils.hs @@ -1,28 +1,24 @@ -{-# LANGUAGE NoImplicitPrelude #-} ------------------------------------------------------------------------------ --- | --- Module : Properties.Utils --- Copyright : (C) 2014 Ryan Scott --- License : BSD-style (see the file LICENSE) --- Maintainer : Ryan Scott --- Stability : Experimental --- Portability : GHC --- --- @QuickCheck@ property-related utility functions. ----------------------------------------------------------------------------- -module Properties.Utils (prop_matchesShow) where +{-| +Module: Properties.Utils +Copyright: (C) 2014-2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC -import Data.Text.Lazy.Builder (fromString) +@QuickCheck@ property-related utility functions. +-} +module Properties.Utils (prop_matchesShow) where -import qualified Prelude as P (Show) import Prelude hiding (Show) -import Test.QuickCheck (Arbitrary) +import Test.Tasty.QuickCheck (Arbitrary) +import qualified Text.Show as S (Show) import qualified Text.Show.Text as T (Show) -import Text.Show.Text (showbPrec) +import Text.Show.Text (showbPrec, FromStringShow(..)) -- | Verifies that a type's @Show@ instances coincide for both 'String's and 'Text', --- irrespective of precedence. -prop_matchesShow :: (P.Show a, T.Show a, Arbitrary a) => Int -> a -> Bool -prop_matchesShow k x = fromString (showsPrec k x "") == showbPrec k x +-- irrespective of precedence. +prop_matchesShow :: (S.Show a, T.Show a, Arbitrary a) => Int -> a -> Bool +prop_matchesShow p x = showbPrec p (FromStringShow x) == showbPrec p x diff --git a/text-show.cabal b/text-show.cabal --- a/text-show.cabal +++ b/text-show.cabal @@ -1,5 +1,5 @@ name: text-show -version: 0.4.1 +version: 0.5 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 @@ -9,10 +9,8 @@ At the moment, @text-show@ provides @Show@ instances for most data types in the @@, @@, - @@, - @@, - @@, and - @@ packages. + @@, and + @@ packages. Therefore, much of the source code for @text-show@ consists of borrowed code from those packages in order to ensure that the behaviors of the two @Show@ typeclasses coincide. @@ -48,26 +46,33 @@ author: Ryan Scott maintainer: Ryan Scott stability: Experimental --- copyright: +copyright: (C) 2014-2015 Ryan Scott category: Text build-type: Simple -extra-source-files: CHANGELOG.md, README.md +extra-source-files: CHANGELOG.md, README.md, include/inline.h cabal-version: >=1.8 source-repository head type: git location: git://github.com/RyanGlScott/text-show.git -flag text-format - description: Do not use text-format, since it may require double-conversion - and thus linking of libstdc++, which may break compilation - due to GHC bug #5289: - . - http://ghc.haskell.org/trac/ghc/ticket/5289 - default: False +flag integer-gmp2 + description: Use @integer-gmp2@. + default: True +flag recent-text + description: Use a recent version of @text@ that fixes a bug related to + converting large @Integer@s to a @Builder@. + default: True + +flag transformers-four + description: Use a recent version of @transformers@. + default: True + library exposed-modules: Text.Show.Text + Text.Show.Text.Debug.Trace + Text.Show.Text.Debug.Trace.TH Text.Show.Text.TH Text.Show.Text.Control.Applicative @@ -78,100 +83,143 @@ Text.Show.Text.Data.Bool Text.Show.Text.Data.ByteString Text.Show.Text.Data.Char - Text.Show.Text.Data.Containers + Text.Show.Text.Data.Complex Text.Show.Text.Data.Data Text.Show.Text.Data.Dynamic Text.Show.Text.Data.Either Text.Show.Text.Data.Fixed Text.Show.Text.Data.Floating + Text.Show.Text.Data.Functor.Identity Text.Show.Text.Data.Integral Text.Show.Text.Data.List Text.Show.Text.Data.Maybe Text.Show.Text.Data.Monoid Text.Show.Text.Data.Ord + Text.Show.Text.Data.Proxy + Text.Show.Text.Data.Ratio Text.Show.Text.Data.Text - Text.Show.Text.Data.Time Text.Show.Text.Data.Tuple Text.Show.Text.Data.Typeable Text.Show.Text.Data.Version + Text.Show.Text.Data.Void Text.Show.Text.Foreign.C.Types Text.Show.Text.Foreign.Ptr Text.Show.Text.Functions + Text.Show.Text.Numeric.Natural Text.Show.Text.System.Exit Text.Show.Text.System.IO Text.Show.Text.System.Posix.Types Text.Show.Text.Text.Read - other-modules: Text.Show.Text.Class + other-modules: Text.Show.Text.Classes Text.Show.Text.Control Text.Show.Text.Data + Text.Show.Text.Data.Typeable.Utils Text.Show.Text.Foreign Text.Show.Text.GHC Text.Show.Text.Instances + Text.Show.Text.Numeric Text.Show.Text.System Text.Show.Text.Text Text.Show.Text.TH.Internal Text.Show.Text.Utils - build-depends: array >= 0.3 && < 0.6 - , base >= 4.2 && < 5 - , bytestring  >= 0.9 && < 0.11 - , containers >= 0.1 && < 0.6 + build-depends: array >= 0.3 && < 0.6 + , base >= 4.2 && < 5 + -- , containers >= 0.1 && < 0.6 + , bytestring  >= 0.9 && < 0.11 , ghc-prim - , template-haskell >= 2.4 && < 2.10 - , text >= 0.2 && < 1.3 - , time >= 0.1 && < 1.6 + , template-haskell >= 2.4 && < 2.11 hs-source-dirs: src ghc-options: -Wall + include-dirs: include + includes: inline.h + install-includes: inline.h - if flag(text-format) - cpp-options: -DTEXT_FORMAT - build-depends: text-format >= 0.2 && < 0.4 + if flag(recent-text) + cpp-options: -DRECENT_TEXT + build-depends: text >= 1.2.0.2 && < 1.3 else - build-depends: integer-gmp >= 0.2 - ghc-options: -fobject-code + build-depends: integer-gmp >= 0.2 + , text >= 0.2 && < 1.2.0.2 + ghc-options: -fobject-code if impl(ghc >= 7.2) - exposed-modules: Text.Show.Text.GHC.Event + exposed-modules: Text.Show.Text.GHC.Fingerprint Text.Show.Text.GHC.Generics + if !os(windows) + exposed-modules: Text.Show.Text.GHC.Event if impl(ghc >= 7.4) exposed-modules: Text.Show.Text.GHC.Stats - -- Data.Proxy is a part of base as of GHC 7.7 + if impl(ghc >= 7.6) + exposed-modules: Text.Show.Text.GHC.TypeLits + if impl(ghc < 7.7) - build-depends: tagged >= 0.4.4 && < 1 + build-depends: tagged >= 0.4.4 && < 1 if impl(ghc >= 7.8) exposed-modules: Text.Show.Text.Data.Type.Coercion Text.Show.Text.Data.Type.Equality + + if impl(ghc < 7.10) + exposed-modules: Text.Show.Text.Data.OldTypeable + if impl(ghc < 7.9) + build-depends: nats >= 0.1 && < 2 + , void >= 0.5 && < 1 + + if flag(transformers-four) + build-depends: transformers >= 0.4 && < 0.5 + else + build-depends: transformers >= 0.2.1 && < 0.4 + , transformers-compat >= 0.3 && < 1 + else + if flag(integer-gmp2) + build-depends: integer-gmp >= 1.0 && < 1.1 + + if impl(ghc >= 7.10) + exposed-modules: Text.Show.Text.GHC.RTS.Flags + Text.Show.Text.GHC.StaticPtr + + if os(windows) + exposed-modules: Text.Show.Text.GHC.Conc.Windows + test-suite text-show-properties type: exitcode-stdio-1.0 main-is: Properties.hs - other-modules: Instances.BaseAndFriends + other-modules: Derived + Instances.BaseAndFriends Instances.Derived Properties.BaseAndFriends Properties.Builder Properties.Derived Properties.MkShow Properties.Utils - hs-source-dirs: tests build-depends: array >= 0.3 && < 0.6 - , base >= 4.2 && < 5 + , base >= 4.5 && < 5 , bytestring  >= 0.9 && < 0.11 - , containers >= 0.1 && < 0.6 - , QuickCheck >= 2.4 && < 2.8 , quickcheck-instances >= 0.1 && < 0.4 , tasty >= 0.8 && < 0.11 + , tasty-hunit >= 0.8 && < 0.10 , tasty-quickcheck >= 0.8 && < 0.9 , text >= 0.2 && < 1.3 - , text-show >= 0.4 && < 0.5 - , time >= 0.1 && < 1.6 + , text-show == 0.5 + hs-source-dirs: tests ghc-options: -Wall -- Prior to GHC 7.6, GHC generics lived in ghc-prim if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim - -- Data.Proxy is a part of base as of GHC 7.7 if impl(ghc < 7.7) build-depends: tagged >= 0.4.4 && < 1 + + if impl(ghc < 7.9) + build-depends: nats >= 0.1 && < 2 + , void >= 0.5 && < 1 + + if flag(transformers-four) + build-depends: transformers >= 0.4 && < 0.5 + else + build-depends: transformers >= 0.2.1 && < 0.4 + , transformers-compat >= 0.3 && < 1