diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 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 +* `Text.Show.Text` now exports `Data.Text.Lazy.Builder` for convenience +* Add `showLazy`, `showPrec`, `showPrecLazy`, `printLazy`, `hPrint`, `hPrintLazy`, `lengthB`, and `replicateB` + # 0.2.0.0 * Add `Show` instances for strict and lazy `Text` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,3 @@ -# `text-show` [![Build Status](https://travis-ci.org/RyanGlScott/text-show.svg)](https://travis-ci.org/RyanGlScott/text-show) +# `text-show` [![Hackage version](https://img.shields.io/hackage/v/text-show.svg)](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). 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,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Show.Text @@ -14,486 +14,27 @@ -- * The 'Show' class Show (..) , show - -- * 'Builder' construction + , showLazy + , showPrec + , showPrecLazy , showbParen - , showbLitChar + -- * 'Builder's + , module Data.Text.Lazy.Builder + , lengthB + , replicateB , unlinesB , unwordsB -- * Printing values , print + , printLazy + , hPrint + , hPrintLazy ) where -import Data.Array (Array, (!), assocs, bounds, listArray) -import Data.Char (ord) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Ix (Ix) -import Data.Complex (Complex(..)) -import qualified Data.Map as M -import Data.Map (Map) -import Data.Monoid (Monoid(mempty), (<>)) -import Data.Ratio (Ratio, numerator, denominator) -import qualified Data.Set as S -import Data.Set (Set) -import Data.Text (Text) -import Data.Text.Buildable (build) -import Data.Text.IO (putStrLn) -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, singleton, toLazyText) -import Data.Text.Lazy.Builder.RealFloat (realFloat) -import Data.Word (Word, Word8, Word16, Word32, Word64) - -import Foreign.Ptr (Ptr, IntPtr, WordPtr) - -import Prelude hiding (Show(..), print, putStrLn) - --- | Conversion of values to 'Text'. -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 [] = "[]" - showbList (x:xs) = s '[' <> showb x <> go xs -- "[.. - where - go (y:ys) = s ',' <> showb y <> go ys -- ..,.. - go [] = s ']' -- ..]" - {-# MINIMAL showbPrec | showb #-} - --- | Constructs a 'Text' from a single value. -show :: Show a => a -> Text -show = toStrict . toLazyText . showb -{-# INLINE show #-} - --- | 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 #-} - --- | Prints a value's 'Text' representation to the standard output. -print :: Show a => a -> IO () -print = putStrLn . show -{-# INLINE print #-} - --- | Merges several 'Builder's, separating them by newlines. -unlinesB :: [Builder] -> Builder -unlinesB (b:bs) = b <> s '\n' <> unlinesB bs -unlinesB [] = mempty - --- | Merges several 'Builder's, separating them by spaces. -unwordsB :: [Builder] -> Builder -unwordsB (b:bs@(_:_)) = b <> s ' ' <> unwordsB bs -unwordsB [b] = b -unwordsB [] = mempty - --- | A table of ASCII control characters that needs to be escaped with a backslash. -asciiTabB :: Array Int Builder -asciiTabB = listArray (0, 32) ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", - "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", - "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", - "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", - "SP"] - --- | Constructs a 'Builder' with one character (without single quotes). -showbLitChar :: Char -> Builder -showbLitChar c | c > '\DEL' = s '\\' <> showb (ord c) -showbLitChar '\DEL' = "\\DEL" -showbLitChar '\\' = "\\\\" -showbLitChar c | c >= ' ' = s c -showbLitChar '\a' = "\\a" -showbLitChar '\b' = "\\b" -showbLitChar '\f' = "\\f" -showbLitChar '\n' = "\\n" -showbLitChar '\r' = "\\r" -showbLitChar '\t' = "\\t" -showbLitChar '\v' = "\\v" -showbLitChar '\SO' = "\\S0" -showbLitChar c = s '\\' <> (asciiTabB ! ord c) -{-# INLINE showbLitChar #-} - --- | --- 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 #-} - -instance Show Builder where - showb = id - -instance Show () where - showb () = "()" - -instance Show Char where - showb '\'' = "'\\''" - showb c = s '\'' <> showbLitChar c <> s '\'' - {-# INLINE showb #-} - - showbList = build - {-# INLINE showbList #-} - --- Strict variant -instance Show Text where - showb = build - {-# INLINE showb #-} - -instance Show LT.Text where - showb = build - {-# INLINE showb #-} - -instance Show Bool where - showb True = "True" - showb False = "False" - -instance Show a => Show [a] where - showb = showbList - {-# INLINE showb #-} - -instance Show Int where - showb = build - {-# INLINE showb #-} - - showbPrec k i = showbParen (i < 0 && k > 0) $ build i - {-# INLINE showbPrec #-} - -instance Show Int8 where - showb = build - {-# INLINE showb #-} - - showbPrec k i = showbParen (i < 0 && k > 0) $ build i - {-# INLINE showbPrec #-} - -instance Show Int16 where - showb = build - {-# INLINE showb #-} - - showbPrec k i = showbParen (i < 0 && k > 0) $ build i - {-# INLINE showbPrec #-} - -instance Show Int32 where - showb = build - {-# INLINE showb #-} - - showbPrec k i = showbParen (i < 0 && k > 0) $ build i - {-# INLINE showbPrec #-} - -instance Show Int64 where - showb = build - {-# INLINE showb #-} - - showbPrec k i = showbParen (i < 0 && k > 0) $ build i - {-# INLINE showbPrec #-} - -instance Show Integer where - showb = build - {-# INLINE showb #-} - - showbPrec k i = showbParen (i < 0 && k > 0) $ build i - {-# INLINE showbPrec #-} - -instance Show Word where - showb = build - {-# INLINE showb #-} - -instance Show Word8 where - showb = build - {-# INLINE showb #-} - -instance Show Word16 where - showb = build - {-# INLINE showb #-} - -instance Show Word32 where - showb = build - {-# INLINE showb #-} - -instance Show Word64 where - showb = build - {-# INLINE showb #-} - -instance Show Float where - showb = realFloat - {-# INLINE showb #-} - - showbPrec k f = showbParen (f < 0 && k > 0) $ realFloat f - {-# INLINE showbPrec #-} - -instance Show Double where - showb = realFloat - {-# INLINE showb #-} - - showbPrec k f = showbParen (f < 0 && k > 0) $ realFloat f - {-# INLINE showbPrec #-} - -instance (Show a, Integral a) => Show (Ratio a) where - {-# SPECIALIZE instance Show Rational #-} - showbPrec k q = showbParen (k > 7) $ showbPrec 8 (numerator q) <> - s '%' <> showb (denominator q) - -instance (Show a, RealFloat a) => Show (Complex a) where - {-# SPECIALIZE instance Show (Complex Float) #-} - {-# SPECIALIZE instance Show (Complex Double) #-} - showbPrec k (a :+ b) = showbParen (k > 6) $ showbPrec 7 a <> " :+ " <> showbPrec 7 b - -instance Show a => Show (Maybe a) where - showbPrec _ Nothing = "Nothing" - showbPrec k (Just a) = showbParen (k > 10) $ "Just " <> showbPrec 11 a - {-# INLINE showbPrec #-} - -instance (Show a, Show b) => Show (Either a b) where - showbPrec k (Left a) = showbParen (k > 10) $ "Left " <> showbPrec 11 a - showbPrec k (Right b) = showbParen (k > 10) $ "Right " <> showbPrec 11 b - -instance Show Ordering where - showb LT = "LT" - showb EQ = "EQ" - showb GT = "GT" - -instance (Show a, Show b) => Show (a, b) where - showb (a, b) = - s '(' <> showb a <> - s ',' <> showb b <> - s ')' - {-# INLINE showb #-} - -instance (Show a, Show b, Show c) => Show (a, b, c) where - showb (a, b, c) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ')' - {-# INLINE showb #-} - -instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where - showb (a, b, c, d) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ')' - {-# INLINE showb #-} - -instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where - showb (a, b, c, d, e) = - s '(' <> showb a <> - s ',' <> showb b <> - s ',' <> showb c <> - s ',' <> showb d <> - s ',' <> showb e <> - s ')' - {-# INLINE showb #-} - -instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a, b, c, d, e, f) where - showb (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 ')' - {-# INLINE showb #-} - -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 (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 ')' - {-# INLINE showb #-} - -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 (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 ')' - {-# INLINE showb #-} - -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 (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 ')' - {-# INLINE showb #-} - -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 (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 ')' - {-# 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 (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 ')' - {-# 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 (a, b, c, d, e, f, g, h, i, j, k, l) where - showb (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 ')' - {-# 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 (a, b, c, d, e, f, g, h, i, j, k, l, m) where - showb (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 ')' - {-# 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) => - Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where - showb (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 ')' - {-# 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, Show o) => - Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where - showb (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 ')' - {-# INLINE showb #-} - -instance (Show i, Show e, Ix i) => Show (Array i e) where - showbPrec k a = showbParen (k > 10) $ "array " <> - showb (bounds a) <> s ' ' <> showb (assocs a) - {-# INLINE showb #-} - -instance (Show k, Show v) => Show (Map k v) where - showbPrec k m = showbParen (k > 10) $ "fromList " <> - showb (M.toList m) - {-# INLINE showb #-} - -instance Show e => Show (Set e) where - showbPrec k set = showbParen (k > 10) $ "fromList " <> - showb (S.toList set) - {-# INLINE showb #-} - -instance Show IntPtr where - showb = build - {-# INLINE showb #-} +import Data.Text.Lazy.Builder -instance Show WordPtr where - showb = build - {-# INLINE showb #-} +import Prelude hiding (Show(show), print) -instance Show (Ptr a) where - showb = build - {-# INLINE showb #-} +import Text.Show.Text.Class +import Text.Show.Text.Instances () +import Text.Show.Text.Utils (lengthB, replicateB, unlinesB, unwordsB) diff --git a/src/Text/Show/Text/Class.hs b/src/Text/Show/Text/Class.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Class.hs @@ -0,0 +1,136 @@ +{-# 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)) + +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's, 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 deriving '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 derive '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 +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL showbPrec | showb #-} +#endif + +-- | Constructs a strict 'Text' from a single value. +show :: Show a => a -> TS.Text +show = toStrict . showLazy +{-# INLINE show #-} + +-- | Constructs a lazy 'Text' from a single value. +showLazy :: Show a => a -> TL.Text +showLazy = toLazyText . showb +{-# INLINE showLazy #-} + +-- | Constructs a strict '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 'Text' from a single value with the given precedence. +showPrecLazy :: Show a => Int -> a -> TL.Text +showPrecLazy p = toLazyText . showbPrec p +{-# INLINE showPrecLazy #-} + +-- | +-- Converts a list of 'Show' 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 :: Show a => [a] -> Builder +showbListDefault [] = "[]" +showbListDefault (x:xs) = s '[' <> showb x <> go xs -- "[.. + where + go (y:ys) = s ',' <> showb y <> go ys -- ..,.. + go [] = s ']' -- ..]" +{-# INLINE showbListDefault #-} + +-- | 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 #-} + +-- | Writes a value's strict '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 '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 '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 '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/Control.hs b/src/Text/Show/Text/Control.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control.hs @@ -0,0 +1,17 @@ +----------------------------------------------------------------------------- +-- | +-- 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 () where + +import Text.Show.Text.Control.Applicative () +import Text.Show.Text.Control.Concurrent () +import Text.Show.Text.Control.Exception () +import Text.Show.Text.Control.Monad.ST () diff --git a/src/Text/Show/Text/Control/Applicative.hs b/src/Text/Show/Text/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control/Applicative.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbZipListPrec) where + +import Control.Applicative (ZipList(..)) + +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Data.List () +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'ZipList' to a 'Builder' with the given precedence. +showbZipListPrec :: Show a => Int -> ZipList a -> Builder +showbZipListPrec p (ZipList zl) = showbParen (p > appPrec) $ + "ZipList {getZipList = " + <> showb zl + <> s '}' +{-# INLINE showbZipListPrec #-} + +instance Show a => Show (ZipList a) where + showbPrec = showbZipListPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Control/Concurrent.hs b/src/Text/Show/Text/Control/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control/Concurrent.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbThreadIdPrec + , showbThreadStatusPrec + , showbBlockReason + ) where + +import Data.Text.Lazy.Builder (Builder, fromString) + +import GHC.Conc (BlockReason(..), ThreadId, ThreadStatus(..)) +import GHC.Show (appPrec) + +import qualified Prelude as P +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'ThreadId' to a 'Builder' with the given precedence. +showbThreadIdPrec :: Int -> ThreadId -> Builder +showbThreadIdPrec p ti = fromString $ P.showsPrec p ti "" +{-# INLINE showbThreadIdPrec #-} + +-- | Convert a 'ThreadStatus' to a 'Builder' with the given precedence. +showbThreadStatusPrec :: Int -> ThreadStatus -> Builder +showbThreadStatusPrec _ ThreadRunning = "ThreadRunning" +showbThreadStatusPrec _ ThreadFinished = "ThreadFinished" +showbThreadStatusPrec p (ThreadBlocked br) + = showbParen (p > appPrec) $ "ThreadBlocked " <> showbBlockReason br +showbThreadStatusPrec _ ThreadDied = "ThreadDied" +{-# INLINE showbThreadStatusPrec #-} + +-- | Convert a 'BlockReason' to a 'Builder'. +showbBlockReason :: BlockReason -> Builder +showbBlockReason BlockedOnMVar = "BlockedOnMVar" +showbBlockReason BlockedOnBlackHole = "BlockedOnBlackHole" +showbBlockReason BlockedOnException = "BlockedOnException" +showbBlockReason BlockedOnSTM = "BlockedOnSTM" +showbBlockReason BlockedOnForeignCall = "BlockedOnForeignCall" +showbBlockReason BlockedOnOther = "BlockedOnOther" +{-# INLINE showbBlockReason #-} + +instance Show ThreadId where + showbPrec = showbThreadIdPrec + {-# INLINE showbPrec #-} + +instance Show ThreadStatus where + showbPrec = showbThreadStatusPrec + {-# INLINE showbPrec #-} + +instance Show BlockReason where + showb = showbBlockReason + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Control/Exception.hs b/src/Text/Show/Text/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control/Exception.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbSomeExceptionPrec + , showbIOException + , showbArithException + , showbArrayException + , showbAssertionFailed +#if MIN_VERSION_base(4,7,0) + , showbSomeAsyncException +#endif + , showbAsyncException + , showbNonTermination + , showbNestedAtomically + , showbBlockedIndefinitelyOnMVar + , showbBlockedIndefinitelyOnSTM + , showbDeadlock + , showbNoMethodError + , showbPatternMatchFail + , showbRecConError + , showbRecSelError + , showbRecUpdError + , showbErrorCall + ) where + +import Control.Exception.Base + +import Data.Monoid (mempty) +import Data.Text.Lazy.Builder (Builder, fromString) + +import qualified Prelude as P +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec)) +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'SomeException' value to a 'Builder' with the given precedence. +showbSomeExceptionPrec :: Int -> SomeException -> Builder +showbSomeExceptionPrec p (SomeException e) = fromString $ P.showsPrec p e "" +{-# INLINE showbSomeExceptionPrec #-} + +-- | Convert an 'IOException' to a 'Builder'. +showbIOException :: IOException -> Builder +showbIOException = fromString . show +{-# INLINE showbIOException #-} + +-- | Convert an 'ArithException' to a 'Builder'. +showbArithException :: ArithException -> Builder +showbArithException Overflow = "arithmetic overflow" +showbArithException Underflow = "arithmetic underflow" +showbArithException LossOfPrecision = "loss of precision" +showbArithException DivideByZero = "divide by zero" +showbArithException Denormal = "denormal" +#if MIN_VERSION_base(4,6,0) +showbArithException RatioZeroDenominator = "Ratio has zero denominator" +#endif +{-# INLINE showbArithException #-} + +-- | Convert an 'ArrayException' to a 'Builder'. +showbArrayException :: ArrayException -> Builder +showbArrayException (IndexOutOfBounds s) + = "array index out of range" + <> (if not $ null s then ": " <> fromString s + else mempty) +showbArrayException (UndefinedElement s) + = "undefined array element" + <> (if not $ null s then ": " <> fromString s + else mempty) +{-# INLINE showbArrayException #-} + +-- | Convert an 'AssertionFailed' exception to a 'Builder'. +showbAssertionFailed :: AssertionFailed -> Builder +showbAssertionFailed (AssertionFailed err) = fromString err +{-# INLINE showbAssertionFailed #-} + +#if MIN_VERSION_base(4,7,0) +-- | Convert a 'SomeAsyncException' value to a 'Builder'. +showbSomeAsyncException :: SomeAsyncException -> Builder +showbSomeAsyncException (SomeAsyncException e) = fromString $ P.show e +{-# INLINE showbSomeAsyncException #-} +#endif + +-- | Convert an 'AsyncException' to a 'Builder'. +showbAsyncException :: AsyncException -> Builder +showbAsyncException StackOverflow = "stack overflow" +showbAsyncException HeapOverflow = "heap overflow" +showbAsyncException ThreadKilled = "thread killed" +showbAsyncException UserInterrupt = "user interrupt" +{-# INLINE showbAsyncException #-} + +-- | Convert a 'NonTermination' exception to a 'Builder'. +showbNonTermination :: NonTermination -> Builder +showbNonTermination NonTermination = "<>" +{-# INLINE showbNonTermination #-} + +-- | Convert a 'NestedAtomically' exception to a 'Builder'. +showbNestedAtomically :: NestedAtomically -> Builder +showbNestedAtomically NestedAtomically = "Control.Concurrent.STM.atomically was nested" +{-# INLINE showbNestedAtomically #-} + +-- | Convert a 'BlockedIndefinitelyOnMVar' exception to a 'Builder'. +showbBlockedIndefinitelyOnMVar :: BlockedIndefinitelyOnMVar -> Builder +showbBlockedIndefinitelyOnMVar BlockedIndefinitelyOnMVar = "thread blocked indefinitely in an MVar operation" +{-# INLINE showbBlockedIndefinitelyOnMVar #-} + +-- | Convert a 'BlockedIndefinitelyOnSTM' exception to a 'Builder'. +showbBlockedIndefinitelyOnSTM :: BlockedIndefinitelyOnSTM -> Builder +showbBlockedIndefinitelyOnSTM BlockedIndefinitelyOnSTM = "thread blocked indefinitely in an STM transaction" +{-# INLINE showbBlockedIndefinitelyOnSTM #-} + +-- | Convert a 'Deadlock' exception to a 'Builder'. +showbDeadlock :: Deadlock -> Builder +showbDeadlock Deadlock = "<>" +{-# INLINE showbDeadlock #-} + +-- | Convert a 'NoMethodError' to a 'Builder'. +showbNoMethodError :: NoMethodError -> Builder +showbNoMethodError (NoMethodError err) = fromString err +{-# INLINE showbNoMethodError #-} + +-- | Convert a 'PatternMatchFail' to a 'Builder'. +showbPatternMatchFail :: PatternMatchFail -> Builder +showbPatternMatchFail (PatternMatchFail err) = fromString err +{-# INLINE showbPatternMatchFail #-} + +-- | Convert a 'RecConError' to a 'Builder'. +showbRecConError :: RecConError -> Builder +showbRecConError (RecConError err) = fromString err +{-# INLINE showbRecConError #-} + +-- | Convert a 'RecSelError' to a 'Builder'. +showbRecSelError :: RecSelError -> Builder +showbRecSelError (RecSelError err) = fromString err +{-# INLINE showbRecSelError #-} + +-- | Convert a 'RecUpdError' to a 'Builder'. +showbRecUpdError :: RecUpdError -> Builder +showbRecUpdError (RecUpdError err) = fromString err +{-# INLINE showbRecUpdError #-} + +-- | Convert an 'ErrorCall' to a 'Builder'. +showbErrorCall :: ErrorCall -> Builder +showbErrorCall (ErrorCall err) = fromString err +{-# INLINE showbErrorCall #-} + +-- | Convert a 'MaskingState' to a 'Builder'. +showbMaskingState :: MaskingState -> Builder +showbMaskingState Unmasked = "Unmasked" +showbMaskingState MaskedInterruptible = "MaskedInterruptible" +showbMaskingState MaskedUninterruptible = "MaskedUninterruptible" +{-# INLINE showbMaskingState #-} + +instance Show SomeException where + showbPrec = showbSomeExceptionPrec + {-# INLINE showbPrec #-} + +instance Show IOException where + showb = showbIOException + {-# INLINE showb #-} + +instance Show ArithException where + showb = showbArithException + {-# INLINE showb #-} + +instance Show ArrayException where + showb = showbArrayException + {-# INLINE showb #-} + +instance Show AssertionFailed where + showb = showbAssertionFailed + {-# INLINE showb #-} + +#if MIN_VERSION_base(4,7,0) +instance Show SomeAsyncException where + showb = showbSomeAsyncException + {-# INLINE showb #-} +#endif + +instance Show AsyncException where + showb = showbAsyncException + {-# INLINE showb #-} + +instance Show NonTermination where + showb = showbNonTermination + {-# INLINE showb #-} + +instance Show NestedAtomically where + showb = showbNestedAtomically + {-# INLINE showb #-} + +instance Show BlockedIndefinitelyOnMVar where + showb = showbBlockedIndefinitelyOnMVar + {-# INLINE showb #-} + +instance Show BlockedIndefinitelyOnSTM where + showb = showbBlockedIndefinitelyOnSTM + {-# INLINE showb #-} + +instance Show Deadlock where + showb = showbDeadlock + {-# INLINE showb #-} + +instance Show NoMethodError where + showb = showbNoMethodError + {-# INLINE showb #-} + +instance Show PatternMatchFail where + showb = showbPatternMatchFail + {-# INLINE showb #-} + +instance Show RecConError where + showb = showbRecConError + {-# INLINE showb #-} + +instance Show RecSelError where + showb = showbRecSelError + {-# INLINE showb #-} + +instance Show RecUpdError where + showb = showbRecUpdError + {-# INLINE showb #-} + +instance Show ErrorCall where + showb = showbErrorCall + {-# INLINE showb #-} + +instance Show MaskingState where + showb = showbMaskingState + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Control/Monad/ST.hs b/src/Text/Show/Text/Control/Monad/ST.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control/Monad/ST.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NoImplicitPrelude, 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 (showbST) where + +import Control.Monad.ST (ST) +import Data.Text.Lazy.Builder (Builder) +import Prelude hiding (Show) +import Text.Show.Text.Class (Show(showb)) + +-- | Convert a strict 'ST' value to a 'Builder'. +showbST :: ST s a -> Builder +showbST _ = "<>" +{-# INLINE showbST #-} + +instance Show (ST s a) where + showb = showbST + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data.hs b/src/Text/Show/Text/Data.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data.hs @@ -0,0 +1,38 @@ +{-# 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 () 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 () +#if MIN_VERSION_base(4,7,0) +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 () diff --git a/src/Text/Show/Text/Data/Array.hs b/src/Text/Show/Text/Data/Array.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Array.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude, 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 (showbArrayPrec) where + +import Data.Array (Array, assocs, bounds) +import Data.Ix (Ix) +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Data.List () +import Text.Show.Text.Data.Tuple () +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'Array' value to a 'Builder' with the given precedence. +showbArrayPrec :: (Show i, Show e, Ix i) => Int -> Array i e -> Builder +showbArrayPrec p a = showbParen (p > appPrec) $ + "array " + <> showbPrec appPrec1 (bounds a) + <> s ' ' + <> showbPrec appPrec1 (assocs a) +{-# INLINE showbArrayPrec #-} + +instance (Show i, Show e, Ix i) => Show (Array i e) where + showbPrec = showbArrayPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Data/Bool.hs b/src/Text/Show/Text/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Bool.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbBool) where + +import Data.Text.Buildable (build) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) + +-- | Convert a 'Bool' to a 'Builder'. +showbBool :: Bool -> Builder +showbBool = build +{-# INLINE showbBool #-} + +instance Show Bool where + showb = showbBool + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/ByteString.hs b/src/Text/Show/Text/Data/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/ByteString.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} +#if !(MIN_VERSION_bytestring(0,10,0)) +{-# LANGUAGE OverloadedStrings #-} +#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 ( + showbByteStringStrict + , showbByteStringLazy + , showbByteStringLazyPrec +#if MIN_VERSION_bytestring(0,10,4) + , showbShortByteString +#endif + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +#if MIN_VERSION_bytestring(0,10,4) +import Data.ByteString.Short (ShortByteString) +#endif +import Data.Text.Lazy.Builder (Builder, fromString) + +import qualified Prelude as P +import Prelude hiding (Show(show)) + +import Text.Show.Text.Class (Show(showb, showbPrec)) + +-- Imports needed for older versions of bytestring +#if !(MIN_VERSION_bytestring(0,10,0)) +import qualified Data.ByteString.Lazy.Internal as BL + +import GHC.Show (appPrec, appPrec1) + +import Text.Show.Text.Class (showbParen) +import Text.Show.Text.Utils ((<>), s) +#endif + +-- | Convert a strict 'ByteString' to a 'Builder'. +showbByteStringStrict :: BS.ByteString -> Builder +showbByteStringStrict = fromString . P.show +{-# INLINE showbByteStringStrict #-} + +-- | Convert a lazy 'ByteString' to a 'Builder'. +showbByteStringLazy :: BL.ByteString -> Builder +showbByteStringLazy = showbByteStringLazyPrec 0 +{-# INLINE showbByteStringLazy #-} + +-- | Convert a lazy 'ByteString' to a 'Builder' with the given precedence. +-- +-- With @bytestring-0.10.0.0@ or later, this function ignores the precedence +-- argument, since lazy 'ByteString's are printed out identically to 'String's. +-- On earlier versions of @bytestring@, however, lazy 'ByteString's can be printed +-- with parentheses (e.g., @Chunk "example" Empty@ vs. @(Chunk "example" Empty)@) +-- depending on the precedence. +showbByteStringLazyPrec :: Int -> BL.ByteString -> Builder +#if MIN_VERSION_bytestring(0,10,0) +showbByteStringLazyPrec _ = fromString . P.show +#else +showbByteStringLazyPrec _ BL.Empty = "Empty" +showbByteStringLazyPrec p (BL.Chunk bs bl) = showbParen (p > appPrec) $ + "Chunk " + <> showbPrec appPrec1 bs + <> s ' ' + <> showbPrec appPrec1 bl +#endif +{-# INLINE showbByteStringLazyPrec #-} + +#if MIN_VERSION_bytestring(0,10,4) +-- | Convert a 'ShortByteString' to a 'Builder'. +showbShortByteString :: ShortByteString -> Builder +showbShortByteString = fromString . P.show +{-# INLINE showbShortByteString #-} +#endif + +instance Show BS.ByteString where + showb = showbByteStringStrict + {-# INLINE showb #-} + +instance Show BL.ByteString where + showbPrec = showbByteStringLazyPrec + {-# INLINE showbPrec #-} + +#if MIN_VERSION_bytestring(0,10,4) +instance Show ShortByteString where + showb = showbShortByteString + {-# INLINE showb #-} +#endif diff --git a/src/Text/Show/Text/Data/Char.hs b/src/Text/Show/Text/Data/Char.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Char.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbChar + , showbLitChar + , showbString + , showbLitString + , showbGeneralCategory + ) where + +import Data.Array (Array, (!), listArray) +import Data.Char (GeneralCategory(..), isDigit, ord) +import Data.Monoid (mempty) +import Data.Text.Buildable (build) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(..)) +import Text.Show.Text.Utils ((<>), s) + +-- | A table of ASCII control characters that needs to be escaped with a backslash. +asciiTabB :: Array Int Builder +asciiTabB = listArray (0, 32) ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + "SP"] + +-- | Convert a 'Char' to a 'Builder' (surrounded by single quotes). +showbChar :: Char -> Builder +showbChar '\'' = "'\\''" +showbChar c = s '\'' <> showbLitChar c <> s '\'' +{-# INLINE showbChar #-} + +-- | Convert a 'Char' to a 'Builder' (without single quotes). +showbLitChar :: Char -> Builder +showbLitChar c | c > '\DEL' = s '\\' <> build (ord c) +showbLitChar '\DEL' = "\\DEL" +showbLitChar '\\' = "\\\\" +showbLitChar c | c >= ' ' = s c +showbLitChar '\a' = "\\a" +showbLitChar '\b' = "\\b" +showbLitChar '\f' = "\\f" +showbLitChar '\n' = "\\n" +showbLitChar '\r' = "\\r" +showbLitChar '\t' = "\\t" +showbLitChar '\v' = "\\v" +showbLitChar '\SO' = "\\SO" +showbLitChar c = s '\\' <> (asciiTabB ! ord c) +{-# INLINE showbLitChar #-} + +-- | Convert a 'String' to a 'Builder' (surrounded by double quotes). +showbString :: String -> Builder +showbString cs = s '"' <> showbLitString cs <> s '"' +{-# INLINE showbString #-} + +-- | Convert a 'String' to a 'Builder' (without double quotes). +showbLitString :: String -> Builder +showbLitString [] = mempty +showbLitString ('\SO':'H':cs) = "\\SO\\&H" <> showbLitString cs +showbLitString ('"':cs) = "\\\"" <> showbLitString cs +showbLitString (c:d:cs) + | c > '\DEL' && isDigit d = s '\\' <> build (ord c) <> "\\&" <> s d <> showbLitString cs +showbLitString (c:cs) = showbLitChar c <> showbLitString cs +{-# INLINE showbLitString #-} + +-- | Convert a 'GeneralCategory' to a 'Builder'. +showbGeneralCategory :: GeneralCategory -> Builder +showbGeneralCategory UppercaseLetter = "UppercaseLetter" +showbGeneralCategory LowercaseLetter = "LowercaseLetter" +showbGeneralCategory TitlecaseLetter = "TitlecaseLetter" +showbGeneralCategory ModifierLetter = "ModifierLetter" +showbGeneralCategory OtherLetter = "OtherLetter" +showbGeneralCategory NonSpacingMark = "NonSpacingMark" +showbGeneralCategory SpacingCombiningMark = "SpacingCombiningMark" +showbGeneralCategory EnclosingMark = "EnclosingMark" +showbGeneralCategory DecimalNumber = "DecimalNumber" +showbGeneralCategory LetterNumber = "LetterNumber" +showbGeneralCategory OtherNumber = "OtherNumber" +showbGeneralCategory ConnectorPunctuation = "ConnectorPunctuation" +showbGeneralCategory DashPunctuation = "DashPunctuation" +showbGeneralCategory OpenPunctuation = "OpenPunctuation" +showbGeneralCategory ClosePunctuation = "ClosePunctuation" +showbGeneralCategory InitialQuote = "InitialQuote" +showbGeneralCategory FinalQuote = "FinalQuote" +showbGeneralCategory OtherPunctuation = "OtherPunctuation" +showbGeneralCategory MathSymbol = "MathSymbol" +showbGeneralCategory CurrencySymbol = "CurrencySymbol" +showbGeneralCategory ModifierSymbol = "ModifierSymbol" +showbGeneralCategory OtherSymbol = "OtherSymbol" +showbGeneralCategory Space = "Space" +showbGeneralCategory LineSeparator = "LineSeparator" +showbGeneralCategory ParagraphSeparator = "ParagraphSeparator" +showbGeneralCategory Control = "Control" +showbGeneralCategory Format = "Format" +showbGeneralCategory Surrogate = "Surrogate" +showbGeneralCategory PrivateUse = "PrivateUse" +showbGeneralCategory NotAssigned = "NotAssigned" +{-# INLINE showbGeneralCategory #-} + +instance Show Char where + showb = showbChar + {-# INLINE showb #-} + + showbList = showbString + {-# INLINE showbList #-} + +instance Show GeneralCategory where + showb = showbGeneralCategory + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Containers.hs b/src/Text/Show/Text/Data/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Containers.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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, showbListDefault) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.Tuple () +import Text.Show.Text.Utils ((<>), s) + +-- | Convert an 'IntMap' into a 'Builder' with the given precedence. +showbIntMapPrec :: Show v => Int -> IntMap v -> Builder +showbIntMapPrec p im + = showbParen (p > appPrec) $ "fromList " <> showbListDefault (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 " <> showbListDefault (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 " <> showbListDefault (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 " <> showbListDefault (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 " <> showbListDefault (Set.toList s') +{-# INLINE showbSetPrec #-} + +-- | Convert a 'Tree' into a 'Builder' with the given precedence. +showbTreePrec :: Show a => Int -> Tree a -> Builder +showbTreePrec p (Node rl sf) = showbParen (p > appPrec) $ + "Node {rootLabel = " + <> showb rl + <> ", subForest = " + <> showbListDefault sf + <> s '}' +{-# 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 #-} + +instance Show a => Show (Tree a) where + showbPrec = showbTreePrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Data/Data.hs b/src/Text/Show/Text/Data/Data.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Data.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbConstr + , showbConstrRepPrec + , showbDataRepPrec + , showbDataTypePrec + , showbFixity + ) where + +import Data.Data (Constr, ConstrRep(..), DataRep(..), DataType, Fixity(..), + dataTypeName, dataTypeRep, showConstr) +import Data.Text.Lazy.Builder (Builder, fromString) + +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Data.Char (showbChar) +import Text.Show.Text.Data.Integral (showbIntPrec, showbIntegerPrec, showbRatioPrec) +import Text.Show.Text.Data.List () +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'DataType' to a 'Builder' with the given precedence. +showbDataTypePrec :: Int -> DataType -> Builder +showbDataTypePrec p dt = showbParen (p > appPrec) $ + "DataType {tycon = " + <> showb (dataTypeName dt) + <> ", datarep = " + <> showb (dataTypeRep dt) + <> s '}' +{-# INLINE showbDataTypePrec #-} + +-- | Convert a 'DataRep' to a 'Builder' with the given precedence. +showbDataRepPrec :: Int -> DataRep -> Builder +showbDataRepPrec p (AlgRep cs) = showbParen (p > appPrec) $ "AlgRep " <> showb cs +showbDataRepPrec _ IntRep = "IntRep" +showbDataRepPrec _ FloatRep = "FloatRep" +showbDataRepPrec _ CharRep = "CharRep" +showbDataRepPrec _ NoRep = "NoRep" +{-# INLINE showbDataRepPrec #-} + +-- | Convert a 'Constr' to a 'Builder'. +showbConstr :: Constr -> Builder +showbConstr = fromString . showConstr +{-# INLINE showbConstr #-} + +-- | Convert a 'Fixity' value to a 'Builder'. +showbFixity :: Fixity -> Builder +showbFixity Prefix = "Prefix" +showbFixity Infix = "Infix" +{-# INLINE showbFixity #-} + +-- | Convert a 'ConstrRep' to a 'Builder' with the given precedence. +showbConstrRepPrec :: Int -> ConstrRep -> Builder +showbConstrRepPrec p (AlgConstr ci) + = showbParen (p > appPrec) $ "AlgConstr " <> showbIntPrec appPrec1 ci +showbConstrRepPrec p (IntConstr i) + = showbParen (p > appPrec) $ "IntConstr " <> showbIntegerPrec appPrec1 i +showbConstrRepPrec p (FloatConstr r) + = showbParen (p > appPrec) $ "FloatConstr " <> showbRatioPrec appPrec1 r +showbConstrRepPrec p (CharConstr c) + = showbParen (p > appPrec) $ "CharConstr " <> showbChar c +{-# INLINE showbConstrRepPrec #-} + +instance Show DataType where + showbPrec = showbDataTypePrec + {-# INLINE showbPrec #-} + +instance Show DataRep where + showbPrec = showbDataRepPrec + {-# INLINE showbPrec #-} + +instance Show Constr where + showb = showbConstr + {-# INLINE showb #-} + +instance Show ConstrRep where + showbPrec = showbConstrRepPrec + {-# INLINE showbPrec #-} + +instance Show Fixity where + showb = showbFixity + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Dynamic.hs b/src/Text/Show/Text/Data/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Dynamic.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude, 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 (showbDynamic) where + +import Data.Dynamic (Dynamic, dynTypeRep) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Data.Typeable (showbTypeRepPrec) +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'Dynamic' value to a 'Builder'. +showbDynamic :: Dynamic -> Builder +showbDynamic dyn = "<<" <> showbTypeRepPrec 0 (dynTypeRep dyn) <> ">>" +{-# INLINE showbDynamic #-} + +instance Show Dynamic where + showb = showbDynamic + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Either.hs b/src/Text/Show/Text/Data/Either.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Either.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbEitherPrec) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'Either' value to a 'Builder' with the given precedence. +showbEitherPrec :: (Show a, Show b) => Int -> Either a b -> Builder +showbEitherPrec p (Left a) = showbParen (p > appPrec) $ "Left " <> showbPrec appPrec1 a +showbEitherPrec p (Right b) = showbParen (p > appPrec) $ "Right " <> showbPrec appPrec1 b +{-# INLINE showbEitherPrec #-} + +instance (Show a, Show b) => Show (Either a b) where + showbPrec = showbEitherPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Data/Fixed.hs b/src/Text/Show/Text/Data/Fixed.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Fixed.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# 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 (showbFixed) where + +import Data.Fixed (HasResolution(..)) +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) + +#if MIN_VERSION_base(4,7,0) +import Data.Fixed (Fixed(..)) +import Data.Int (Int64) +import Data.Monoid (mempty) + +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) +#else +import Data.Fixed (Fixed, showFixed) +import Data.Text.Lazy.Builder (fromString) +#endif + +-- | Convert a 'Fixed' value to a 'Builder', where the first argument indicates +-- whether to chop off trailing zeroes. +showbFixed :: HasResolution a => Bool -> Fixed a -> Builder +#if MIN_VERSION_base(4,7,0) +showbFixed chopTrailingZeroes fa@(MkFixed a) | a < 0 + = s '-' <> showbFixed chopTrailingZeroes (asTypeOf (MkFixed (negate a)) fa) +showbFixed chopTrailingZeroes fa@(MkFixed a) + = showb i <> withDotB (showbIntegerZeroes chopTrailingZeroes digits fracNum) + where + res = fromInteger $ resolution fa + (i, d) = divMod (fromInteger a) res + digits = ceiling (logBase 10 (fromInteger $ resolution fa) :: Double) + maxnum = 10 ^ digits + fracNum = div (d * maxnum) res +#else +showbFixed chopTrailingZeroes = fromString . showFixed chopTrailingZeroes +#endif +{-# INLINE showbFixed #-} + +#if MIN_VERSION_base(4,7,0) +-- | Only works for positive 'Integer's. +showbIntegerZeroes :: Bool -> Int64 -> Integer -> Builder +showbIntegerZeroes True _ 0 = mempty +showbIntegerZeroes chopTrailingZeroes digits a = replicateB (digits - lengthB sh) (s '0') <> sh' + where + sh, sh' :: Builder + sh = showb a + sh' = if chopTrailingZeroes then chopZeroesB a else sh +{-# INLINE showbIntegerZeroes #-} + +-- | Chops off the trailing zeroes of an 'Integer'. +chopZeroesB :: Integer -> Builder +chopZeroesB 0 = mempty +chopZeroesB a | mod a 10 == 0 = chopZeroesB (div a 10) +chopZeroesB a = showb a +{-# INLINE chopZeroesB #-} + +-- | Prepends a dot to a non-empty 'Builder'. +withDotB :: Builder -> Builder +withDotB b | b == mempty = mempty + | otherwise = s '.' <> b +{-# INLINE withDotB #-} +#endif + +instance HasResolution a => Show (Fixed a) where + showb = showbFixed False + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Floating.hs b/src/Text/Show/Text/Data/Floating.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Floating.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE NoImplicitPrelude, 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 ( + showbRealFloatPrec + , showbFloatPrec + , showbDoublePrec + , showbComplexPrec + , showbEFloat + , showbFFloat + , showbGFloat + , showbFFloatAlt + , showbGFloatAlt + ) where + +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) +import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Utils ((<>), i2d, s) + +-- | Convert a 'RealFloat' value to a 'Builder' with the given precedence. +showbRealFloatPrec :: RealFloat a => Int -> a -> Builder +showbRealFloatPrec p x + | x < 0 || isNegativeZero x = showbParen (p > 6) $ s '-' <> showbGFloat Nothing (-x) + | otherwise = showbGFloat Nothing x +{-# INLINE showbRealFloatPrec #-} + +-- | Convert a 'Float' to a 'Builder' with the given precedence. +showbFloatPrec :: Int -> Float -> Builder +showbFloatPrec = showbRealFloatPrec +{-# INLINE showbFloatPrec #-} + +-- | Convert a 'Double' to a 'Builder' with the given precedence. +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. +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. +showbFFloat :: RealFloat a => Maybe Int -> a -> Builder +showbFFloat = formatRealFloat Fixed +{-# INLINE showbFFloat #-} + +-- | 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. +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. +showbFFloatAlt :: RealFloat a => Maybe Int -> a -> Builder +showbFFloatAlt d x = formatRealFloatAlt Fixed d True x +{-# INLINE showbFFloatAlt #-} + +-- | 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. +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 #-} + +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 #-} + +------------------------------------------------------------------------------- +-- 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@. +formatRealFloat :: RealFloat a + => FPFormat -- ^ What notation to use. + -> Maybe Int -- ^ Number of decimal places to render. + -> a + -> Builder +formatRealFloat fmt decs = formatRealFloatAlt fmt decs False +{-# INLINE formatRealFloat #-} + +-- | Converts a 'RealFloat' value to a Builder. Super-configurable. +formatRealFloatAlt :: RealFloat a + => FPFormat -- ^ What notation to use. + -> Maybe Int -- ^ Number of decimal places to render. + -> Bool -- ^ Should a decimal point always be shown? + -> a + -> Builder +{-# SPECIALIZE formatRealFloatAlt :: FPFormat -> Maybe Int -> Bool -> Float -> Builder #-} +{-# SPECIALIZE formatRealFloatAlt :: FPFormat -> Maybe Int -> Bool -> Double -> Builder #-} +formatRealFloatAlt fmt decs alt x + | isNaN x = "NaN" + | isInfinite x = if x < 0 then "-Infinity" else "Infinity" + | x < 0 || isNegativeZero x = s '-' <> doFmt fmt (floatToDigits (-x)) + | otherwise = doFmt fmt (floatToDigits x) + where + doFmt format (is, e) = + let ds = map i2d is in + case format of + Generic -> + doFmt (if e < 0 || e > 7 then Exponent else Fixed) + (is,e) + Exponent -> + case decs of + Nothing -> + let show_e' = decimal (e-1) in + case ds of + "0" -> "0.0e0" + [d] -> s d <> ".0e" <> show_e' + (d:ds') -> s d <> s '.' <> fromString ds' <> s 'e' <> show_e' + [] -> error "formatRealFloat/doFmt/Exponent: []" + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0" + _ -> + let + (ei,is') = roundTo (dec'+1) is + (d:ds') = map i2d (if ei > 0 then init is' else is') + in + s d <> s '.' <> fromString ds' <> s 'e' <> decimal (e-1+ei) + Fixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls} + in + case decs of + Nothing + | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds + | otherwise -> + let + f 0 str rs = mk0 (reverse str) <> s '.' <> mk0 rs + f n str "" = f (n-1) ('0':str) "" + f n str (r:rs) = f (n-1) (r:str) rs + in + f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let + (ei,is') = roundTo (dec' + e) is + (ls,rs) = splitAt (e+ei) (map i2d is') + in + mk0 ls <> (if null rs && not alt then "" else s '.' <> fromString rs) + else + let + (ei,is') = roundTo dec' (replicate (-e) 0 ++ is) + d:ds' = map i2d (if ei > 0 then is' else 0:is') + in + s d <> (if null ds' && not alt then "" else s '.' <> fromString ds') + +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R.K. Dybvig in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number, +-- and returns a list of digits and an exponent. +-- In particular, if @x>=0@, and +-- +-- > floatToDigits base x = ([d1,d2,...,dn], e) +-- +-- then +-- +-- (1) @n >= 1@ +-- +-- (2) @x = 0.d1d2...dn * (base**e)@ +-- +-- (3) @0 <= di <= base-1@ +floatToDigits :: (RealFloat a) => a -> ([Int], Int) +{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-} +{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-} +floatToDigits 0 = ([0], 0) +floatToDigits x = + let + (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = + let n = minExp - e0 in + if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0) + (r, s', mUp, mDn) = + if e >= 0 then + let be = expt b e in + if f == expt b (p-1) then + (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig + else + (f*be*2, 2, be, be) + else + if e > minExp && f == expt b (p-1) then + (f*b*2, expt b (-e+1)*2, b, 1) + else + (f*2, expt b (-e)*2, 1, 1) + k :: Int + k = + let + k0 :: Int + k0 = + if b == 2 then + -- logBase 10 2 is very slightly larger than 8651/28738 + -- (about 5.3558e-10), so if log x >= 0, the approximation + -- k1 is too small, hence we add one and need one fixup step less. + -- If log x < 0, the approximation errs rather on the high side. + -- That is usually more than compensated for by ignoring the + -- fractional part of logBase 2 x, but when x is a power of 1/2 + -- or slightly larger and the exponent is a multiple of the + -- denominator of the rational approximation to logBase 10 2, + -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x, + -- we get a leading zero-digit we don't want. + -- With the approximation 3/10, this happened for + -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above. + -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x + -- for IEEE-ish floating point types with exponent fields + -- <= 17 bits and mantissae of several thousand bits, earlier + -- convergents to logBase 10 2 would fail for long double. + -- Using quot instead of div is a little faster and requires + -- fewer fixup steps for negative lx. + let lx = p - 1 + e0 + k1 = (lx * 8651) `quot` 28738 + in if lx >= 0 then k1 + 1 else k1 + else + -- f :: Integer, log :: Float -> Float, + -- ceiling :: Float -> Int + ceiling ((log (fromInteger (f+1) :: Float) + + fromIntegral e * log (fromInteger b)) / + log 10) +--WAS: fromInt e * log (fromInteger b)) + + fixup n = + if n >= 0 then + if r + mUp <= expt 10 n * s' then n else fixup (n+1) + else + if expt 10 (-n) * (r + mUp) <= s' then n else fixup (n+1) + in + fixup k0 + + gen ds rn sN mUpN mDnN = + let + (dn, rn') = (rn * 10) `quotRem` sN + mUpN' = mUpN * 10 + mDnN' = mDnN * 10 + in + case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + + rds = + if k >= 0 then + gen [] r (s' * expt 10 k) mUp mDn + else + let bk = expt 10 (-k) in + gen [] (r * bk) s' (mUp * bk) (mDn * bk) + in + (map fromIntegral (reverse rds), k) + +-- | +roundTo :: Int -> [Int] -> (Int,[Int]) +roundTo d is = + case f d True is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) + _ -> error "roundTo: bad Value" + where + 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 n _ (i:xs) + | i' == 10 = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) (even i) xs + i' = c + i + +-- Exponentiation with a cache for the most common numbers. + +-- | The minimum exponent in the cache. +minExpt :: Int +minExpt = 0 +{-# INLINE minExpt #-} + +-- | The maximum exponent (of 2) in the cache. +maxExpt :: Int +maxExpt = 1100 +{-# INLINE maxExpt #-} + +-- | Exponentiate an 'Integer', using a cache if possible. +expt :: Integer -> Int -> Integer +expt base n + | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n + | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n + | otherwise = base^n +{-# INLINE expt #-} + +-- | Cached powers of two. +expts :: Array Int Integer +expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] + +-- | The maximum exponent (of 10) in the cache. +maxExpt10 :: Int +maxExpt10 = 324 +{-# INLINE maxExpt10 #-} + +-- | Cached powers of 10. +expts10 :: Array Int Integer +expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]] diff --git a/src/Text/Show/Text/Data/Integral.hs b/src/Text/Show/Text/Data/Integral.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Integral.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbIntPrec + , showbInt8Prec + , showbInt16Prec + , showbInt32Prec + , showbInt64Prec + , showbIntegerPrec + , showbIntegralPrec + , showbIntAtBase + , showbBin + , showbHex + , showbOct + , showbRatioPrec + , showbWord + , showbWord8 + , showbWord16 + , showbWord32 + , showbWord64 + ) where + +import Data.Char (intToDigit) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Monoid (mempty) +import Data.Ratio (Ratio, numerator, denominator) +import Data.Text.Buildable (build) +import Data.Text.Lazy.Builder (Builder) +import Data.Word (Word, Word8, Word16, Word32, Word64) + +import GHC.Exts (Int(I#)) +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Exts (isTrue#) +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) + +-- | Convert an 'Int' to a 'Builder' with the given precedence. +showbIntPrec :: Int -> Int -> Builder +showbIntPrec (I# p) n'@(I# n) + | isTrue (n <# 0#) && isTrue (p ># 6#) = s '(' <> build n' <> s ')' + | otherwise = build n' + where +#if __GLASGOW_HASKELL__ >= 708 + isTrue :: Int# -> Bool + isTrue b = isTrue# b +#else + isTrue :: Bool -> Bool + isTrue = id +#endif + +-- | Convert an 'Int8' to a 'Builder' with the given precedence. +showbInt8Prec :: Int -> Int8 -> Builder +showbInt8Prec p = showbIntPrec p . fromIntegral +{-# INLINE showbInt8Prec #-} + +-- | Convert an 'Int16' to a 'Builder' with the given precedence. +showbInt16Prec :: Int -> Int16 -> Builder +showbInt16Prec p = showbIntPrec p . fromIntegral +{-# INLINE showbInt16Prec #-} + +-- | Convert an 'Int32' to a 'Builder' with the given precedence. +showbInt32Prec :: Int -> Int32 -> Builder +showbInt32Prec p = showbIntPrec p . fromIntegral +{-# INLINE showbInt32Prec #-} + +-- | Convert an 'Int64' to a 'Builder' with the given precedence. +showbInt64Prec :: Int -> Int64 -> Builder +#if WORD_SIZE_IN_BITS < 64 +showbInt64Prec p = showbIntegerPrec p . toInteger +#else +showbInt64Prec p = showbIntPrec p . fromIntegral +#endif +{-# INLINE showbInt64Prec #-} + +-- | Convert an 'Integer' to a 'Builder' with the given precedence. +showbIntegerPrec :: Int -> Integer -> Builder +showbIntegerPrec p n + | p > 6 && n < 0 = s '(' <> build n <> s ')' + | otherwise = build n +{-# INLINE showbIntegerPrec #-} + +-- | Convert an 'Integral' type to a 'Builder' with the given precedence. +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. +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 + | otherwise = showbIt (quotRem n0 base) mempty + where + showbIt (n, d) b = seq c $ -- stricter than necessary + case n of + 0 -> b' + _ -> showbIt (quotRem n base) b' + where + c :: Char + c = toChr $ fromIntegral d + + b' :: Builder + b' = s c <> b +{-# INLINE showbIntAtBase #-} + +-- | Show /non-negative/ 'Integral' numbers in base 2. +showbBin :: (Integral a, Show a) => a -> Builder +showbBin = showbIntAtBase 2 intToDigit +{-# INLINE showbBin #-} + +-- | Show /non-negative/ 'Integral' numbers in base 16. +showbHex :: (Integral a, Show a) => a -> Builder +showbHex = showbIntAtBase 16 intToDigit +{-# INLINE showbHex #-} + +-- | Show /non-negative/ 'Integral' numbers in base 8. +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. +showbWord :: Word -> Builder +showbWord = build +{-# INLINE showbWord #-} + +-- | Convert a 'Word8' to a 'Builder' with the given precedence. +showbWord8 :: Word8 -> Builder +showbWord8 = build +{-# INLINE showbWord8 #-} + +-- | Convert a 'Word16' to a 'Builder' with the given precedence. +showbWord16 :: Word16 -> Builder +showbWord16 = build +{-# INLINE showbWord16 #-} + +-- | Convert a 'Word32' to a 'Builder' with the given precedence. +showbWord32 :: Word32 -> Builder +showbWord32 = build +{-# INLINE showbWord32 #-} + +-- | Convert a 'Word64' to a 'Builder' with the given precedence. +showbWord64 :: Word64 -> Builder +showbWord64 = build +{-# INLINE showbWord64 #-} + +instance Show Int where + showbPrec = showbIntPrec + {-# INLINE showbPrec #-} + +instance Show Int8 where + showbPrec = showbInt8Prec + {-# INLINE showbPrec #-} + +instance Show Int16 where + showbPrec = showbInt16Prec + {-# INLINE showbPrec #-} + +instance Show Int32 where + showbPrec = showbInt32Prec + {-# INLINE showbPrec #-} + +instance Show Int64 where + showbPrec = showbInt64Prec + {-# INLINE 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 #-} + +instance Show Word where + showb = showbWord + {-# INLINE showb #-} + +instance Show Word8 where + showb = showbWord8 + {-# INLINE showb #-} + +instance Show Word16 where + showb = showbWord16 + {-# INLINE showb #-} + +instance Show Word32 where + showb = showbWord32 + {-# INLINE showb #-} + +instance Show Word64 where + showb = showbWord64 + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/List.hs b/src/Text/Show/Text/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/List.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# 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 (showbListDefault) where + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbList), showbListDefault) +import Text.Show.Text.Data.Char () +import Text.Show.Text.Data.Integral () + +instance Show a => Show [a] where + {-# SPECIALIZE instance Show [String] #-} + {-# SPECIALIZE instance Show [Char] #-} + {-# SPECIALIZE instance Show [Int] #-} + showb = showbList + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Maybe.hs b/src/Text/Show/Text/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Maybe.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbMaybePrec) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'Maybe' value to a 'Builder' with the given precedence. +showbMaybePrec :: Show a => Int -> Maybe a -> Builder +showbMaybePrec _ Nothing = "Nothing" +showbMaybePrec p (Just a) = showbParen (p > appPrec) $ "Just " <> showbPrec appPrec1 a +{-# INLINE showbMaybePrec #-} + +instance Show a => Show (Maybe a) where + showbPrec = showbMaybePrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Data/Monoid.hs b/src/Text/Show/Text/Data/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Monoid.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbAllPrec + , showbAnyPrec + , showbDualPrec + , showbFirstPrec + , showbLastPrec + , showbProductPrec + , showbSumPrec + ) where + +import Data.Monoid (All(..), Any(..), Dual(..), First(..), + Last(..), Product(..), Sum(..)) +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Data.Bool (showbBool) +import Text.Show.Text.Data.Maybe (showbMaybePrec) +import Text.Show.Text.Utils ((<>), s) + +-- | Convert an 'All' value to a 'Builder' with the given precedence. +showbAllPrec :: Int -> All -> Builder +showbAllPrec p (All a) = showbParen (p > appPrec) $ + "All {getAll = " + <> showbBool a + <> s '}' +{-# INLINE showbAllPrec #-} + +-- | Convert an 'Any' value to a 'Builder' with the given precedence. +showbAnyPrec :: Int -> Any -> Builder +showbAnyPrec p (Any a) = showbParen (p > appPrec) $ + "Any {getAny = " + <> showbBool a + <> s '}' +{-# INLINE showbAnyPrec #-} + +-- | Convert a 'Dual' value to a 'Builder' with the given precedence. +showbDualPrec :: Show a => Int -> Dual a -> Builder +showbDualPrec p (Dual d) = showbParen (p > appPrec) $ + "Dual {getDual = " + <> showb d + <> s '}' +{-# INLINE showbDualPrec #-} + +-- | Convert a 'First' value to a 'Builder' with the given precedence. +showbFirstPrec :: Show a => Int -> First a -> Builder +showbFirstPrec p (First f) = showbParen (p > appPrec) $ + "First {getFirst = " + <> showbMaybePrec 0 f + <> s '}' +{-# INLINE showbFirstPrec #-} + +-- | Convert a 'Last' value to a 'Builder' with the given precedence. +showbLastPrec :: Show a => Int -> Last a -> Builder +showbLastPrec p (Last l) = showbParen (p > appPrec) $ + "Last {getLast = " + <> showbMaybePrec 0 l + <> s '}' +{-# INLINE showbLastPrec #-} + +-- | Convert a 'Product' value to a 'Builder' with the given precedence. +showbProductPrec :: Show a => Int -> Product a -> Builder +showbProductPrec p (Product prod) = showbParen (p > appPrec) $ + "Product {getProduct = " + <> showb prod + <> s '}' +{-# INLINE showbProductPrec #-} + +-- | Convert a 'Sum' value to a 'Builder' with the given precedence. +showbSumPrec :: Show a => Int -> Sum a -> Builder +showbSumPrec p (Sum sum') = showbParen (p > appPrec) $ + "Sum {getSum = " + <> showb sum' + <> s '}' +{-# INLINE showbSumPrec #-} + +instance Show All where + showbPrec = showbAllPrec + {-# INLINE showbPrec #-} + +instance Show Any where + showbPrec = showbAnyPrec + {-# INLINE showbPrec #-} + +instance Show a => Show (Dual a) where + showbPrec = showbDualPrec + {-# INLINE showbPrec #-} + +instance Show a => Show (First a) where + showbPrec = showbFirstPrec + {-# INLINE showbPrec #-} + +instance Show a => Show (Last a) where + showbPrec = showbLastPrec + {-# INLINE showbPrec #-} + +instance Show a => Show (Product a) where + showbPrec = showbProductPrec + {-# INLINE showbPrec #-} + +instance Show a => Show (Sum a) where + showbPrec = showbSumPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Data/Ord.hs b/src/Text/Show/Text/Data/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Ord.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbOrdering +#if MIN_VERSION_base(4,6,0) + , showbDownPrec +#endif + ) where + +import Data.Text.Lazy.Builder (Builder) +import Prelude hiding (Show) +import Text.Show.Text.Class (Show(showb)) + +#if MIN_VERSION_base(4,6,0) +import Data.Ord (Down(..)) +import GHC.Show (appPrec, appPrec1) +import Text.Show.Text.Class (showbPrec, showbParen) +import Text.Show.Text.Utils ((<>)) +#endif + +-- | Convert a 'Ordering' to a 'Builder'. +showbOrdering :: Ordering -> Builder +showbOrdering LT = "LT" +showbOrdering EQ = "EQ" +showbOrdering GT = "GT" +{-# INLINE showbOrdering #-} + +instance Show Ordering where + showb = showbOrdering + {-# INLINE showb #-} + +#if MIN_VERSION_base(4,6,0) +-- | Convert a 'Down' value to a 'Builder' with the given precedence. +showbDownPrec :: Show a => Int -> Down a -> Builder +showbDownPrec p (Down d) = showbParen (p > appPrec) $ "Down " <> showbPrec appPrec1 d +{-# INLINE showbDownPrec #-} + +instance Show a => Show (Down a) where + showbPrec = showbDownPrec + {-# INLINE showbPrec #-} +#endif diff --git a/src/Text/Show/Text/Data/Text.hs b/src/Text/Show/Text/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Text.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# 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 ( + showbTextStrict + , showbTextLazy + ) where + +import Data.Text as TS +import Data.Text.Lazy as TL +import Data.Text.Lazy.Builder (Builder, toLazyText) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Data.Char () +import Text.Show.Text.Data.List () + +-- | Convert a strict 'Text' into a 'Builder'. +showbTextStrict :: TS.Text -> Builder +showbTextStrict = showb . TS.unpack + +-- | Convert a lazy 'Text' into a 'Builder'. +showbTextLazy :: TL.Text -> Builder +showbTextLazy = showb . TL.unpack + +instance Show Builder where + showb = showb . toLazyText + {-# INLINE showb #-} + +-- Strict variant +instance Show TS.Text where + showb = showbTextStrict + {-# INLINE showb #-} + +-- Lazy variant +instance Show TL.Text where + showb = showbTextLazy + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Time.hs b/src/Text/Show/Text/Data/Time.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Time.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE 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 + ) where + +import Data.Text.Buildable (build) +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, + utc, utcToLocalTime) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'Day' into a 'Builder'. +showbDay :: Day -> Builder +showbDay = build +{-# INLINE showbDay #-} + +-- | Convert a 'DiffTime' into a 'Builder'. +showbDiffTime :: DiffTime -> Builder +showbDiffTime = build +{-# INLINE showbDiffTime #-} + +-- | Convert a 'UTCTime' into a 'Builder'. +showbUTCTime :: UTCTime -> Builder +showbUTCTime = build +{-# INLINE showbUTCTime #-} + +-- | Convert a 'NominalDiffTime' into a 'Builder'. +showbNominalDiffTime :: NominalDiffTime -> Builder +showbNominalDiffTime = build +{-# 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 +showbTimeZone = build +{-# INLINE showbTimeZone #-} + +-- | Convert a 'TimeOfDay' into a 'Builder'. +showbTimeOfDay :: TimeOfDay -> Builder +showbTimeOfDay = build +{-# INLINE showbTimeOfDay #-} + +-- | Convert a 'LocalTime' into a 'Builder'. +showbLocalTime :: LocalTime -> Builder +showbLocalTime = build +{-# INLINE showbLocalTime #-} + +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 #-} diff --git a/src/Text/Show/Text/Data/Tuple.hs b/src/Text/Show/Text/Data/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Tuple.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbUnit + , showb2Tuple + , showb3Tuple + , showb4Tuple + , showb5Tuple + , showb6Tuple + , showb7Tuple + , showb8Tuple + , showb9Tuple + , showb10Tuple + , showb11Tuple + , showb12Tuple + , showb13Tuple + , showb14Tuple + , showb15Tuple + ) where + +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) +import Text.Show.Text.Utils ((<>), s) + +-- | Converts @()@ into a 'Builder'. +showbUnit :: () -> Builder +showbUnit () = "()" +{-# INLINE showbUnit #-} + +-- | Converts a 2-tuple into a 'Builder'. +showb2Tuple :: (Show a, Show b) => (a, b) -> Builder +showb2Tuple (a, b) = + s '(' <> showb a <> + s ',' <> showb b <> + s ')' +{-# INLINE showb2Tuple #-} + +-- | Converts a 3-tuple into a 'Builder'. +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 ')' +{-# INLINE showb3Tuple #-} + +-- | Converts a 4-tuple into a 'Builder'. +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 ')' +{-# INLINE showb4Tuple #-} + +-- | Converts a 5-tuple into a 'Builder'. +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 ')' +{-# INLINE showb5Tuple #-} + +-- | Converts a 6-tuple into a 'Builder'. +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 ')' +{-# INLINE showb6Tuple #-} + +-- | Converts a 7-tuple into a 'Builder'. +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 ')' +{-# INLINE showb7Tuple #-} + +-- | Converts an 8-tuple into a 'Builder'. +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 ')' +{-# INLINE showb8Tuple #-} + +-- | Converts a 9-tuple into a 'Builder'. +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 ')' +{-# INLINE showb9Tuple #-} + +-- | Converts a 10-tuple into a 'Builder'. +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 ')' +{-# INLINE showb10Tuple #-} + +-- | Converts an 11-tuple into a 'Builder'. +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 ')' +{-# INLINE showb11Tuple #-} + +-- | Converts a 12-tuple into a 'Builder'. +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 ')' +{-# INLINE showb12Tuple #-} + +-- | Converts a 13-tuple into a 'Builder'. +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 ')' +{-# INLINE showb13Tuple #-} + +-- | Converts a 14-tuple into a 'Builder'. +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 ')' +{-# INLINE showb14Tuple #-} + +-- | Converts a 15-tuple into a 'Builder'. +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 ')' +{-# INLINE showb15Tuple #-} + +instance Show () where + showb = showbUnit + {-# INLINE showb #-} + +instance (Show a, Show b) => Show (a, b) where + showb = showb2Tuple + {-# INLINE showb #-} + +instance (Show a, Show b, Show c) => Show (a, b, c) where + showb = showb3Tuple + {-# INLINE showb #-} + +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, Show d, Show e) => Show (a, b, c, d, e) where + showb = showb5Tuple + {-# INLINE showb #-} + +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, 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, Show g, Show h) => + Show (a, b, c, d, e, f, g, h) where + showb = showb8Tuple + {-# INLINE showb #-} + +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 #-} + +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 #-} + +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, 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, 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, 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 #-} diff --git a/src/Text/Show/Text/Data/Type/Coercion.hs b/src/Text/Show/Text/Data/Type/Coercion.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Type/Coercion.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs, NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbCoercion) where + +import Data.Text.Lazy.Builder (Builder) +import Data.Type.Coercion (Coercion(..)) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) + +-- | Convert a representational equality value to a 'Builder'. +showbCoercion :: Coercion a b -> Builder +showbCoercion Coercion = "Coercion" +{-# INLINE showbCoercion #-} + +instance Show (Coercion a b) where + showb = showbCoercion + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Type/Equality.hs b/src/Text/Show/Text/Data/Type/Equality.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Type/Equality.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs, NoImplicitPrelude, OverloadedStrings, 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 (showbPropEquality) where + +import Data.Text.Lazy.Builder (Builder) +import Data.Type.Equality ((:~:)(..)) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb)) + +-- | Convert a propositional equality value to a 'Builder'. +showbPropEquality :: (a :~: b) -> Builder +showbPropEquality Refl = "Refl" +{-# INLINE showbPropEquality #-} + +instance Show (a :~: b) where + showb = showbPropEquality + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Data/Typeable.hs b/src/Text/Show/Text/Data/Typeable.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Typeable.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, 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 +#if MIN_VERSION_base(4,7,0) + , showbProxy +#endif + ) where + +import Data.Monoid (mempty) +#if MIN_VERSION_base(4,7,0) +import Data.Proxy (Proxy(..)) +#endif +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.Data.List () +import Text.Show.Text.Utils ((<>), lengthB, replicateB, s) + +-- | Convert a 'TypeRep' to a 'Builder' with the given precedence. +showbTypeRepPrec :: Int -> TypeRep -> Builder +showbTypeRepPrec p tyrep = + 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 + <> s ' ' + <> showbArgs (s ' ') tys + where + tycon = typeRepTyCon tyrep + tys = typeRepArgs tyrep +{-# INLINE showbTypeRepPrec #-} + +#if !(MIN_VERSION_base(4,4,0)) +-- | The list 'TyCon'. +listTc :: TyCon +listTc = typeRepTyCon $ typeOf [()] +{-# INLINE listTc #-} + +-- | The function (@->@) 'TyCon'. +funTc :: TyCon +funTc = mkTyCon "->" +#endif + +-- | Does the 'TyCon' represent a tuple type constructor? +isTupleTyCon :: TyCon -> Bool +isTupleTyCon tycon = case tyconStr of + ('(':',':_) -> True + _ -> False + where + 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'. +showbTyCon :: TyCon -> Builder +showbTyCon = fromString . tyConString +{-# INLINE showbTyCon #-} + +#if MIN_VERSION_base(4,7,0) +-- | Convert a 'Proxy' type to a 'Builder'. +showbProxy :: Proxy s -> Builder +showbProxy _ = "Proxy" +{-# INLINE showbProxy #-} +#endif + +#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'. +tyConString :: TyCon -> String +tyConString = tyConName +{-# INLINE tyConString #-} +#endif + +instance Show TypeRep where + showbPrec = showbTypeRepPrec + {-# INLINE 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 + +#if MIN_VERSION_base(4,7,0) +instance Show (Proxy s) where + showb = showbProxy + {-# INLINE showb #-} +#endif diff --git a/src/Text/Show/Text/Data/Version.hs b/src/Text/Show/Text/Data/Version.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Version.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbVersionPrec + , showbVersionConcrete + ) where + +import Data.List (intersperse) +import Data.Monoid (mconcat) +import Data.Text.Lazy.Builder (Builder, fromString) +import Data.Version (Version(..)) + +import GHC.Show (appPrec) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Data.Char () +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.List () +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'Version' to a 'Builder' with the given precedence. +showbVersionPrec :: Int -> Version -> Builder +showbVersionPrec p (Version b t) = showbParen (p > appPrec) $ + "Version {versionBranch = " + <> showb b + <> ", versionTags = " + <> showb t + <> s '}' +{-# INLINE showbVersionPrec #-} + +-- | 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@. +showbVersionConcrete :: Version -> Builder +showbVersionConcrete (Version branch tags) + = mconcat (intersperse (s '.') $ map showb branch) <> + mconcat (map ((s '-' <>) . fromString) tags) +{-# INLINE showbVersionConcrete #-} + +instance Show Version where + showbPrec = showbVersionPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Foreign.hs b/src/Text/Show/Text/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Foreign.hs @@ -0,0 +1,15 @@ +----------------------------------------------------------------------------- +-- | +-- 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 () where + +import Text.Show.Text.Foreign.C.Types () +import Text.Show.Text.Foreign.Ptr () diff --git a/src/Text/Show/Text/Foreign/C/Types.hs b/src/Text/Show/Text/Foreign/C/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Foreign/C/Types.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, NoImplicitPrelude, StandaloneDeriving #-} +{-# 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 ( + showbCCharPrec + , showbCSCharPrec + , showbCUChar + , showbCShortPrec + , showbCUShort + , showbCIntPrec + , showbCUInt + , showbCLongPrec + , showbCULong + , showbCPtrdiffPrec + , showbCSize + , showbCWcharPrec + , showbCSigAtomicPrec + , showbCLLongPrec + , showbCULLong + , showbCIntPtrPrec + , showbCUIntPtr + , showbCIntMaxPrec + , showbCUIntMax + , showbCClockPrec + , showbCTimePrec + , showbCUSeconds + , showbCSUSecondsPrec + , showbCFloatPrec + , showbCDoublePrec + ) where + +import Data.Text.Lazy.Builder (Builder) + +import Foreign.C.Types + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec)) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.Floating () + +-- | Convert a 'CChar' to a 'Builder' with the given precedence. +showbCCharPrec :: Int -> CChar -> Builder +showbCCharPrec = showbPrec +{-# INLINE showbCCharPrec #-} + +-- | Convert a 'CSChar' to a 'Builder' with the given precedence. +showbCSCharPrec :: Int -> CSChar -> Builder +showbCSCharPrec = showbPrec +{-# INLINE showbCSCharPrec #-} + +-- | Convert a 'CUChar' to a 'Builder'. +showbCUChar :: CUChar -> Builder +showbCUChar = showb +{-# INLINE showbCUChar #-} + +-- | Convert a 'CShort' to a 'Builder' with the given precedence. +showbCShortPrec :: Int -> CShort -> Builder +showbCShortPrec = showbPrec +{-# INLINE showbCShortPrec #-} + +-- | Convert a 'CUShort' to a 'Builder'. +showbCUShort :: CUShort -> Builder +showbCUShort = showb +{-# INLINE showbCUShort #-} + +-- | Convert a 'CInt' to a 'Builder' with the given precedence. +showbCIntPrec :: Int -> CInt -> Builder +showbCIntPrec = showbPrec +{-# INLINE showbCIntPrec #-} + +-- | Convert a 'CUInt' to a 'Builder'. +showbCUInt :: CUInt -> Builder +showbCUInt = showb +{-# INLINE showbCUInt #-} + +-- | Convert a 'CLong' to a 'Builder' with the given precedence. +showbCLongPrec :: Int -> CLong -> Builder +showbCLongPrec = showbPrec +{-# INLINE showbCLongPrec #-} + +-- | Convert a 'CULong' to a 'Builder'. +showbCULong :: CULong -> Builder +showbCULong = showb +{-# INLINE showbCULong #-} + +-- | Convert a 'CPtrdiff' to a 'Builder' with the given precedence. +showbCPtrdiffPrec :: Int -> CPtrdiff -> Builder +showbCPtrdiffPrec = showbPrec +{-# INLINE showbCPtrdiffPrec #-} + +-- | Convert a 'CSize' to a 'Builder'. +showbCSize :: CSize -> Builder +showbCSize = showb +{-# INLINE showbCSize #-} + +-- | Convert a 'CWchar' to a 'Builder' with the given precedence. +showbCWcharPrec :: Int -> CWchar -> Builder +showbCWcharPrec = showbPrec +{-# INLINE showbCWcharPrec #-} + +-- | Convert a 'CSigAtomic' to a 'Builder' with the given precedence. +showbCSigAtomicPrec :: Int -> CSigAtomic -> Builder +showbCSigAtomicPrec = showbPrec +{-# INLINE showbCSigAtomicPrec #-} + +-- | Convert a 'CLLong' to a 'Builder' with the given precedence. +showbCLLongPrec :: Int -> CLLong -> Builder +showbCLLongPrec = showbPrec +{-# INLINE showbCLLongPrec #-} + +-- | Convert a 'CULLong' to a 'Builder'. +showbCULLong :: CULLong -> Builder +showbCULLong = showb +{-# INLINE showbCULLong #-} + +-- | Convert a 'CIntPtr' to a 'Builder' with the given precedence. +showbCIntPtrPrec :: Int -> CIntPtr -> Builder +showbCIntPtrPrec = showbPrec +{-# INLINE showbCIntPtrPrec #-} + +-- | Convert a 'CUIntPtr' to a 'Builder'. +showbCUIntPtr :: CUIntPtr -> Builder +showbCUIntPtr = showb +{-# INLINE showbCUIntPtr #-} + +-- | Convert a 'CIntMax' to a 'Builder' with the given precedence. +showbCIntMaxPrec :: Int -> CIntMax -> Builder +showbCIntMaxPrec = showbPrec +{-# INLINE showbCIntMaxPrec #-} + +-- | Convert a 'CUIntMax' to a 'Builder'. +showbCUIntMax :: CUIntMax -> Builder +showbCUIntMax = showb +{-# INLINE showbCUIntMax #-} + +-- | Convert a 'CClock' to a 'Builder' with the given precedence. +showbCClockPrec :: Int -> CClock -> Builder +showbCClockPrec = showbPrec +{-# INLINE showbCClockPrec #-} + +-- | Convert a 'CTime' to a 'Builder' with the given precedence. +showbCTimePrec :: Int -> CTime -> Builder +showbCTimePrec = showbPrec +{-# INLINE showbCTimePrec #-} + +-- | Convert a 'CUSeconds' value to a 'Builder'. +showbCUSeconds :: CUSeconds -> Builder +showbCUSeconds = showb +{-# INLINE showbCUSeconds #-} + +-- | Convert a 'CSUSeconds' value to a 'Builder' with the given precedence. +showbCSUSecondsPrec :: Int -> CSUSeconds -> Builder +showbCSUSecondsPrec = showbPrec +{-# INLINE showbCSUSecondsPrec #-} + +-- | Convert a 'CFloat' to a 'Builder' with the given precedence. +showbCFloatPrec :: Int -> CFloat -> Builder +showbCFloatPrec = showbPrec +{-# INLINE showbCFloatPrec #-} + +-- | Convert a 'CDouble' to a 'Builder' with the given precedence. +showbCDoublePrec :: Int -> CDouble -> Builder +showbCDoublePrec = showbPrec +{-# INLINE showbCDoublePrec #-} + +deriving instance Show CChar +deriving instance Show CSChar +deriving instance Show CUChar +deriving instance Show CShort +deriving instance Show CUShort +deriving instance Show CInt +deriving instance Show CUInt +deriving instance Show CLong +deriving instance Show CULong +deriving instance Show CPtrdiff +deriving instance Show CSize +deriving instance Show CWchar +deriving instance Show CSigAtomic +deriving instance Show CLLong +deriving instance Show CULLong +deriving instance Show CIntPtr +deriving instance Show CUIntPtr +deriving instance Show CIntMax +deriving instance Show CUIntMax +deriving instance Show CClock +deriving instance Show CTime +deriving instance Show CUSeconds +deriving instance Show CSUSeconds +deriving instance Show CFloat +deriving instance Show CDouble diff --git a/src/Text/Show/Text/Foreign/Ptr.hs b/src/Text/Show/Text/Foreign/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Foreign/Ptr.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} +{-# 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 ( + showbPtr + , showbFunPtr + , showbIntPtrPrec + , showbWordPtr + , showbForeignPtr + ) where + +import Data.Text.Lazy.Builder (Builder) + +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Ptr (FunPtr, IntPtr, WordPtr, castFunPtrToPtr) + +import GHC.Num (wordToInteger) +import GHC.Ptr (Ptr(..)) +import GHC.Prim (addr2Int#, int2Word#, unsafeCoerce#) + +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) + +#include "MachDeps.h" + +-- | Convert a 'Ptr' to a 'Builder'. Note that this does not require the parameterized +-- type to be an instance of 'Show' itself. +showbPtr :: Ptr a -> Builder +showbPtr (Ptr a) = padOut . showbHex $ wordToInteger (int2Word# (addr2Int# a)) + where + padOut :: Builder -> Builder + padOut ls = s '0' <> s 'x' + <> replicateB (2*SIZEOF_HSPTR - lengthB ls) (s '0') + <> ls + +-- | Convert a 'FunPtr' to a 'Builder'. Note that this does not require the +-- parameterized type to be an instance of 'Show' itself. +showbFunPtr :: FunPtr a -> Builder +showbFunPtr = showb . castFunPtrToPtr +{-# INLINE showbFunPtr #-} + +-- | Convert an 'IntPtr' to a 'Builder' with the given precedence. +showbIntPtrPrec :: Int -> IntPtr -> Builder +showbIntPtrPrec k ip = showbIntPrec k $ unsafeCoerce# ip + +-- | Convert a 'WordPtr' to a 'Builder'. +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. +showbForeignPtr :: ForeignPtr a -> Builder +showbForeignPtr = showb . unsafeForeignPtrToPtr +{-# INLINE showbForeignPtr #-} + +instance Show (Ptr a) where + showb = showbPtr + {-# INLINE showb #-} + +instance Show (FunPtr a) where + showb = showbFunPtr + {-# INLINE showb #-} + +instance Show IntPtr where + showbPrec = showbIntPtrPrec + {-# INLINE showbPrec #-} + +instance Show WordPtr where + showb = showbWordPtr + {-# INLINE showb #-} + +instance Show (ForeignPtr a) where + showb = showbForeignPtr + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/Functions.hs b/src/Text/Show/Text/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Functions.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude, 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 (showbFunction) where + +import Data.Text.Lazy.Builder (Builder) +import Prelude hiding (Show) +import Text.Show.Text.Class (Show(showb)) + +-- | Convert a function to a 'Builder'. +showbFunction :: (a -> b) -> Builder +showbFunction = const "" +{-# INLINE showbFunction #-} + +instance Show (a -> b) where + showb = showbFunction + {-# INLINE showb #-} diff --git a/src/Text/Show/Text/GHC.hs b/src/Text/Show/Text/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC.hs @@ -0,0 +1,21 @@ +{-# 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 () where + +#if MIN_VERSION_base(4,4,0) +import Text.Show.Text.GHC.Event () +import Text.Show.Text.GHC.Generics () +#endif +#if MIN_VERSION_base(4,5,0) +import Text.Show.Text.GHC.Stats () +#endif diff --git a/src/Text/Show/Text/GHC/Event.hs b/src/Text/Show/Text/GHC/Event.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/Event.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# 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 + +import Data.Text.Lazy.Builder (Builder, fromString) + +import GHC.Event (Event, FdKey) + +import qualified Prelude as P +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec)) + +-- | Convert an 'Event' to a 'Builder'. +showbEvent :: Event -> Builder +showbEvent = fromString . P.show +{-# INLINE showbEvent #-} + +-- | Convert an 'FdKey' to a 'Builder' with the given precedence. +showbFdKeyPrec :: Int -> FdKey -> Builder +showbFdKeyPrec p fdKey = fromString $ P.showsPrec p fdKey "" +{-# INLINE showbFdKeyPrec #-} + +instance Show Event where + showb = showbEvent + {-# INLINE showb #-} + +instance Show FdKey where + showbPrec = showbFdKeyPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/GHC/Generics.hs b/src/Text/Show/Text/GHC/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/Generics.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, OverloadedStrings, 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 ( + showbU1 + , showbPar1Prec + , showbRec1Prec + , showbK1Prec + , showbM1Prec + , showbSumTypePrec + , showbProductTypePrec + , showbCompFunctorsPrec + , showbFixityPrec + , showbAssociativity + , showbArityPrec + ) where + +import Data.Text.Lazy.Builder (Builder) + +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.Data.Integral (showbIntPrec) +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'U1' value to a 'Builder'. +showbU1 :: U1 p -> Builder +showbU1 U1 = "U1" +{-# INLINE showbU1 #-} + +-- | Convert a 'Par1' value to a 'Builder' with the given precedence. +showbPar1Prec :: Show p => Int -> Par1 p -> Builder +showbPar1Prec p (Par1 up) = showbParen (p > appPrec) $ + "Par1 {unPar1 = " <> showb up <> s '}' +{-# INLINE showbPar1Prec #-} + +-- | Convert a 'Rec1' value to a 'Builder' with the given precedence. +showbRec1Prec :: Show (f p) => Int -> Rec1 f p -> Builder +showbRec1Prec p (Rec1 ur) = showbParen (p > appPrec) $ + "Rec1 {unRec1 = " <> showb ur <> s '}' +{-# INLINE showbRec1Prec #-} + +-- | Convert a 'K1' value to a 'Builder' with the given precedence. +showbK1Prec :: Show c => Int -> K1 i c p -> Builder +showbK1Prec p (K1 uk) = showbParen (p > appPrec) $ + "K1 {unK1 = " <> showb uk <> s '}' +{-# INLINE showbK1Prec #-} + +-- | Convert an 'M1' value to a 'Builder' with the given precedence. +showbM1Prec :: Show (f p) => Int -> M1 i c f p -> Builder +showbM1Prec p (M1 um) = showbParen (p > appPrec) $ + "M1 {unM1 = " <> showb um <> s '}' +{-# INLINE showbM1Prec #-} + +-- | Convert a '(:+:)' value to a 'Builder' with the given precedence. +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 +{-# INLINE showbSumTypePrec #-} + +-- | Convert an '(:*:)' value to a 'Builder' with the given precedence. +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 +{-# INLINE showbProductTypePrec #-} + +-- | Convert an '(:.:)' value to a 'Builder' with the given precedence. +showbCompFunctorsPrec :: Show (f (g p)) => Int -> (f :.: g) p -> Builder +showbCompFunctorsPrec p (Comp1 uc) = showbParen (p > appPrec) $ + "Comp1 {unComp1 = " <> showb uc <> s '}' +{-# INLINE showbCompFunctorsPrec #-} + +-- | Convert a 'Fixity' value to a 'Builder' with the given precedence. +showbFixityPrec :: Int -> Fixity -> Builder +showbFixityPrec _ Prefix = "Prefix" +showbFixityPrec p (Infix a i) = showbParen (p > appPrec) $ + "Infix " <> showbAssociativity a <> s ' ' <> showbIntPrec appPrec1 i +{-# INLINE showbFixityPrec #-} + +-- | Convert an 'Associativity' value to a 'Builder'. +showbAssociativity :: Associativity -> Builder +showbAssociativity LeftAssociative = "LeftAssociative" +showbAssociativity RightAssociative = "RightAssociative" +showbAssociativity NotAssociative = "NotAssociative" +{-# INLINE showbAssociativity #-} + +-- | Convert an 'Arity' value to a 'Builder' with the given precedence. +showbArityPrec :: Int -> Arity -> Builder +showbArityPrec _ NoArity = "NoArity" +showbArityPrec p (Arity i) = showbParen (p > appPrec) $ + "Arity " <> showbIntPrec appPrec1 i +{-# INLINE showbArityPrec #-} + +instance Show (U1 p) where + showb = showbU1 + {-# INLINE showb #-} + +instance Show p => Show (Par1 p) where + showbPrec = showbPar1Prec + {-# INLINE showbPrec #-} + +instance Show (f p) => Show (Rec1 f p) where + showbPrec = showbRec1Prec + {-# INLINE showbPrec #-} + +instance Show c => Show (K1 i c p) where + showbPrec = showbK1Prec + {-# INLINE showbPrec #-} + +instance Show (f p) => Show (M1 i c f p) where + showbPrec = showbM1Prec + {-# INLINE showbPrec #-} + +instance (Show (f p), Show (g p)) => Show ((f :+: g) p) where + showbPrec = showbSumTypePrec + {-# INLINE showbPrec #-} + +instance (Show (f p), Show (g p)) => Show ((f :*: g) p) where + showbPrec = showbProductTypePrec + {-# INLINE showbPrec #-} + +instance Show (f (g p)) => Show ((f :.: g) p) where + showbPrec = showbCompFunctorsPrec + {-# INLINE showbPrec #-} + +instance Show Fixity where + showbPrec = showbFixityPrec + {-# INLINE showbPrec #-} + +instance Show Associativity where + showb = showbAssociativity + {-# INLINE showb #-} + +instance Show Arity where + showbPrec = showbArityPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/GHC/Stats.hs b/src/Text/Show/Text/GHC/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/GHC/Stats.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbGCStatsPrec) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec) +import GHC.Stats (GCStats(..)) + +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Data.Integral (showbInt64Prec) +import Text.Show.Text.Data.Floating (showbDoublePrec) +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'GCStats' value to a 'Builder' with the given precedence. +showbGCStatsPrec :: Int -> GCStats -> Builder +showbGCStatsPrec p gcStats = showbParen (p > appPrec) $ + "GCStats {bytesAllocated = " + <> showbInt64Prec 0 (bytesAllocated gcStats) + <> ", numGcs = " + <> showbInt64Prec 0 (numGcs gcStats) + <> ", maxBytesUsed = " + <> showbInt64Prec 0 (maxBytesUsed gcStats) + <> ", numByteUsageSamples = " + <> showbInt64Prec 0 (numByteUsageSamples gcStats) + <> ", cumulativeBytesUsed = " + <> showbInt64Prec 0 (cumulativeBytesUsed gcStats) + <> ", bytesCopied = " + <> showbInt64Prec 0 (bytesCopied gcStats) + <> ", currentBytesUsed = " + <> showbInt64Prec 0 (currentBytesUsed gcStats) + <> ", currentBytesSlop = " + <> showbInt64Prec 0 (currentBytesSlop gcStats) + <> ", maxBytesSlop = " + <> showbInt64Prec 0 (maxBytesSlop gcStats) + <> ", peakMegabytesAllocated = " + <> showbInt64Prec 0 (peakMegabytesAllocated gcStats) + <> ", mutatorCpuSeconds = " + <> showbDoublePrec 0 (mutatorCpuSeconds gcStats) + <> ", mutatorWallSeconds = " + <> showbDoublePrec 0 (mutatorWallSeconds gcStats) + <> ", gcCpuSeconds = " + <> showbDoublePrec 0 (gcCpuSeconds gcStats) + <> ", gcWallSeconds = " + <> showbDoublePrec 0 (gcWallSeconds gcStats) + <> ", cpuSeconds = " + <> showbDoublePrec 0 (cpuSeconds gcStats) + <> ", wallSeconds = " + <> showbDoublePrec 0 (wallSeconds gcStats) +#if MIN_VERSION_base(4,6,0) + <> ", parTotBytesCopied = " + <> showbInt64Prec 0 (parTotBytesCopied gcStats) +#else + <> ", parAvgBytesCopied = " + <> showbInt64Prec 0 (parAvgBytesCopied gcStats) +#endif + <> ", parMaxBytesCopied = " + <> showbInt64Prec 0 (parMaxBytesCopied gcStats) + <> s '}' +{-# INLINE showbGCStatsPrec #-} + +instance Show GCStats where + showbPrec = showbGCStatsPrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/Instances.hs b/src/Text/Show/Text/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Instances.hs @@ -0,0 +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 () 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.System () +import Text.Show.Text.Text () diff --git a/src/Text/Show/Text/System.hs b/src/Text/Show/Text/System.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System.hs @@ -0,0 +1,16 @@ +----------------------------------------------------------------------------- +-- | +-- 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 () where + +import Text.Show.Text.System.Exit () +import Text.Show.Text.System.IO () +import Text.Show.Text.System.Posix.Types () diff --git a/src/Text/Show/Text/System/Exit.hs b/src/Text/Show/Text/System/Exit.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Exit.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# 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 (showbExitCodePrec) where + +import Data.Text.Lazy.Builder (Builder) + +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import System.Exit (ExitCode(..)) + +import Text.Show.Text.Class (Show(showbPrec), showbParen) +import Text.Show.Text.Data.Integral (showbIntPrec) +import Text.Show.Text.Utils ((<>)) + +-- | Convert an 'ExitCode' to a 'Builder' with the given precedence. +showbExitCodePrec :: Int -> ExitCode -> Builder +showbExitCodePrec _ ExitSuccess = "ExitSuccess" +showbExitCodePrec p (ExitFailure c) = showbParen (p > appPrec) $ + "ExitFailure " <> showbIntPrec appPrec1 c +{-# INLINE showbExitCodePrec #-} + +instance Show ExitCode where + showbPrec = showbExitCodePrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/System/IO.hs b/src/Text/Show/Text/System/IO.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/IO.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings #-} +{-# 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 ( + showbHandle + , showbIOMode + , showbBufferModePrec + , showbHandlePosn + , showbSeekMode +#if MIN_VERSION_base(4,3,0) + , showbTextEncoding +#endif +#if MIN_VERSION_base(4,4,0) + , showbCodingProgress + , showbCodingFailureMode +#endif + , showbNewline + , showbNewlineModePrec + ) where + +import Data.Text.Lazy.Builder (Builder, fromString) + +#if MIN_VERSION_base(4,3,0) +import GHC.IO.Encoding.Types (TextEncoding(..)) +#endif +#if MIN_VERSION_base(4,4,0) +import GHC.IO.Encoding.Failure (CodingFailureMode(..)) +import GHC.IO.Encoding.Types (CodingProgress(..)) +#endif +import GHC.IO.Handle (HandlePosn(..)) +import GHC.IO.Handle.Types (Handle(..)) +import GHC.Show (appPrec, appPrec1) + +import Prelude hiding (Show) + +import System.IO (BufferMode(..), IOMode(..), Newline(..), + NewlineMode(..), SeekMode(..)) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Data.Integral (showbIntegerPrec) +import Text.Show.Text.Data.Maybe (showbMaybePrec) +import Text.Show.Text.Utils ((<>), s) + +-- | Convert a 'Handle' to a 'Builder'. +showbHandle :: Handle -> Builder +showbHandle (FileHandle file _) = showbHandleFilePath file +showbHandle (DuplexHandle file _ _) = showbHandleFilePath file +{-# INLINE showbHandle #-} + +-- | Convert a 'Handle`'s 'FilePath' to a 'Builder'. +showbHandleFilePath :: FilePath -> Builder +showbHandleFilePath file = "{handle: " <> fromString file <> s '}' +{-# INLINE showbHandleFilePath #-} + +-- | Convert an 'IOMode' to a 'Builder'. +showbIOMode :: IOMode -> Builder +showbIOMode ReadMode = "ReadMode" +showbIOMode WriteMode = "WriteMode" +showbIOMode AppendMode = "AppendMode" +showbIOMode ReadWriteMode = "ReadWriteMode" +{-# INLINE showbIOMode #-} + +-- | Convert a 'BufferMode' to a 'Builder' with the given precedence. +showbBufferModePrec :: Int -> BufferMode -> Builder +showbBufferModePrec _ NoBuffering = "NoBuffering" +showbBufferModePrec _ LineBuffering = "LineBuffering" +showbBufferModePrec p (BlockBuffering size) + = showbParen (p > appPrec) $ "BlockBuffering " <> showbMaybePrec appPrec1 size +{-# INLINE showbBufferModePrec #-} + +-- | Convert a 'HandlePosn' to a 'Builder'. +showbHandlePosn :: HandlePosn -> Builder +showbHandlePosn (HandlePosn h pos) + = showbHandle h <> " at position " <> showbIntegerPrec 0 pos +{-# INLINE showbHandlePosn #-} + +-- | Convert a 'SeekMode' to a 'Builder'. +showbSeekMode :: SeekMode -> Builder +showbSeekMode AbsoluteSeek = "AbsoluteSeek" +showbSeekMode RelativeSeek = "RelativeSeek" +showbSeekMode SeekFromEnd = "SeekFromEnd" +{-# INLINE showbSeekMode #-} + +#if MIN_VERSION_base(4,3,0) +-- | Convert a 'TextEncoding' to a 'Builder'. +showbTextEncoding :: TextEncoding -> Builder +showbTextEncoding = fromString . textEncodingName +{-# INLINE showbTextEncoding #-} +#endif + +#if MIN_VERSION_base(4,4,0) +-- | Convert a 'CodingProgress' to a 'Builder'. +showbCodingProgress :: CodingProgress -> Builder +showbCodingProgress InputUnderflow = "InputUnderflow" +showbCodingProgress OutputUnderflow = "OutputUnderflow" +showbCodingProgress InvalidSequence = "InvalidSequence" +{-# INLINE showbCodingProgress #-} + +-- | Convert a 'CodingFailureMode' value to a 'Builder'. +showbCodingFailureMode :: CodingFailureMode -> Builder +showbCodingFailureMode ErrorOnCodingFailure = "ErrorOnCodingFailure" +showbCodingFailureMode IgnoreCodingFailure = "IgnoreCodingFailure" +showbCodingFailureMode TransliterateCodingFailure = "TransliterateCodingFailure" +showbCodingFailureMode RoundtripFailure = "RoundtripFailure" +{-# INLINE showbCodingFailureMode #-} +#endif + +-- | Convert a 'Newline' to a 'Builder'. +showbNewline :: Newline -> Builder +showbNewline LF = "LF" +showbNewline CRLF = "CRLF" +{-# INLINE showbNewline #-} + +-- | Convert a 'NewlineMode' to a 'Builder' with the given precedence. +showbNewlineModePrec :: Int -> NewlineMode -> Builder +showbNewlineModePrec p (NewlineMode inl onl) = showbParen (p > appPrec) $ + "NewlineMode {inputNL = " + <> showbNewline inl + <> ", outputNL = " + <> showbNewline onl + <> s '}' +{-# INLINE showbNewlineModePrec #-} + +instance Show Handle where + showb = showbHandle + {-# INLINE showb #-} + +instance Show IOMode where + showb = showbIOMode + {-# INLINE showb #-} + +instance Show BufferMode where + showbPrec = showbBufferModePrec + {-# INLINE showbPrec #-} + +instance Show HandlePosn where + showb = showbHandlePosn + {-# INLINE showb #-} + +instance Show SeekMode where + showb = showbSeekMode + {-# INLINE showb #-} + +#if MIN_VERSION_base(4,3,0) +instance Show TextEncoding where + showb = showbTextEncoding + {-# INLINE showb #-} +#endif + +#if MIN_VERSION_base(4,4,0) +instance Show CodingProgress where + showb = showbCodingProgress + {-# INLINE showb #-} + +instance Show CodingFailureMode where + showb = showbCodingFailureMode + {-# INLINE showb #-} +#endif + +instance Show Newline where + showb = showbNewline + {-# INLINE showb #-} + +instance Show NewlineMode where + showbPrec = showbNewlineModePrec + {-# INLINE showbPrec #-} diff --git a/src/Text/Show/Text/System/Posix/Types.hs b/src/Text/Show/Text/System/Posix/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Posix/Types.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, NoImplicitPrelude, StandaloneDeriving #-} +{-# 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 ( + showbCDev + , showbCIno + , showbCMode + , showbCOffPrec + , showbCPidPrec + , showbCSsizePrec + , showbCGid + , showbCNlink + , showbCUid + , showbCCc + , showbCSpeed + , showbCTcflag + , showbCRLim + , showbFdPrec + ) where + +import Data.Text.Lazy.Builder (Builder) + +import Prelude hiding (Show) + +import System.Posix.Types + +import Text.Show.Text.Class (Show(showb, showbPrec)) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Foreign.C.Types () + +-- | Convert a 'CDev' to a 'Builder'. +showbCDev :: CDev -> Builder +showbCDev = showb +{-# INLINE showbCDev #-} + +-- | Convert a 'CIno' to a 'Builder'. +showbCIno :: CIno -> Builder +showbCIno = showb +{-# INLINE showbCIno #-} + +-- | Convert a 'CMode' to a 'Builder'. +showbCMode :: CMode -> Builder +showbCMode = showb +{-# INLINE showbCMode #-} + +-- | Convert a 'COff' to a 'Builder' with the given precedence. +showbCOffPrec :: Int -> COff -> Builder +showbCOffPrec = showbPrec +{-# INLINE showbCOffPrec #-} + +-- | Convert a 'CPid' to a 'Builder' with the given precedence. +showbCPidPrec :: Int -> CPid -> Builder +showbCPidPrec = showbPrec +{-# INLINE showbCPidPrec #-} + +-- | Convert a 'CSsize' to a 'Builder' with the given precedence. +showbCSsizePrec :: Int -> CSsize -> Builder +showbCSsizePrec = showbPrec +{-# INLINE showbCSsizePrec #-} + +-- | Convert a 'CGid' to a 'Builder'. +showbCGid :: CGid -> Builder +showbCGid = showb +{-# INLINE showbCGid #-} + +-- | Convert a 'CNlink' to a 'Builder'. +showbCNlink :: CNlink -> Builder +showbCNlink = showb +{-# INLINE showbCNlink #-} + +-- | Convert a 'CUid' to a 'Builder'. +showbCUid :: CUid -> Builder +showbCUid = showb +{-# INLINE showbCUid #-} + +-- | Convert a 'CCc' to a 'Builder'. +showbCCc :: CCc -> Builder +showbCCc = showb +{-# INLINE showbCCc #-} + +-- | Convert a 'CSpeed' to a 'Builder'. +showbCSpeed :: CSpeed -> Builder +showbCSpeed = showb +{-# INLINE showbCSpeed #-} + +-- | Convert a 'CTcflag' to a 'Builder'. +showbCTcflag :: CTcflag -> Builder +showbCTcflag = showb +{-# INLINE showbCTcflag #-} + +-- | Convert a 'CRLim' to a 'Builder'. +showbCRLim :: CRLim -> Builder +showbCRLim = showb +{-# INLINE showbCRLim #-} + +-- | Convert an 'Fd' to a 'Builder' with the given precedence. +showbFdPrec :: Int -> Fd -> Builder +showbFdPrec = showbPrec +{-# INLINE showbFdPrec #-} + +deriving instance Show CDev +deriving instance Show CIno +deriving instance Show CMode +deriving instance Show COff +deriving instance Show CPid +deriving instance Show CSsize +deriving instance Show CGid +deriving instance Show CNlink +deriving instance Show CUid +deriving instance Show CCc +deriving instance Show CSpeed +deriving instance Show CTcflag +deriving instance Show CRLim +deriving instance Show Fd diff --git a/src/Text/Show/Text/TH.hs b/src/Text/Show/Text/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/TH.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Show.Text.TH +-- Copyright : (C) 2014 Ryan Scott +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Ryan Scott +-- Stability : Experimental +-- Portability : GHC +-- +-- Exports 'deriveShow', which automatically derives a 'Show' instance for a +-- @data@ type or @newtype@. You need to enable the @TemplateHaskell@ +-- language extension in order to use 'deriveShow'. +-- +-- As an example: +-- +-- @ +-- {-# LANGUAGE TemplateHaskell #-} +-- import Text.Show.Text.TH (deriveShow) +-- +-- data D a = Nullary +-- | Unary Int +-- | Product String Char a +-- | Record { testOne :: Double +-- , testTwo :: Bool +-- , testThree :: D a +-- } +-- $(deriveShow ''D) +-- @ +-- +-- @D@ now has a 'Show' instance equivalent to that which 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. +---------------------------------------------------------------------------- +module Text.Show.Text.TH (deriveShow) where + +import Control.Applicative ((<$>)) + +import Data.List (foldl') +import Data.Text.Lazy.Builder (Builder, fromString) + +import GHC.Show (appPrec, appPrec1) + +import Language.Haskell.TH + +import qualified Prelude as P +import Prelude hiding (Show) + +import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) +import Text.Show.Text.Instances () +import Text.Show.Text.Utils ((<>), s) + +-- | 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 + where + fromCons :: [TyVarBndr] -> [Con] -> Q Dec + fromCons tvbs cons = + instanceD (applyCon ''Show typeNames name) + (appT classType instanceType) + [ funD 'showbPrec [ clause [] (normalB $ consToShow cons) [] + ] + ] + where + classType :: Q Type + classType = conT ''Show + + typeNames :: [Name] + typeNames = map tvbName tvbs + + instanceType :: Q Type + instanceType = foldl' appT (conT name) $ map varT typeNames + +-- | Generates code to generate the '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 value) + $ caseE (varE value) [encodeArgs p con | con <- cons] + +-- | Generates code to generate the 'Show' encoding of a single constructor. +encodeArgs :: Name -> Con -> Q Match +encodeArgs _ (NormalC conName []) + = match (conP conName []) + (normalB [| fromString $(stringE (nameBase conName)) |]) + [] +encodeArgs p (NormalC conName ts) = do + args <- mapM newName ["arg" ++ P.show n | (_, n) <- zip ts [1 :: Int ..]] + + let showArgs = map (appE [| showbPrec appPrec1 |] . varE) args + mappendArgs = foldr1 (\v q -> [| $(v) <> s ' ' <> $(q) |]) showArgs + namedArgs = [| fromString $(stringE (nameBase conName)) <> s ' ' <> $(mappendArgs) |] + + match (conP conName $ map varP args) + (normalB $ appE [| 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 ..]] + + 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) |] + + match (conP conName $ map varP args) + (normalB $ appE [| showbParen ($(varE p) > appPrec) |] namedArgs) + [] +encodeArgs p (InfixC _ conName _) = do + al <- newName "argL" + ar <- newName "argR" + info <- reify conName + + let conPrec = case info of + DataConI _ _ _ (Fixity prec _) -> prec + other -> error $ "Text.Show.Text.TH.encodeArgs: Unsupported type: " ++ P.show other + + match (infixP (varP al) conName (varP ar)) + (normalB $ appE [| showbParen ($(varE p) > conPrec) |] + [| showbPrec (conPrec + 1) $(varE al) + <> s ' ' + <> fromString $(stringE (nameBase conName)) + <> s ' ' + <> showbPrec (conPrec + 1) $(varE ar) + |] + ) + [] +encodeArgs p (ForallC _ _ con) = encodeArgs p con + +------------------------------------------------------------------------------- +-- Utility functions +------------------------------------------------------------------------------- + +-- | If constructor is nullary. +isNullary :: Con -> Bool +isNullary (NormalC _ []) = True +isNullary (RecC _ []) = True +isNullary _ = False + +-- | Surrounds a 'Builder' with braces. +showbBraces :: Builder -> Builder +showbBraces b = s '{' <> b <> s '}' + +-- | Boilerplate for top level splices. +-- +-- The given 'Name' must be from a type constructor. Furthermore, the +-- type constructor must be either a data type or a newtype. Any other +-- value will result in an exception. +withType :: Name + -> ([TyVarBndr] -> [Con] -> Q a) + -- ^ Function that generates the actual code. Will be applied + -- to the type variable binders and constructors extracted + -- from the given 'Name'. + -> Q a + -- ^ Resulting value in the 'Q'uasi monad. +withType name f = do + info <- reify name + case info of + TyConI dec -> + case dec of + DataD _ _ tvbs cons _ -> f tvbs cons + NewtypeD _ _ tvbs con _ -> f tvbs [con] + other -> error $ "Text.Show.Text.TH.withType: Unsupported type: " + ++ P.show other + _ -> error "Text.Show.Text.TH.withType: I need the name of a type." + +-- | 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. +applyCon :: Name -> [Name] -> Name -> Q [Pred] +#if MIN_VERSION_template_haskell(2,9,0) +applyCon con typeNames targetData + = map apply . nonPhantomNames typeNames <$> reifyRoles targetData +#else +applyCon con typeNames _ + = return $ map apply typeNames +#endif + where + apply :: Name -> Pred + apply t = ClassP con [VarT t] + +#if MIN_VERSION_template_haskell(2,9,0) + -- Filters a list of tycon names based on their type roles. + -- If a tycon has a phantom type role, remove it from the list. + nonPhantomNames :: [Name] -> [Role] -> [Name] + nonPhantomNames (_:ns) (PhantomR:rs) = nonPhantomNames ns rs + nonPhantomNames (n:ns) (_:rs) = n:(nonPhantomNames ns rs) + nonPhantomNames [] _ = [] + nonPhantomNames _ [] = [] +#endif diff --git a/src/Text/Show/Text/Text.hs b/src/Text/Show/Text/Text.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Text.hs @@ -0,0 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- 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 () 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 new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Text/Read.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, 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 ( + showbLexemePrec +#if MIN_VERSION_base(4,7,0) + , showbNumberPrec +#endif + ) where + +import Data.Text.Lazy.Builder (Builder, fromString) + +import GHC.Show (appPrec, appPrec1) + +import qualified Prelude as P +import Prelude hiding (Show) + +import Text.Read.Lex (Lexeme(..)) +#if MIN_VERSION_base(4,7,0) +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) +#endif +import Text.Show.Text.Utils ((<>)) + +-- | Convert a 'Lexeme' to a 'Builder' with the given precedence. +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 +#if MIN_VERSION_base(4,6,0) +showbLexemePrec p (Number n) = showbParen (p > appPrec) $ "Number " <> fromString (P.showsPrec appPrec1 n "") +#else +showbLexemePrec p (Int i) = showbParen (p > appPrec) $ "Int " <> showbIntegerPrec appPrec1 i +showbLexemePrec p (Rat r) = showbParen (p > appPrec) $ "Rat " <> showbRatioPrec appPrec1 r +#endif +showbLexemePrec _ EOF = "EOF" +{-# INLINE showbLexemePrec #-} + +#if MIN_VERSION_base(4,7,0) +-- | Convert a 'Number' to a 'Builder' with the given precedence. +showbNumberPrec :: Int -> Number -> Builder +showbNumberPrec p n = fromString $ P.showsPrec p n "" +{-# INLINE showbNumberPrec #-} +#endif + +instance Show Lexeme where + showbPrec = showbLexemePrec + {-# INLINE showbPrec #-} + +#if MIN_VERSION_base(4,7,0) +instance Show Number where + showbPrec = showbNumberPrec + {-# INLINE showbPrec #-} +#endif diff --git a/src/Text/Show/Text/Utils.hs b/src/Text/Show/Text/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Utils.hs @@ -0,0 +1,66 @@ +{-# 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. +---------------------------------------------------------------------------- +module Text.Show.Text.Utils where + +import Data.Int (Int64) +import Data.Monoid (Monoid(mappend, mempty)) +import Data.Text.Lazy (length, replicate) +import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText) + +import GHC.Exts (Char(C#), Int(I#)) +import GHC.Prim ((+#), chr#, ord#) + +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 #-} + +-- | Infix 'mappend', defined here for backwards-compatibility with older versions +-- of base. +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} + +-- | +-- 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'. +lengthB :: Builder -> Int64 +lengthB = length . toLazyText +{-# INLINE lengthB #-} + +-- | @'replicateB' n b@ yields a 'Builder' containing @b@ repeated @n@ times. +replicateB :: Int64 -> Builder -> Builder +replicateB n = fromLazyText . replicate n . toLazyText +{-# INLINE replicateB #-} + +-- | Merges several 'Builder's, separating them by newlines. +unlinesB :: [Builder] -> Builder +unlinesB (b:bs) = b <> s '\n' <> unlinesB bs +unlinesB [] = mempty +{-# INLINE unlinesB #-} + +-- | Merges several 'Builder's, separating them by spaces. +unwordsB :: [Builder] -> Builder +unwordsB (b:bs@(_:_)) = b <> s ' ' <> unwordsB bs +unwordsB [b] = b +unwordsB [] = mempty +{-# INLINE unwordsB #-} diff --git a/tests/Instances/BaseAndFriends.hs b/tests/Instances/BaseAndFriends.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/BaseAndFriends.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, StandaloneDeriving #-} +#if MIN_VERSION_base(4,4,0) +{-# LANGUAGE FlexibleContexts, TypeOperators #-} +#endif +#if MIN_VERSION_base(4,7,0) +{-# LANGUAGE TypeFamilies #-} +#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 () where + +import Control.Applicative (ZipList(..), (<$>), (<*>), pure) +import Control.Exception +import Control.Monad.ST (ST, fixST) + +#if MIN_VERSION_bytestring(0,10,4) +import Data.ByteString.Short (ShortByteString, pack) +#endif +import Data.Char (GeneralCategory(..)) +import qualified Data.Data as D (Fixity(..)) +import Data.Data (Constr, ConstrRep(..), DataRep(..), DataType, + mkConstr, mkDataType) +import Data.Dynamic (Dynamic, toDyn) +import Data.Monoid (All(..), Any(..), Dual(..), First(..), + Last(..), Product(..), Sum(..)) +#if MIN_VERSION_base(4,6,0) +import Data.Ord (Down(..)) +#endif +#if MIN_VERSION_base(4,7,0) +import Data.Proxy (Proxy(..)) +#endif +import Data.Text.Lazy.Builder (Builder, fromString) +#if MIN_VERSION_base(4,7,0) +import Data.Coerce (Coercible) +import Data.Type.Coercion (Coercion(..)) +import Data.Type.Equality ((:~:)(..)) +#endif +#if MIN_VERSION_base(4,4,0) +import Data.Typeable.Internal (Typeable, TyCon(..), TypeRep(..), + mkTyConApp, splitTyConApp, typeOf) +import GHC.Fingerprint.Type (Fingerprint(..)) +import Data.Word (Word) + +#if !(MIN_VERSION_base(4,7,0)) +import Data.Word (Word64) +import Numeric (showHex) +#endif +#endif +import Data.Version (Version(..)) + +import Foreign.C.Types +import Foreign.Ptr (FunPtr, IntPtr, Ptr, WordPtr, + castPtrToFunPtr, nullPtr, plusPtr, + ptrToIntPtr, ptrToWordPtr) + +import GHC.Conc (BlockReason(..), ThreadStatus(..)) +#if MIN_VERSION_base(4,4,0) +import GHC.IO.Encoding.Failure (CodingFailureMode(..)) +import GHC.IO.Encoding.Types (CodingProgress(..)) +import qualified GHC.Generics as G (Fixity(..)) +import GHC.Generics (U1(..), Par1(..), Rec1(..), K1(..), + M1(..), (:+:)(..), (:*:)(..), (:.:)(..), + Associativity(..), Arity(..)) +#endif +#if MIN_VERSION_base(4,5,0) +import GHC.Stats (GCStats(..)) +#endif + +import System.Exit (ExitCode(..)) +import System.IO (BufferMode(..), IOMode(..), Newline(..), + NewlineMode(..), SeekMode(..)) +import System.Posix.Types + +import Test.QuickCheck + +instance Arbitrary Builder where + arbitrary = fromString <$> arbitrary + +#if MIN_VERSION_bytestring(0,10,4) +instance Arbitrary ShortByteString where + arbitrary = pack <$> arbitrary +#endif + +instance Arbitrary (Ptr a) where + arbitrary = plusPtr nullPtr <$> arbitrary + +instance Arbitrary (FunPtr a) where + arbitrary = castPtrToFunPtr <$> arbitrary + +instance Arbitrary IntPtr where + arbitrary = ptrToIntPtr <$> arbitrary + +instance Arbitrary WordPtr where + arbitrary = ptrToWordPtr <$> arbitrary + +-- 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 + ] + +instance Arbitrary Version where + arbitrary = Version <$> arbitrary <*> arbitrary + +-- TODO: Be more creative with this instance +instance Arbitrary SomeException where + arbitrary = SomeException <$> (arbitrary :: Gen AssertionFailed) + +-- instance Arbitrary IOException + +instance Arbitrary ArithException where + arbitrary = oneof $ map pure [ Overflow + , Underflow + , LossOfPrecision + , DivideByZero + , Denormal +#if MIN_VERSION_base(4,6,0) + , RatioZeroDenominator +#endif + ] + +instance Arbitrary ArrayException where + arbitrary = oneof [ IndexOutOfBounds <$> arbitrary + , UndefinedElement <$> arbitrary + ] + +instance Arbitrary AssertionFailed where + arbitrary = AssertionFailed <$> arbitrary + +#if MIN_VERSION_base(4,7,0) +-- TODO: Be more creative with this instance +instance Arbitrary SomeAsyncException where + arbitrary = SomeAsyncException <$> (arbitrary :: Gen AsyncException) +#endif + +instance Arbitrary AsyncException where + arbitrary = oneof $ map pure [ StackOverflow + , HeapOverflow + , ThreadKilled + , UserInterrupt + ] + +instance Arbitrary NonTermination where + arbitrary = pure NonTermination + +instance Arbitrary NestedAtomically where + arbitrary = pure NestedAtomically + +instance Arbitrary BlockedIndefinitelyOnMVar where + arbitrary = pure BlockedIndefinitelyOnMVar + +instance Arbitrary BlockedIndefinitelyOnSTM where + arbitrary = pure BlockedIndefinitelyOnSTM + +instance Arbitrary Deadlock where + arbitrary = pure Deadlock + +instance Arbitrary NoMethodError where + arbitrary = NoMethodError <$> arbitrary + +instance Arbitrary PatternMatchFail where + arbitrary = PatternMatchFail <$> arbitrary + +instance Arbitrary RecConError where + arbitrary = RecConError <$> arbitrary + +instance Arbitrary RecSelError where + arbitrary = RecSelError <$> arbitrary + +instance Arbitrary RecUpdError where + arbitrary = RecUpdError <$> arbitrary + +-- ErrorCall is a newtype starting with base-4.7.0.0, but we'll +-- manually derive Arbitrary to support older versions of GHC. +-- +-- deriving instance Arbitrary ErrorCall +instance Arbitrary ErrorCall where + arbitrary = ErrorCall <$> arbitrary + +instance Arbitrary MaskingState where + arbitrary = oneof $ map pure [ Unmasked + , MaskedInterruptible + , MaskedUninterruptible + ] + +-- instance Arbitrary Lexeme +-- #if MIN_VERSION_base(4,7,0) +-- instance Arbitrary Number +-- #endif + +#if MIN_VERSION_base(4,7,0) +instance Arbitrary (Proxy s) where + arbitrary = pure Proxy +#endif + +#if MIN_VERSION_base(4,4,0) +-- Borrowed from the concrete-typerep package +instance Arbitrary TypeRep where + arbitrary = do + nargs <- elements [0,1,2] + mkTyConApp <$> (genTyCon nargs) <*> (vectorOf nargs arbitrary) + +genTyCon :: Int -- ^ Number of arguments; must be in [0,1,2] + -> Gen TyCon +genTyCon 0 = elements [tyConOf (__::Int), tyConOf (__::Word), tyConOf (__::Double), tyConOf (__::Bool)] +genTyCon 1 = elements [tyConOf (__::Maybe Int), tyConOf (__::IO Int), tyConOf (__::[Int])] +genTyCon 2 = elements [tyConOf (__::Either Int Int), tyConOf (__::Int -> Int)] +genTyCon _ = genTyCon 0 + +tyConOf :: Typeable a => a -> TyCon +tyConOf ty = fst $ splitTyConApp (typeOf ty) + +__ :: t +__ = undefined + +instance Arbitrary TyCon where + arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Fingerprint where + arbitrary = Fingerprint <$> arbitrary <*> arbitrary + +#if !(MIN_VERSION_base(4,7,0)) +instance Show Fingerprint where + show (Fingerprint w1 w2) = hex16 w1 ++ hex16 w2 + where + -- | Formats a 64 bit number as 16 digits hex. + hex16 :: Word64 -> String + hex16 i = let hex = showHex i "" + in replicate (16 - length hex) '0' ++ hex +#endif +#endif + +-- TODO: Be more creative with this instance +instance Arbitrary Dynamic where + arbitrary = toDyn <$> (arbitrary :: Gen Int) + +instance Arbitrary Constr where + arbitrary = mkConstr <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ConstrRep where + arbitrary = oneof [ AlgConstr <$> arbitrary + , IntConstr <$> arbitrary + , FloatConstr <$> arbitrary + , CharConstr <$> arbitrary + ] + +instance Arbitrary DataRep where + arbitrary = oneof [ AlgRep <$> arbitrary + , pure IntRep + , pure FloatRep + , pure CharRep + , pure NoRep + ] + +instance Arbitrary DataType where + arbitrary = mkDataType <$> arbitrary <*> arbitrary + +instance Arbitrary D.Fixity where + arbitrary = oneof $ map pure [D.Prefix, D.Infix] + +#if MIN_VERSION_base(4,7,0) +instance Coercible a b => Arbitrary (Coercion a b) where + arbitrary = pure Coercion + +instance a ~ b => Arbitrary (a :~: b) where + arbitrary = pure Refl +#endif + +instance Arbitrary BlockReason where + arbitrary = oneof $ map pure [ BlockedOnMVar + , BlockedOnBlackHole + , BlockedOnException + , BlockedOnSTM + , BlockedOnForeignCall + , BlockedOnOther + ] + +-- instance Arbitrary ThreadId + +instance Arbitrary ThreadStatus where + arbitrary = oneof [ pure ThreadRunning + , pure ThreadFinished + , ThreadBlocked <$> arbitrary + , pure ThreadDied + ] + +instance Arbitrary (ST s a) where + arbitrary = pure $ fixST undefined + +-- instance Arbitrary Handle +-- instance Arbitrary HandlePosn + +instance Arbitrary IOMode where + arbitrary = oneof $ map pure [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Arbitrary BufferMode where + arbitrary = oneof [ pure NoBuffering + , pure LineBuffering + , BlockBuffering <$> arbitrary + ] + +instance Arbitrary SeekMode where + arbitrary = oneof $ map pure [AbsoluteSeek, RelativeSeek, SeekFromEnd] + +instance Arbitrary Newline where + arbitrary = oneof $ map pure [LF, CRLF] + +instance Arbitrary NewlineMode where + arbitrary = NewlineMode <$> arbitrary <*> arbitrary + +#if MIN_VERSION_base(4,3,0) +-- instance Arbitrary TextEncoding +#else +deriving instance Show Newline +deriving instance Show NewlineMode +#endif + +#if MIN_VERSION_base(4,4,0) +instance Arbitrary CodingProgress where + arbitrary = oneof $ map pure [InputUnderflow, OutputUnderflow, InvalidSequence] + +instance Arbitrary CodingFailureMode where + arbitrary = oneof $ map pure [ ErrorOnCodingFailure + , IgnoreCodingFailure + , TransliterateCodingFailure + , RoundtripFailure + ] +#endif + +#if MIN_VERSION_base(4,5,0) +instance Arbitrary GCStats where + arbitrary = GCStats <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary +#endif + +-- #if MIN_VERSION_base(4,4,0) +-- instance Arbitrary Event +-- instance Arbitrary FdKey +-- #endif + +#if MIN_VERSION_base(4,4,0) +instance Arbitrary (U1 p) where + arbitrary = pure U1 + +instance Arbitrary p => Arbitrary (Par1 p) where + arbitrary = Par1 <$> arbitrary + +instance Arbitrary (f p) => Arbitrary (Rec1 f p) where + arbitrary = Rec1 <$> arbitrary + +instance Arbitrary c => Arbitrary (K1 i c p) where + arbitrary = K1 <$> arbitrary + +instance Arbitrary (f p) => Arbitrary (M1 i c f p) where + arbitrary = M1 <$> arbitrary + +instance (Arbitrary (f p), Arbitrary (g p)) => Arbitrary ((f :+: g) p) where + arbitrary = oneof [L1 <$> arbitrary, R1 <$> arbitrary] + +instance (Arbitrary (f p), Arbitrary (g p)) => Arbitrary ((f :*: g) p) where + arbitrary = (:*:) <$> arbitrary <*> arbitrary + +instance Arbitrary (f (g p)) => Arbitrary ((f :.: g) p) where + arbitrary = Comp1 <$> arbitrary + +instance Arbitrary G.Fixity where + arbitrary = oneof [pure G.Prefix, G.Infix <$> arbitrary <*> arbitrary] + +instance Arbitrary Associativity where + arbitrary = oneof $ map pure [LeftAssociative, RightAssociative, NotAssociative] + +instance Arbitrary Arity where + arbitrary = oneof [pure NoArity, Arity <$> arbitrary] + +#if !(MIN_VERSION_base(4,7,0)) +deriving instance Show (U1 p) +deriving instance Show p => Show (Par1 p) +deriving instance Show (f p) => Show (Rec1 f p) +deriving instance Show c => Show (K1 i c p) +deriving instance Show (f p) => Show (M1 i c f p) +deriving instance (Show (f p), Show (g p)) => Show ((f :+: g) p) + +-- Due to a GHC bug (https://ghc.haskell.org/trac/ghc/ticket/9830), this Show +-- instance produces output with the wrong precedence on older versions of GHC. +-- I'll manually define the Show instance to get the correct behavior. +-- +-- deriving instance (Show (f p), Show (g p)) => Show ((f :*: g) p) +instance (Show (f p), Show (g p)) => Show ((f :*: g) p) where + showsPrec p (l :*: r) = showParen (p > prec) $ + showsPrec (prec + 1) l + . showString " :*: " + . showsPrec (prec + 1) r + where prec = 6 + +deriving instance Show (f (g p)) => Show ((f :.: g) p) +#endif +#endif + +deriving instance Arbitrary CChar +deriving instance Arbitrary CSChar +deriving instance Arbitrary CUChar +deriving instance Arbitrary CShort +deriving instance Arbitrary CUShort +deriving instance Arbitrary CInt +deriving instance Arbitrary CUInt +deriving instance Arbitrary CLong +deriving instance Arbitrary CULong +deriving instance Arbitrary CLLong +deriving instance Arbitrary CULLong +deriving instance Arbitrary CFloat +deriving instance Arbitrary CDouble +deriving instance Arbitrary CPtrdiff +deriving instance Arbitrary CSize +deriving instance Arbitrary CWchar +deriving instance Arbitrary CSigAtomic +deriving instance Arbitrary CClock +deriving instance Arbitrary CTime +deriving instance Arbitrary CUSeconds +deriving instance Arbitrary CSUSeconds +deriving instance Arbitrary CIntPtr +deriving instance Arbitrary CUIntPtr +deriving instance Arbitrary CIntMax +deriving instance Arbitrary CUIntMax + +instance Arbitrary ExitCode where + arbitrary = oneof [pure ExitSuccess, ExitFailure <$> arbitrary] + +deriving instance Arbitrary CDev +deriving instance Arbitrary CIno +deriving instance Arbitrary CMode +deriving instance Arbitrary COff +deriving instance Arbitrary CPid +deriving instance Arbitrary CSsize +deriving instance Arbitrary CGid +deriving instance Arbitrary CNlink +deriving instance Arbitrary CUid +deriving instance Arbitrary CCc +deriving instance Arbitrary CSpeed +deriving instance Arbitrary CTcflag +deriving instance Arbitrary CRLim +deriving instance Arbitrary Fd + +deriving instance Arbitrary All +deriving instance Arbitrary Any +deriving instance Arbitrary a => Arbitrary (Dual a) +deriving instance Arbitrary a => Arbitrary (First a) +deriving instance Arbitrary a => Arbitrary (Last a) +deriving instance Arbitrary a => Arbitrary (Product a) +deriving instance Arbitrary a => Arbitrary (Sum a) + +deriving instance Arbitrary a => Arbitrary (ZipList a) +#if !(MIN_VERSION_base(4,7,0)) +deriving instance Show a => Show (ZipList a) +#endif + +#if MIN_VERSION_base(4,6,0) +deriving instance Arbitrary a => Arbitrary (Down a) +#if !(MIN_VERSION_base(4,7,0)) +deriving instance Show a => Show (Down a) +#endif +#endif diff --git a/tests/Instances/Derived.hs b/tests/Instances/Derived.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Derived.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TemplateHaskell, TypeOperators #-} +{-# 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 + +import Control.Applicative ((<$>), (<*>), pure) +import GHC.Show (appPrec, appPrec1) +import Test.QuickCheck +import Text.Show.Text.TH (deriveShow) + +data Nullary = Nullary deriving Show +$(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 ''AllAtOnce) +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (AllAtOnce a b c d) where + arbitrary = oneof [ pure AAONullary + , AAOUnary <$> arbitrary + , AAOProduct <$> arbitrary <*> arbitrary <*> arbitrary + , AAORecord <$> arbitrary <*> arbitrary <*> arbitrary + , (:/\:) <$> arbitrary <*> arbitrary + ] + +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 + +-- 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,61 +1,23 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where - -import Data.Array (Array) -import Data.Complex (Complex) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Map (Map) -import Data.Ratio (Ratio) -import Data.Set (Set) -import qualified Data.Text as T -import qualified Data.Text as TL -import Data.Text.Lazy.Builder (Builder, fromString) -import Data.Word (Word, Word8, Word16, Word32, Word64) - -import qualified Prelude as P -import Prelude hiding (Show(..)) - -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import qualified Text.Show.Text as T +----------------------------------------------------------------------------- +-- | +-- 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 Main (main) where -prop_matchesShow :: (P.Show a, T.Show a, Arbitrary a) => a -> Bool -prop_matchesShow x = P.show x == T.unpack (T.show x) +import Properties.BaseAndFriends (baseAndFriendsTests) +import Properties.Derived (derivedTests) -instance Arbitrary Builder where - arbitrary = fmap fromString arbitrary +import Test.Tasty (TestTree, defaultMain, testGroup) main :: IO () -main = do - quickCheck (prop_matchesShow :: Bool -> Bool) - quickCheck (prop_matchesShow :: Char -> Bool) - quickCheck (prop_matchesShow :: Float -> Bool) - quickCheck (prop_matchesShow :: Double -> Bool) - quickCheck (prop_matchesShow :: Int -> Bool) - quickCheck (prop_matchesShow :: Int8 -> Bool) - quickCheck (prop_matchesShow :: Int16 -> Bool) - quickCheck (prop_matchesShow :: Int32 -> Bool) - quickCheck (prop_matchesShow :: Int64 -> Bool) - quickCheck (prop_matchesShow :: Integer -> Bool) - quickCheck (prop_matchesShow :: Ordering -> Bool) - quickCheck (prop_matchesShow :: Word -> Bool) - quickCheck (prop_matchesShow :: Word8 -> Bool) - quickCheck (prop_matchesShow :: Word16 -> Bool) - quickCheck (prop_matchesShow :: Word32 -> Bool) - quickCheck (prop_matchesShow :: Word64 -> Bool) - quickCheck (prop_matchesShow :: () -> Bool) - quickCheck (prop_matchesShow :: Builder -> Bool) - quickCheck (prop_matchesShow :: String -> Bool) - quickCheck (prop_matchesShow :: T.Text -> Bool) - quickCheck (prop_matchesShow :: TL.Text -> Bool) - quickCheck (prop_matchesShow :: [Int] -> Bool) - quickCheck (prop_matchesShow :: Ratio Int -> Bool) - quickCheck (prop_matchesShow :: Complex Double -> Bool) - quickCheck (prop_matchesShow :: (Int, Double) -> Bool) - quickCheck (prop_matchesShow :: (Int, Double, Char) -> Bool) - quickCheck (prop_matchesShow :: (Int, Double, Char, String) -> Bool) - quickCheck (prop_matchesShow :: (Int, Double, Char, String, T.Text) -> Bool) - quickCheck (prop_matchesShow :: Array Int T.Text -> Bool) - quickCheck (prop_matchesShow :: Map Int T.Text -> Bool) - quickCheck (prop_matchesShow :: Set Int -> Bool) +main = defaultMain testTree + +testTree :: TestTree +testTree = testGroup "QuickCheck properties" $ baseAndFriendsTests ++ derivedTests diff --git a/tests/Properties/BaseAndFriends.hs b/tests/Properties/BaseAndFriends.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/BaseAndFriends.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} +#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 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 + +import Data.Array (Array) +import qualified Data.ByteString as BS (ByteString) +import qualified Data.ByteString.Lazy as BL (ByteString) +#if MIN_VERSION_bytestring(0,10,4) +import Data.ByteString.Short (ShortByteString) +#endif +import Data.Char (GeneralCategory, intToDigit) +import Data.Complex (Complex) +import qualified Data.Data as D (Fixity) +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.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,6,0) +import Data.Ord (Down(..)) +#endif +#if MIN_VERSION_base(4,7,0) +import Data.Proxy (Proxy) +#endif +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) +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, TypeRep) +import GHC.Fingerprint.Type (Fingerprint) +#endif +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Version (Version, showVersion) + +import Foreign.C.Types +import Foreign.Ptr (FunPtr, IntPtr, Ptr, WordPtr) + +import GHC.Conc (BlockReason, ThreadStatus) +import qualified GHC.Generics as G (Fixity) +import GHC.Generics (U1, Par1, Rec1, K1, M1, (:+:), (:*:), (:.:), + Associativity, Arity) +#if MIN_VERSION_base(4,4,0) +import GHC.IO.Encoding.Failure (CodingFailureMode) +import GHC.IO.Encoding.Types (CodingProgress) +#endif +#if MIN_VERSION_base(4,5,0) +import GHC.Stats (GCStats) +#endif + +import Instances.BaseAndFriends () + +import Numeric (showIntAtBase, showEFloat, showFFloat, showGFloat) +#if MIN_VERSION_base(4,7,0) +import Numeric (showFFloatAlt, showGFloatAlt) +#endif + +import Prelude hiding (Show) + +import Properties.Utils (prop_matchesShow) + +import System.Exit (ExitCode) +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 Text.Show.Functions () +import Text.Show.Text hiding (Show) +import Text.Show.Text.Functions () +import Text.Show.Text.Data.Fixed (showbFixed) +import Text.Show.Text.Data.Floating (showbEFloat, showbFFloat, showbGFloat) +#if MIN_VERSION_base(4,7,0) +import Text.Show.Text.Data.Floating (showbFFloatAlt, showbGFloatAlt) +#endif +import Text.Show.Text.Data.Integral (showbIntAtBase) +import Text.Show.Text.Data.Version (showbVersionConcrete) + +-- | 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. +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 + +-- | 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 + +-- | Verifies 'showVersion' and 'showbVersion' generate the same output. +prop_showVersion :: Version -> Bool +prop_showVersion v = fromString (showVersion v) == showbVersionConcrete v + +baseAndFriendsTests :: [TestTree] +baseAndFriendsTests = + [ testGroup "Text.Show.Text.Control.Applicative" + [ testProperty "ZipList Int instance" (prop_matchesShow :: Int -> ZipList Int -> Bool) + ] + , testGroup "Text.Show.Text.Control.Concurrent" + [ testProperty "BlockReason instance" (prop_matchesShow :: Int -> BlockReason -> Bool) +-- , testProperty "ThreadId instance" (prop_matchesShow :: Int -> ThreadId -> Bool) + , testProperty "ThreadStatus instance" (prop_matchesShow :: Int -> ThreadStatus -> Bool) + ] + , testGroup "Text.Show.Text.Control.Exception" + [ testProperty "SomeException instance" (prop_matchesShow :: Int -> SomeException -> Bool) +-- , testProperty "IOException instance" (prop_matchesShow :: Int -> IOException -> Bool) + , testProperty "ArithException instance" (prop_matchesShow :: Int -> ArithException -> Bool) + , testProperty "ArrayException instance" (prop_matchesShow :: Int -> ArrayException -> Bool) + , testProperty "AssertionFailed instance" (prop_matchesShow :: Int -> AssertionFailed -> Bool) +#if MIN_VERSION_base(4,7,0) + , testProperty "SomeAsyncException instance" (prop_matchesShow :: Int -> SomeAsyncException -> Bool) +#endif + , testProperty "AsyncException instance" (prop_matchesShow :: Int -> AsyncException -> Bool) + , testProperty "NonTermination instance" (prop_matchesShow :: Int -> NonTermination -> Bool) + , testProperty "NestedAtomically instance" (prop_matchesShow :: Int -> NestedAtomically -> Bool) + , testProperty "BlockedIndefinitelyOnMVar instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnMVar -> Bool) + , testProperty "BlockedIndefinitelyOnSTM instance" (prop_matchesShow :: Int -> BlockedIndefinitelyOnSTM -> Bool) + , testProperty "Deadlock instance" (prop_matchesShow :: Int -> Deadlock -> Bool) + , testProperty "NoMethodError instance" (prop_matchesShow :: Int -> NoMethodError -> Bool) + , testProperty "PatternMatchFail instance" (prop_matchesShow :: Int -> PatternMatchFail -> Bool) + , testProperty "RecConError instance" (prop_matchesShow :: Int -> RecConError -> Bool) + , testProperty "RecSelError instance" (prop_matchesShow :: Int -> RecSelError -> Bool) + , testProperty "RecUpdError instance" (prop_matchesShow :: Int -> RecUpdError -> Bool) + , testProperty "ErrorCall instance" (prop_matchesShow :: Int -> ErrorCall -> Bool) + ] + , testGroup "Text.Show.Text.Control.Monad.ST" + [ testProperty "ST instance" (prop_matchesShow :: Int -> ST Int Int -> Bool) + ] + , testGroup "Text.Show.Text.Data.Array" + [ testProperty "Array Int Int instance" (prop_matchesShow :: Int -> Array Int Int -> Bool) + ] + , testGroup "Text.Show.Text.Data.Bool" + [ testProperty "Bool instance" (prop_matchesShow :: Int -> Bool -> Bool) + ] + , testGroup "Text.Show.Text.Data.ByteString" + [ testProperty "strict ByteString instance" (prop_matchesShow :: Int -> BS.ByteString -> Bool) + , testProperty "lazy ByteString instance" (prop_matchesShow :: Int -> BL.ByteString -> Bool) +#if MIN_VERSION_bytestring(0,10,4) + , testProperty "ShortByteString instance" (prop_matchesShow :: Int -> ShortByteString -> Bool) +#endif + ] + , testGroup "Text.Show.Text.Data.Char" + [ testProperty "Char instance" (prop_matchesShow :: Int -> Char -> Bool) + , testProperty "GeneralCategory instance" (prop_matchesShow :: Int -> GeneralCategory -> Bool) + ] + , testGroup "Text.Show.Text.Data.Containers" + [ testProperty "IntMap Int instance" (prop_matchesShow :: Int -> IntMap Int -> Bool) + , testProperty "IntSet instance" (prop_matchesShow :: Int -> IntSet -> Bool) + , testProperty "Map Int Int instance" (prop_matchesShow :: Int -> Map Int Int -> Bool) + , testProperty "Sequence Int" (prop_matchesShow :: Int -> Seq Int -> Bool) + , testProperty "Set Int instance" (prop_matchesShow :: Int -> Set Int -> Bool) + , testProperty "Tree Int instance" (prop_matchesShow :: Int -> Tree Int -> Bool) + ] + , testGroup "Text.Show.Text.Data.Data" + [ testProperty "Constr instance" (prop_matchesShow :: Int -> Constr -> Bool) + , testProperty "ConstrRep instance" (prop_matchesShow :: Int -> ConstrRep -> Bool) + , testProperty "DataRep instance" (prop_matchesShow :: Int -> DataRep -> Bool) + , testProperty "DataType instance" (prop_matchesShow :: Int -> DataType -> Bool) + , testProperty "Fixity instance" (prop_matchesShow :: Int -> D.Fixity -> Bool) + ] + , testGroup "Text.Show.Text.Data.Dynamic" + [ testProperty "Dynamic instance" (prop_matchesShow :: Int -> Dynamic -> Bool) + ] + , testGroup "Text.Show.Text.Data.Either" + [ testProperty "Either Int Int instance" (prop_matchesShow :: Int -> Either Int Int -> Bool) + ] + , testGroup "Text.Show.Text.Data.Fixed" + [ testProperty "Fixed E0 instance" (prop_matchesShow :: Int -> Fixed E0 -> Bool) + , testProperty "Fixed E1 instance" (prop_matchesShow :: Int -> Fixed E1 -> Bool) + , testProperty "Fixed E2 instance" (prop_matchesShow :: Int -> Fixed E2 -> Bool) + , testProperty "Fixed E3 instance" (prop_matchesShow :: Int -> Fixed E3 -> Bool) + , testProperty "Fixed E6 instance" (prop_matchesShow :: Int -> Fixed E6 -> Bool) + , testProperty "Fixed E9 instance" (prop_matchesShow :: Int -> Fixed E9 -> Bool) + , testProperty "Fixed E12 instance" (prop_matchesShow :: Int -> Fixed E12 -> Bool) + , testProperty "showFixed output" prop_showFixed + ] + , 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 +#if MIN_VERSION_base(4,7,0) + , testProperty "showbFFloatAlt output" $ prop_showXFloat showFFloatAlt showbFFloatAlt + , testProperty "showbGFloatAlt output" $ prop_showXFloat showGFloatAlt showbGFloatAlt +#endif + ] + , testGroup "Text.Show.Text.Data.Functions" + [ testProperty "Int -> Int instance" (prop_matchesShow :: Int -> (Int -> Int) -> Bool) + ] + , testGroup "Text.Show.Text.Data.Integral" + [ testProperty "Int instance" (prop_matchesShow :: Int -> Int -> Bool) + , testProperty "Int8 instance" (prop_matchesShow :: Int -> Int8 -> Bool) + , testProperty "Int16 instance" (prop_matchesShow :: Int -> Int16 -> Bool) + , testProperty "Int32 instance" (prop_matchesShow :: Int -> Int32 -> Bool) + , testProperty "Int64 instance" (prop_matchesShow :: Int -> Int64 -> Bool) + , testProperty "Integer instance" (prop_matchesShow :: Int -> Integer -> Bool) + , testProperty "Word instance" (prop_matchesShow :: Int -> Word -> Bool) + , testProperty "Word8 instance" (prop_matchesShow :: Int -> Word8 -> Bool) + , testProperty "Word16 instance" (prop_matchesShow :: Int -> Word16 -> Bool) + , testProperty "Word32 instance" (prop_matchesShow :: Int -> Word32 -> Bool) + , testProperty "Word64 instance" (prop_matchesShow :: Int -> Word64 -> Bool) + , testProperty "Ratio Int instance" (prop_matchesShow :: Int -> Ratio Int -> Bool) + , testProperty "showbIntAtBase output" prop_showIntAtBase + ] + , testGroup "Text.Show.Text.Data.List" + [ testProperty "String instance" (prop_matchesShow :: Int -> String -> Bool) + , testProperty "[String] instance" (prop_matchesShow :: Int -> [String] -> Bool) + , testProperty "[Int] instance" (prop_matchesShow :: Int -> [Int] -> Bool) + ] + , testGroup "Text.Show.Text.Data.Maybe" + [ testProperty "Maybe Int instance" (prop_matchesShow :: Int -> Maybe Int -> Bool) + ] + , testGroup "Text.Show.Text.Data.Monoid" + [ testProperty "All instance" (prop_matchesShow :: Int -> All -> Bool) + , testProperty "Any instance" (prop_matchesShow :: Int -> Any -> Bool) + , testProperty "Dual Int instance" (prop_matchesShow :: Int -> Dual Int -> Bool) + , testProperty "First (Maybe Int) instance" (prop_matchesShow :: Int -> First (Maybe Int) -> Bool) + , testProperty "Last (Maybe Int) instance" (prop_matchesShow :: Int -> Last (Maybe Int) -> Bool) + , testProperty "Product Int instance" (prop_matchesShow :: Int -> Product Int -> Bool) + , testProperty "Sum Int instance" (prop_matchesShow :: Int -> Sum Int -> Bool) + ] + , 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.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) + ] + , testGroup "Text.Show.Text.Data.Tuple" + [ testProperty "() instance" (prop_matchesShow :: Int -> () -> Bool) + , testProperty "(Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int) -> Bool) + , testProperty "(Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int) -> Bool) + , testProperty "(Int, Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int, Int) -> Bool) + , testProperty "(Int, Int, Int, Int, Int) instance" (prop_matchesShow :: Int -> (Int, Int, Int, Int, Int) -> Bool) + ] +#if MIN_VERSION_base(4,7,0) + , testGroup "Text.Show.Text.Data.Type.Coercion" + [ testProperty "Coercion instance" (prop_matchesShow :: Int -> Coercion All Bool -> Bool) + ] + , testGroup "Text.Show.Text.Data.Type.Equality" + [ testProperty "(:~:) instance" (prop_matchesShow :: Int -> Int :~: Int -> Bool) + ] +#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) +#if MIN_VERSION_base(4,7,0) + , testProperty "Proxy Int instance" (prop_matchesShow :: Int -> Proxy Int -> Bool) +#endif + ] +#endif + , testGroup "Text.Show.Text.Data.Version" + [ testProperty "Version instance" (prop_matchesShow :: Int -> Version -> Bool) + , testProperty "showbVersionConcrete output" prop_showVersion + ] + , testGroup "Text.Show.Text.Foreign.C.Types" + [ testProperty "CChar" (prop_matchesShow :: Int -> CChar -> Bool) + , testProperty "CSChar instance" (prop_matchesShow :: Int -> CSChar -> Bool) + , testProperty "CUChar instance" (prop_matchesShow :: Int -> CUChar -> Bool) + , testProperty "CShort instance" (prop_matchesShow :: Int -> CShort -> Bool) + , testProperty "CUShort instance" (prop_matchesShow :: Int -> CUShort -> Bool) + , testProperty "CInt instance" (prop_matchesShow :: Int -> CInt -> Bool) + , testProperty "CUInt instance" (prop_matchesShow :: Int -> CUInt -> Bool) + , testProperty "CLong instance" (prop_matchesShow :: Int -> CLong -> Bool) + , testProperty "CULong instance" (prop_matchesShow :: Int -> CULong -> Bool) + , testProperty "CPtrdiff instance" (prop_matchesShow :: Int -> CPtrdiff -> Bool) + , testProperty "CSize instance" (prop_matchesShow :: Int -> CSize -> Bool) + , testProperty "CWchar instance" (prop_matchesShow :: Int -> CWchar -> Bool) + , testProperty "CSigAtomic instance" (prop_matchesShow :: Int -> CSigAtomic -> Bool) + , testProperty "CLLong instance" (prop_matchesShow :: Int -> CLLong -> Bool) + , testProperty "CULLong instance" (prop_matchesShow :: Int -> CULLong -> Bool) + , testProperty "CIntPtr instance" (prop_matchesShow :: Int -> CIntPtr -> Bool) + , testProperty "CUIntPtr instance" (prop_matchesShow :: Int -> CUIntPtr -> Bool) + , testProperty "CIntMax instance" (prop_matchesShow :: Int -> CIntMax -> Bool) + , testProperty "CUIntPtr instance" (prop_matchesShow :: Int -> CUIntPtr -> Bool) + , testProperty "CIntMax instance" (prop_matchesShow :: Int -> CIntMax -> Bool) + , testProperty "CUIntMax instance" (prop_matchesShow :: Int -> CUIntMax -> Bool) + , testProperty "CClock instance" (prop_matchesShow :: Int -> CClock -> Bool) + , testProperty "CTime instance" (prop_matchesShow :: Int -> CTime -> Bool) + , testProperty "CUSeconds instance" (prop_matchesShow :: Int -> CUSeconds -> Bool) + , testProperty "CSUSeconds instance" (prop_matchesShow :: Int -> CSUSeconds -> Bool) + , testProperty "CFloat instance" (prop_matchesShow :: Int -> CFloat -> Bool) + , testProperty "CDouble instance" (prop_matchesShow :: Int -> CUChar -> Bool) + ] + , testGroup "Text.Show.Text.Foreign.Ptr" + [ testProperty "Ptr Int instance" (prop_matchesShow :: Int -> Ptr Int -> Bool) + , testProperty "FunPtr Int instance" (prop_matchesShow :: Int -> FunPtr Int -> Bool) + , testProperty "IntPtr instance" (prop_matchesShow :: Int -> IntPtr -> Bool) + , testProperty "WordPtr instance" (prop_matchesShow :: Int -> WordPtr -> Bool) +-- , testProperty "ForeignPtr instance" (prop_matchesShow :: Int -> ForeignPtr Int -> Bool) + ] +-- #if MIN_VERSION_base(4,4,0) +-- , testGroup "Text.Show.Text.GHC.Event" +-- [ testProperty "Event instance" (prop_matchesShow :: Int -> Event -> Bool) +-- , testProperty "FdKey instance" (prop_matchesShow :: Int -> FdKey -> Bool) +-- ] +-- #endif + , testGroup "Text.Show.Text.GHC.Generics" + [ testProperty "U1 Int instance" (prop_matchesShow :: Int -> U1 Int -> Bool) + , testProperty "Par1 Int instance" (prop_matchesShow :: Int -> Par1 Int -> Bool) + , testProperty "Rec1 Maybe Int instance" (prop_matchesShow :: Int -> Rec1 Maybe Int -> Bool) + , testProperty "K1 () Int () instance" (prop_matchesShow :: Int -> K1 () Int () -> Bool) + , testProperty "M1 () () Maybe Int instance" (prop_matchesShow :: Int -> M1 () () Maybe Int -> Bool) + , testProperty "(Maybe :+: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :+: Maybe) Int -> Bool) + , testProperty "(Maybe :*: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :*: Maybe) Int -> Bool) + , testProperty "(Maybe :.: Maybe) Int instance" (prop_matchesShow :: Int -> (Maybe :.: Maybe) Int -> Bool) + , testProperty "Fixity instance" (prop_matchesShow :: Int -> G.Fixity -> Bool) + , testProperty "Associativity instance" (prop_matchesShow :: Int -> Associativity -> Bool) + , testProperty "Arity instance" (prop_matchesShow :: Int -> Arity -> Bool) + ] + , testGroup "Text.Show.Text.GHC.Stats" + [ testProperty "GCStats instance" (prop_matchesShow :: Int -> GCStats -> Bool) + ] + , testGroup "Text.Show.Text.System.Exit" + [ testProperty "ExitCode instance" (prop_matchesShow :: Int -> ExitCode -> Bool) + ] + , testGroup "Text.Show.Text.System.IO" + [ -- testProperty "Handle instance" (prop_matchesShow :: Int -> Handle -> Bool) + testProperty "IOMode instance" (prop_matchesShow :: Int -> IOMode -> Bool) + , testProperty "BufferMode instance" (prop_matchesShow :: Int -> BufferMode -> Bool) +-- , testProperty "HandlePosn instance" (prop_matchesShow :: Int -> HandlePosn -> Bool) + , testProperty "SeekMode instance" (prop_matchesShow :: Int -> SeekMode -> Bool) +-- #if MIN_VERSION_base(4,3,0) +-- , testProperty "TextEncoding" (prop_matchesShow :: Int -> TextEncoding -> Bool) +-- #endif +#if MIN_VERSION_base(4,4,0) + , testProperty "CodingProgress instance" (prop_matchesShow :: Int -> CodingProgress -> Bool) + , testProperty "CodingFailureMode instance" (prop_matchesShow :: Int -> CodingFailureMode -> Bool) +#endif + , testProperty "Newline instance" (prop_matchesShow :: Int -> Newline -> Bool) + , testProperty "NewlineMode instance" (prop_matchesShow :: Int -> NewlineMode -> Bool) + ] + , testGroup "Text.Show.Text.System.Posix.Types" + [ testProperty "CDev instance" (prop_matchesShow :: Int -> CDev -> Bool) + , testProperty "CIno instance" (prop_matchesShow :: Int -> CIno -> Bool) + , testProperty "CMode instance" (prop_matchesShow :: Int -> CMode -> Bool) + , testProperty "COff instance" (prop_matchesShow :: Int -> COff -> Bool) + , testProperty "CPid instance" (prop_matchesShow :: Int -> CPid -> Bool) + , testProperty "CSsize instance" (prop_matchesShow :: Int -> CSsize -> Bool) + , testProperty "CGid instance" (prop_matchesShow :: Int -> CGid -> Bool) + , testProperty "CNlink instance" (prop_matchesShow :: Int -> CNlink -> Bool) + , testProperty "CUid instance" (prop_matchesShow :: Int -> CUid -> Bool) + , testProperty "CCc instance" (prop_matchesShow :: Int -> CCc -> Bool) + , testProperty "CSpeed instance" (prop_matchesShow :: Int -> CSpeed -> Bool) + , testProperty "CTcflag instance" (prop_matchesShow :: Int -> CTcflag -> Bool) + , testProperty "CRLim instance" (prop_matchesShow :: Int -> CRLim -> Bool) + , testProperty "Fd instance" (prop_matchesShow :: Int -> Fd -> Bool) + ] +-- , testGroup "Text.Show.Text.Text.Read.Lex" +-- [ testProperty "Lexeme instance" (prop_matchesShow :: Int -> Lexeme -> Bool) +-- , testProperty "Number instance" (prop_matchesShow :: Int -> Number -> Bool) +-- ] + ] diff --git a/tests/Properties/Derived.hs b/tests/Properties/Derived.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Derived.hs @@ -0,0 +1,66 @@ +{-# 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.Derived (derivedTests) where + +import Data.Text.Lazy.Builder (fromString) + +import Instances.Derived + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text (showb, showbPrec) + +-- | 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' + -> Bool +prop_showGADT p d i + = let gc1 :: GADT Char Int + gc1 = GADTCon1 + + gc2 :: GADT Double Double + gc2 = GADTCon2 d + + gc3 :: GADT Int String + gc3 = GADTCon3 i + in fromString (show gc1) == showb gc1 + && fromString (showsPrec p gc2 "") == showbPrec p gc2 + && fromString (showsPrec p gc3 "") == showbPrec p gc3 + +derivedTests :: [TestTree] +derivedTests = + [ testGroup "Template Haskell-derived data types" + [ testProperty "Nullary instance" (prop_matchesShow :: Int -> Nullary -> Bool) + , testProperty "PhantomNullary Int instance" (prop_matchesShow :: Int -> PhantomNullary Int -> Bool) + , testProperty "MonomorphicUnary instance" (prop_matchesShow :: Int -> MonomorphicUnary -> Bool) + , testProperty "PolymorphicUnary Int Int instance" (prop_matchesShow :: Int -> PolymorphicUnary Int Int -> Bool) + , testProperty "MonomorphicNewtype instance" (prop_matchesShow :: Int -> MonomorphicNewtype -> Bool) + , testProperty "PolymorphicNewtype Int Int instance" (prop_matchesShow :: Int -> PolymorphicNewtype Int Int -> Bool) + , testProperty "MonomorphicProduct instance" (prop_matchesShow :: Int -> MonomorphicProduct -> Bool) + , testProperty "PolymorphicProduct Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicProduct Int Int Int Int -> Bool) + , testProperty "MonomorphicRecord instance" (prop_matchesShow :: Int -> MonomorphicRecord -> Bool) + , testProperty "PolymorphicRecord Int Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicRecord Int Int Int Int -> Bool) + , testProperty "MonomorphicInfix instance" (prop_matchesShow :: Int -> MonomorphicInfix -> Bool) + , testProperty "PolymorphicInfix Int Int Int instance" (prop_matchesShow :: Int -> PolymorphicInfix Int Int Int -> Bool) + , testProperty "AllAtOnce Int Int Int Int instance" (prop_matchesShow :: Int -> AllAtOnce Int Int Int Int -> Bool) + , testProperty "GADT instance" prop_showGADT + , 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) + ] + ] diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Utils.hs @@ -0,0 +1,28 @@ +{-# 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 + +import Data.Text.Lazy.Builder (fromString) + +import qualified Prelude as P (Show) +import Prelude hiding (Show) + +import Test.QuickCheck (Arbitrary) + +import qualified Text.Show.Text as T (Show) +import Text.Show.Text (showbPrec) + +-- | 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 diff --git a/text-show.cabal b/text-show.cabal --- a/text-show.cabal +++ b/text-show.cabal @@ -1,10 +1,45 @@ name: text-show -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Efficient conversion of values into Text -description: @text-show@ offers a complete drop-in replacement of the @Show@ - typeclass, but for @Text@ instead of @String@. This package was - created in the spirit of +description: @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 @@. + . + At the moment, @text-show@ provides @Show@ instances for most data + types in the @@, + @@, + @@, + @@, + @@, 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. + . + For most uses, simply importing "Text.Show.Text" + will suffice: + . + @ + {-# LANGUAGE NoImplicitPrelude #-} + module Main where + import Data.Text (Text) + import Prelude hiding (Show(..), print) + import Text.Show.Text + . + number :: Text + number = show 27 + . + 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@). homepage: https://github.com/RyanGlScott/text-show bug-reports: https://github.com/RyanGlScott/text-show/issues license: BSD3 @@ -24,23 +59,93 @@ library exposed-modules: Text.Show.Text - build-depends: array >= 0.3 - , base >= 4.2 && < 5 - , containers < 0.6 - , text >= 0.2 && < 1.3 - , text-format >= 0.2 && < 0.4 + Text.Show.Text.TH + + Text.Show.Text.Control.Applicative + Text.Show.Text.Control.Concurrent + Text.Show.Text.Control.Exception + Text.Show.Text.Control.Monad.ST + Text.Show.Text.Data.Array + Text.Show.Text.Data.Bool + Text.Show.Text.Data.ByteString + Text.Show.Text.Data.Char + Text.Show.Text.Data.Containers + 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.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.Text + Text.Show.Text.Data.Time + Text.Show.Text.Data.Tuple + Text.Show.Text.Data.Typeable + Text.Show.Text.Data.Version + Text.Show.Text.Foreign.C.Types + Text.Show.Text.Foreign.Ptr + Text.Show.Text.Functions + 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 + Text.Show.Text.Control + Text.Show.Text.Data + Text.Show.Text.Foreign + Text.Show.Text.GHC + Text.Show.Text.Instances + Text.Show.Text.System + Text.Show.Text.Text + 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 + , ghc-prim + , template-haskell >= 2.4 && < 2.10 + , text >= 0.2 && < 1.3 + , text-format >= 0.2 && < 0.4 + , time >= 0.1 && < 1.6 hs-source-dirs: src ghc-options: -Wall + + if impl(ghc >= 7.2) + exposed-modules: Text.Show.Text.GHC.Event + Text.Show.Text.GHC.Generics + + if impl(ghc >= 7.4) + exposed-modules: Text.Show.Text.GHC.Stats + + if impl(ghc >= 7.8) + exposed-modules: Text.Show.Text.Data.Type.Coercion + Text.Show.Text.Data.Type.Equality -test-suite properties +test-suite text-show-properties type: exitcode-stdio-1.0 main-is: Properties.hs + other-modules: Instances.BaseAndFriends + Instances.Derived + Properties.BaseAndFriends + Properties.Derived + Properties.Utils hs-source-dirs: tests - build-depends: array >= 0.3 - , base >= 4.2 && < 5 - , containers < 0.6 - , QuickCheck >= 2.4 && < 2.8 - , quickcheck-instances - , text >= 0.2 && < 1.3 - , text-show == 0.2.0.0 + build-depends: array >= 0.3 && < 0.6 + , base >= 4.2 && < 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-quickcheck >= 0.8 && < 0.9 + , text >= 0.2 && < 1.3 + , text-show >= 0.3 && < 0.4 + , time >= 0.1 && < 1.6 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