text-show 0.3.0.0 → 0.3.1.0
raw patch · 14 files changed
+508/−275 lines, 14 files
Files
- CHANGELOG.md +6/−0
- src/Text/Show/Text.hs +3/−1
- src/Text/Show/Text/Class.hs +40/−30
- src/Text/Show/Text/Data/Array.hs +4/−4
- src/Text/Show/Text/Data/ByteString.hs +5/−5
- src/Text/Show/Text/Data/Containers.hs +8/−7
- src/Text/Show/Text/Data/Text.hs +2/−2
- src/Text/Show/Text/TH.hs +6/−193
- src/Text/Show/Text/TH/Internal.hs +341/−0
- tests/Instances/BaseAndFriends.hs +3/−21
- tests/Properties.hs +9/−2
- tests/Properties/BaseAndFriends.hs +15/−8
- tests/Properties/MkShow.hs +61/−0
- text-show.cabal +5/−2
CHANGELOG.md view
@@ -1,9 +1,15 @@+# 0.3.1.0+* Add `showList` and `showListLazy`+* Don't use showbListDefault to show `containers` data types+* Add the ability to splice `show` functions for arbitrary data types (even if they aren't `Show` instances). These functions are `mkShow`, `mkShowLazy`, `mkShowPrec`, `mkShowPrecLazy`, `mkShowb`, `mkShowbPrec`, `mkPrint`, `mkPrintLazy`, `mkHPrint`, and `mkHPrintLazy`.+ # 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`+* Template Haskell derivation of `Show` instances (doesn't support data families yet) # 0.2.0.0
src/Text/Show/Text.hs view
@@ -17,6 +17,8 @@ , showLazy , showPrec , showPrecLazy+ , showList+ , showListLazy , showbParen -- * 'Builder's , module Data.Text.Lazy.Builder@@ -33,7 +35,7 @@ import Data.Text.Lazy.Builder -import Prelude hiding (Show(show), print)+import Prelude hiding (Show(show, showList), print) import Text.Show.Text.Class import Text.Show.Text.Instances ()
src/Text/Show/Text/Class.hs view
@@ -19,20 +19,20 @@ import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (Builder, toLazyText) -import Prelude hiding (Show(show))+import Prelude hiding (Show(show, showList)) import System.IO (Handle) import Text.Show.Text.Utils ((<>), s) -- | --- Conversion of values to 'Text'. Because there are both strict and lazy 'Text'--- variants, the 'Show' class deliberately avoids using 'Text' in its functions.--- Instead, 'showbPrec', 'showb', and 'showbList' all return 'Builder's, an--- efficient intermediate form that can be converted to either kind of 'Text'.+-- Conversion of values to @Text@. Because there are both strict and lazy @Text@+-- variants, the 'Show' class deliberately avoids using @Text@ in its functions.+-- Instead, 'showbPrec', 'showb', and 'showbList' all return 'Builder', an+-- efficient intermediate form that can be converted to either kind of @Text@. -- -- 'Builder' is a 'Monoid', so it is useful to use the 'mappend' (or '<>') function--- to combine 'Builder's when deriving 'Show' instances. As an example:+-- to combine 'Builder's when creating 'Show' instances. As an example: -- -- @ -- import Text.Show.Text@@ -42,20 +42,20 @@ -- showb (Example i1 i2) = showb i1 <> singleton ' ' <> showb i2 -- @ -- --- If you do not want to derive 'Show' instances manually, you can alternatively+-- If you do not want to create 'Show' instances manually, you can alternatively -- use the "Text.Show.Text.TH" module to automatically generate default 'Show' -- instances using Template Haskell. class Show a where -- |- -- Constructs a 'Text' via an efficient 'Builder'. The precedence is used to + -- 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'.+ -- 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+ -- 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 @@ -68,68 +68,78 @@ showb = showbPrec 0 - showbList = showbListDefault+ showbList = showbListDefault showb #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL showbPrec | showb #-} #endif --- | Constructs a strict 'Text' from a single value.+-- | Constructs a strict 'TS.Text' from a single value. show :: Show a => a -> TS.Text show = toStrict . showLazy {-# INLINE show #-} --- | Constructs a lazy 'Text' from a single value.+-- | Constructs a lazy 'TL.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.+-- | Constructs a strict 'TS.Text' from a single value with the given precedence. showPrec :: Show a => Int -> a -> TS.Text showPrec p = toStrict . showPrecLazy p {-# INLINE showPrec #-} --- | Constructs a lazy 'Text' from a single value with the given precedence.+-- | Constructs a lazy 'TL.Text' from a single value with the given precedence. showPrecLazy :: Show a => Int -> a -> TL.Text showPrecLazy p = toLazyText . showbPrec p {-# INLINE showPrecLazy #-} --- |--- 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 #-}+-- | Construct a strict 'TS.Text' from a list of values.+showList :: Show a => [a] -> TS.Text+showList = toStrict . showListLazy+{-# INLINE showList #-} +-- | Construct a lazy 'TL.Text' from a list of values.+showListLazy :: Show a => [a] -> TL.Text+showListLazy = toLazyText . showbList+{-# INLINE showListLazy #-}+ -- | Surrounds 'Builder' output with parentheses if the 'Bool' parameter is 'True'. showbParen :: Bool -> Builder -> Builder showbParen p builder | p = s '(' <> builder <> s ')' | otherwise = builder {-# INLINE showbParen #-} --- | Writes a value's strict 'Text' representation to the standard output, followed+-- |+-- Converts a list of values into a 'Builder' in which the values are surrounded+-- by square brackets and each value is separated by a comma. This is the default+-- implementation of 'showbList' save for a few special cases (e.g., 'String').+showbListDefault :: (a -> Builder) -> [a] -> Builder+showbListDefault _ [] = "[]"+showbListDefault showbx (x:xs) = s '[' <> showbx x <> go xs -- "[..+ where+ go (y:ys) = s ',' <> showbx y <> go ys -- ..,..+ go [] = s ']' -- ..]"+{-# INLINE showbListDefault #-}++-- | Writes a value's strict 'TS.Text' representation to the standard output, followed -- by a newline. print :: Show a => a -> IO () print = TS.putStrLn . show {-# INLINE print #-} --- | Writes a value's lazy 'Text' representation to the standard output, followed+-- | Writes a value's lazy 'TL.Text' representation to the standard output, followed -- by a newline. printLazy :: Show a => a -> IO () printLazy = TL.putStrLn . showLazy {-# INLINE printLazy #-} --- | Writes a value's strict 'Text' representation to a file handle, followed+-- | Writes a value's strict 'TS.Text' representation to a file handle, followed -- by a newline. hPrint :: Show a => Handle -> a -> IO () hPrint h = TS.hPutStrLn h . show {-# INLINE hPrint #-} --- | Writes a value's lazy 'Text' representation to a file handle, followed+-- | Writes a value's lazy 'TL.Text' representation to a file handle, followed -- by a newline. hPrintLazy :: Show a => Handle -> a -> IO () hPrintLazy h = TL.hPutStrLn h . showLazy
src/Text/Show/Text/Data/Array.hs view
@@ -17,11 +17,11 @@ import Data.Ix (Ix) import Data.Text.Lazy.Builder (Builder) -import GHC.Show (appPrec, appPrec1)+import GHC.Show (appPrec) import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showbPrec), showbParen)+import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) import Text.Show.Text.Data.List () import Text.Show.Text.Data.Tuple () import Text.Show.Text.Utils ((<>), s)@@ -30,9 +30,9 @@ showbArrayPrec :: (Show i, Show e, Ix i) => Int -> Array i e -> Builder showbArrayPrec p a = showbParen (p > appPrec) $ "array "- <> showbPrec appPrec1 (bounds a)+ <> showb (bounds a) <> s ' '- <> showbPrec appPrec1 (assocs a)+ <> showb (assocs a) {-# INLINE showbArrayPrec #-} instance (Show i, Show e, Ix i) => Show (Array i e) where
src/Text/Show/Text/Data/ByteString.hs view
@@ -47,21 +47,21 @@ import Text.Show.Text.Utils ((<>), s) #endif --- | Convert a strict 'ByteString' to a 'Builder'.+-- | Convert a strict 'BS.ByteString' to a 'Builder'. showbByteStringStrict :: BS.ByteString -> Builder showbByteStringStrict = fromString . P.show {-# INLINE showbByteStringStrict #-} --- | Convert a lazy 'ByteString' to a 'Builder'.+-- | Convert a lazy 'BL.ByteString' to a 'Builder'. showbByteStringLazy :: BL.ByteString -> Builder showbByteStringLazy = showbByteStringLazyPrec 0 {-# INLINE showbByteStringLazy #-} --- | Convert a lazy 'ByteString' to a 'Builder' with the given precedence.+-- | Convert a lazy 'BL.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+-- argument, since lazy 'BL.ByteString's are printed out identically to 'String's.+-- On earlier versions of @bytestring@, however, lazy 'BL.ByteString's can be printed -- with parentheses (e.g., @Chunk "example" Empty@ vs. @(Chunk "example" Empty)@) -- depending on the precedence. showbByteStringLazyPrec :: Int -> BL.ByteString -> Builder
src/Text/Show/Text/Data/Containers.hs view
@@ -40,39 +40,40 @@ import Prelude hiding (Show) -import Text.Show.Text.Class (Show(showb, showbPrec), showbParen, showbListDefault)+import Text.Show.Text.Class (Show(showb, showbPrec), showbParen) import Text.Show.Text.Data.Integral ()+import Text.Show.Text.Data.List () import Text.Show.Text.Data.Tuple () import Text.Show.Text.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)+ = showbParen (p > appPrec) $ "fromList " <> showb (IM.toList im) {-# INLINE showbIntMapPrec #-} -- | Convert an 'IntSet' into a 'Builder' with the given precedence. showbIntSetPrec :: Int -> IntSet -> Builder showbIntSetPrec p is- = showbParen (p > appPrec) $ "fromList " <> showbListDefault (IS.toList is)+ = showbParen (p > appPrec) $ "fromList " <> showb (IS.toList is) {-# INLINE showbIntSetPrec #-} -- | Convert a 'Map' into a 'Builder' with the given precedence. showbMapPrec :: (Show k, Show v) => Int -> Map k v -> Builder showbMapPrec p m- = showbParen (p > appPrec) $ "fromList " <> showbListDefault (M.toList m)+ = showbParen (p > appPrec) $ "fromList " <> showb (M.toList m) {-# INLINE showbMapPrec #-} -- | Convert a 'Sequence' into a 'Builder' with the given precedence. showbSequencePrec :: Show a => Int -> Seq a -> Builder showbSequencePrec p s'- = showbParen (p > appPrec) $ "fromList " <> showbListDefault (F.toList s')+ = showbParen (p > appPrec) $ "fromList " <> showb (F.toList s') {-# INLINE showbSequencePrec #-} -- | Convert a 'Set' into a 'Builder' with the given precedence. showbSetPrec :: Show a => Int -> Set a -> Builder showbSetPrec p s'- = showbParen (p > appPrec) $ "fromList " <> showbListDefault (Set.toList s')+ = showbParen (p > appPrec) $ "fromList " <> showb (Set.toList s') {-# INLINE showbSetPrec #-} -- | Convert a 'Tree' into a 'Builder' with the given precedence.@@ -81,7 +82,7 @@ "Node {rootLabel = " <> showb rl <> ", subForest = "- <> showbListDefault sf+ <> showb sf <> s '}' {-# INLINE showbTreePrec #-}
src/Text/Show/Text/Data/Text.hs view
@@ -26,11 +26,11 @@ import Text.Show.Text.Data.Char () import Text.Show.Text.Data.List () --- | Convert a strict 'Text' into a 'Builder'.+-- | Convert a strict 'TS.Text' into a 'Builder'. showbTextStrict :: TS.Text -> Builder showbTextStrict = showb . TS.unpack --- | Convert a lazy 'Text' into a 'Builder'.+-- | Convert a lazy 'TL.Text' into a 'Builder'. showbTextLazy :: TL.Text -> Builder showbTextLazy = showb . TL.unpack
src/Text/Show/Text/TH.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Show.Text.TH@@ -8,197 +7,11 @@ -- 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.+-- Functions to mechanically derive 'Show' instances or splice+-- 'show'-related expressions into Haskell source code. You need to enable+-- the @TemplateHaskell@ language extension in order to use this module. -----------------------------------------------------------------------------module Text.Show.Text.TH (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]+module Text.Show.Text.TH (module Text.Show.Text.TH.Internal) where -#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+import Text.Show.Text.Instances ()+import Text.Show.Text.TH.Internal
+ src/Text/Show/Text/TH/Internal.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Text.Show.Text.TH.Internal+-- Copyright : (C) 2014 Ryan Scott+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Ryan Scott+-- Stability : Experimental+-- Portability : GHC+-- +-- Functions to mechanically derive 'Show' instances or splice+-- 'show'-related expressions into Haskell source code. You need to enable+-- the @TemplateHaskell@ language extension in order to use this module.+----------------------------------------------------------------------------+module Text.Show.Text.TH.Internal (+ -- * @deriveShow@+ -- $deriveShow+ deriveShow+ -- * @mk@ functions+ -- $mk+ , mkShow+ , mkShowLazy+ , mkShowPrec+ , mkShowPrecLazy+-- , mkShowList+-- , mkShowListLazy+ , mkShowb+ , mkShowbPrec+-- , mkShowbList+ , mkPrint+ , mkPrintLazy+ , mkHPrint+ , mkHPrintLazy+ ) where++import Control.Applicative ((<$>))++import Data.List (foldl')+import qualified Data.Text as TS ()+import qualified Data.Text.IO as TS (putStrLn, hPutStrLn)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (Builder, fromString, toLazyText)+import qualified Data.Text.Lazy as TL ()+import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn)++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.Utils ((<>), s)++{- $deriveShow++'deriveShow' automatically generates a 'Show' instance declaration for a @data@+type or @newtype@. 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.++-}++-- | 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 cxt'+ (appT classType type')+ [ funD 'showbPrec [ clause [] (normalB $ consToShow cons) []+ ]+ ]+ where+ classType :: Q Type+ classType = conT ''Show+ + cxt' :: Q Cxt+ type' :: Q Type+ (cxt', type') = instanceCtxType name tvbs++{- $mk++There may be scenarios in which you want to show an arbitrary @data@ type or @newtype@+without having to make the type an instance of 'Show'. For these cases,+"Text.Show.Text.TH" provide several functions (all prefixed with @mk@) that splice+the appropriate lambda expression into your source code.++As an example, suppose you have @data ADT = ADTCon@, which is not an instance of 'Show'.+With @mkShow@, you can still convert it to 'Text':++@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}++whichADT :: Bool+whichADT = $(mkShow ''ADT) ADTCon == \"ADT\"+@++Note that due the order in which Template Haskell executes splices, the above code+may fail to compile if @ADT@ is located in the same module and @whichADT@. To get+around this, you can use the following hack:++@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}++data ADT = ADTCon+$(return [])++whichADT :: Bool+whichADT = $(mkShow ''ADT) ADTCon == \"ADT\"+@++-}++-- |+-- Generates a lambda expression which converts the given @data@ type or @newtype@+-- to a strict 'TS.Text'.+mkShow :: Name -> Q Exp+mkShow name = [| toStrict . $(mkShowLazy name) |]++-- |+-- Generates a lambda expression which converts the given @data@ type or @newtype@+-- to a lazy 'TL.Text'.+mkShowLazy :: Name -> Q Exp+mkShowLazy name = [| toLazyText . $(mkShowb name) |]++-- |+-- Generates a lambda expression which converts the given @data@ type or @newtype@+-- to a strict 'TS.Text' with the given precedence.+mkShowPrec :: Name -> Q Exp+mkShowPrec name = [| \p -> toStrict . $(mkShowPrecLazy name) p |]++-- |+-- Generates a lambda expression which converts the given @data@ type or @newtype@+-- to a lazy 'TL.Text' with the given precedence.+mkShowPrecLazy :: Name -> Q Exp+mkShowPrecLazy name = [| \p -> toLazyText . $(mkShowbPrec name) p |]++-- |+-- Generates a lambda expression which converts the given @data@ type or @newtype@+-- to a 'Builder'.+mkShowb :: Name -> Q Exp+mkShowb name = mkShowbPrec name `appE` [| 0 :: Int |]++-- |+-- Generates a lambda expression which converts the given @data@ type or @newtype@+-- to a 'Builder' with the given precedence.+mkShowbPrec :: Name -> Q Exp+mkShowbPrec name = withType name $ \tvbs cons -> fromCons tvbs cons+ where+ fromCons :: [TyVarBndr] -> [Con] -> Q Exp+ fromCons tvbs cons = sigE (consToShow cons)+ $ forallT tvbs+ cxt'+ [t| Int -> $(type') -> Builder |]+ where+ cxt' :: Q Cxt+ type' :: Q Type+ (cxt', type') = instanceCtxType name tvbs++-- |+-- Generates a lambda expression which writes the given @data@ type or @newtype@+-- argument's strict 'TS.Text' output to the standard output, followed by a newline.+mkPrint :: Name -> Q Exp+mkPrint name = [| TS.putStrLn . $(mkShow name) |]++-- |+-- Generates a lambda expression which writes the given @data@ type or @newtype@+-- argument's lazy 'TL.Text' output to the standard output, followed by a newline.+mkPrintLazy :: Name -> Q Exp+mkPrintLazy name = [| TL.putStrLn . $(mkShowLazy name) |]++-- |+-- Generates a lambda expression which writes the given @data@ type or @newtype@+-- argument's strict 'TS.Text' output to the given file handle, followed by a newline.+mkHPrint :: Name -> Q Exp+mkHPrint name = [| \h -> TS.hPutStrLn h . $(mkShow name) |]++-- |+-- Generates a lambda expression which writes the given @data@ type or @newtype@+-- argument's lazy 'TL.Text' output to the given file handle, followed by a newline.+mkHPrintLazy :: Name -> Q Exp+mkHPrintLazy name = [| \h -> TL.hPutStrLn h . $(mkShowLazy name) |]++-- | Generates code to generate the 'Show' encoding of a number of constructors.+-- All constructors must be from the same type.+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+-------------------------------------------------------------------------------++instanceCtxType :: Name -> [TyVarBndr] -> (Q Cxt, Q Type)+instanceCtxType name tvbs+ = let typeNames :: [Name]+ typeNames = map tvbName tvbs+ + instanceType :: Q Type+ instanceType = foldl' appT (conT name) $ map varT typeNames+ in (applyCon ''Show typeNames name, instanceType)++-- | If constructor is nullary.+isNullary :: Con -> Bool+isNullary (NormalC _ []) = True+isNullary (RecC _ []) = True+isNullary _ = False++-- | 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
tests/Instances/BaseAndFriends.hs view
@@ -49,10 +49,8 @@ import Data.Type.Equality ((:~:)(..)) #endif #if MIN_VERSION_base(4,4,0)-import Data.Typeable.Internal (Typeable, TyCon(..), TypeRep(..),- mkTyConApp, splitTyConApp, typeOf)+import Data.Typeable.Internal (TyCon(..)) import GHC.Fingerprint.Type (Fingerprint(..))-import Data.Word (Word) #if !(MIN_VERSION_base(4,7,0)) import Data.Word (Word64)@@ -236,24 +234,8 @@ #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+-- TODO: Come up with an instance of TypeRep that doesn't take forever+-- instance Arbitrary TypeRep where instance Arbitrary TyCon where arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
tests/Properties.hs view
@@ -12,12 +12,19 @@ module Main (main) where import Properties.BaseAndFriends (baseAndFriendsTests)-import Properties.Derived (derivedTests)+import Properties.Derived (derivedTests)+import Properties.MkShow (mkShowTests) import Test.Tasty (TestTree, defaultMain, testGroup) main :: IO () main = defaultMain testTree +allTests :: [TestTree]+allTests = concat [ baseAndFriendsTests+ , derivedTests+ , mkShowTests+ ]+ testTree :: TestTree-testTree = testGroup "QuickCheck properties" $ baseAndFriendsTests ++ derivedTests+testTree = testGroup "QuickCheck properties" allTests
tests/Properties/BaseAndFriends.hs view
@@ -59,7 +59,7 @@ import Data.Type.Equality ((:~:)) #endif #if MIN_VERSION_base(4,4,0)-import Data.Typeable.Internal (TyCon, TypeRep)+import Data.Typeable.Internal (TyCon) import GHC.Fingerprint.Type (Fingerprint) #endif import Data.Word (Word, Word8, Word16, Word32, Word64)@@ -79,6 +79,7 @@ #if MIN_VERSION_base(4,5,0) import GHC.Stats (GCStats) #endif+import GHC.Show (showList__) import Instances.BaseAndFriends () @@ -109,6 +110,7 @@ import Text.Show.Text.Data.Floating (showbFFloatAlt, showbGFloatAlt) #endif import Text.Show.Text.Data.Integral (showbIntAtBase)+import Text.Show.Text.Data.List (showbListDefault) import Text.Show.Text.Data.Version (showbVersionConcrete) -- | Verifies 'showFixed' and 'showbFixed' generate the same output.@@ -122,6 +124,10 @@ i <- arbitrary `suchThat` (>= 0) :: Gen Int return $ fromString (showIntAtBase base intToDigit i "") == showbIntAtBase base intToDigit i +-- | Verifies 'showList__' and 'showbListDefault' generate the same output.+prop_showListDefault :: [Char] -> Bool+prop_showListDefault str = fromString (showList__ shows str "") == showbListDefault showb str+ -- | Verifies @showXFloat@ and @showbXFloat@ generate the same output (where @X@ -- is one of E, F, or G). prop_showXFloat :: (Maybe Int -> Double -> ShowS) -> (Maybe Int -> Double -> Builder) -> Maybe Int -> Double -> Bool@@ -184,12 +190,12 @@ , 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 "IntMap Char instance" (prop_matchesShow :: Int -> IntMap Char -> 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)+ , testProperty "Map Char Char instance" (prop_matchesShow :: Int -> Map Char Char -> Bool)+ , testProperty "Sequence Char" (prop_matchesShow :: Int -> Seq Char -> Bool)+ , testProperty "Set Char instance" (prop_matchesShow :: Int -> Set Char -> Bool)+ , testProperty "Tree Char instance" (prop_matchesShow :: Int -> Tree Char -> Bool) ] , testGroup "Text.Show.Text.Data.Data" [ testProperty "Constr instance" (prop_matchesShow :: Int -> Constr -> Bool)@@ -248,6 +254,7 @@ [ testProperty "String instance" (prop_matchesShow :: Int -> String -> Bool) , testProperty "[String] instance" (prop_matchesShow :: Int -> [String] -> Bool) , testProperty "[Int] instance" (prop_matchesShow :: Int -> [Int] -> Bool)+ , testProperty "showbListDefault output" prop_showListDefault ] , testGroup "Text.Show.Text.Data.Maybe" [ testProperty "Maybe Int instance" (prop_matchesShow :: Int -> Maybe Int -> Bool)@@ -299,8 +306,8 @@ #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 "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)
+ tests/Properties/MkShow.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Properties.BaseAndFriends+-- Copyright : (C) 2014 Ryan Scott+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Ryan Scott+-- Stability : Experimental+-- Portability : GHC+-- +-- @QuickCheck@ properties for 'mkShow' and related functions in+-- "Text.Show.Text.TH".+----------------------------------------------------------------------------+module Properties.MkShow (mkShowTests) where++import qualified Data.Text as TS (pack)+import qualified Data.Text.Lazy as TL (pack)+import Data.Text.Lazy.Builder (fromString)++import Instances.Derived++import Test.QuickCheck.Modifiers (Large)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import Text.Show.Text.TH++-- | Verifies 'mkShow' (and related functions) produce the same output as their+-- 'String' counterparts. This uses a data type that is a 'Show' instance.+prop_mkShowIsInstance :: Int -> AllAtOnce Int Int Int Int -> Bool+prop_mkShowIsInstance p a =+ TS.pack (show a ) == $(mkShow ''AllAtOnce) a+ && TL.pack (show a ) == $(mkShowLazy ''AllAtOnce) a+ && TS.pack (showsPrec p a "") == $(mkShowPrec ''AllAtOnce) p a+ && TL.pack (showsPrec p a "") == $(mkShowPrecLazy ''AllAtOnce) p a+ && fromString (show a ) == $(mkShowb ''AllAtOnce) a+ && fromString (showsPrec p a "") == $(mkShowbPrec ''AllAtOnce) p a++-- | Verifies 'mkShow' (and related functions) produce the same output as their+-- 'String' counterparts. This uses a data type that is not a 'Show' instance.+prop_mkShowIsNotInstance :: Int -> Large Int -> Bool+prop_mkShowIsNotInstance p a =+ TS.pack (show a ) == $(mkShow ''Large) a+ && TL.pack (show a ) == $(mkShowLazy ''Large) a+ && TS.pack (showsPrec p a "") == $(mkShowPrec ''Large) p a+ && TL.pack (showsPrec p a "") == $(mkShowPrecLazy ''Large) p a+ && fromString (show a ) == $(mkShowb ''Large) a+ && fromString (showsPrec p a "") == $(mkShowbPrec ''Large) p a++-- prop_mkPrintIsInstance+-- prop_mkPrintIsNotInstance++mkShowTests :: [TestTree]+mkShowTests =+ [ testGroup "mkShow and related functions"+ [ testProperty "$(mkShow ''AllAtOnce) (a Show instance)" prop_mkShowIsInstance+ , testProperty "$(mkShow ''Large) (not a Show instance)" prop_mkShowIsNotInstance+-- , testProperty "$(mkPrint ''AllAtOnce) (a Show instance)" prop_mkPrintIsInstance+-- , testProperty "$(mkPrint ''Large) (not a Show instance)" prop_mkPrintIsNotInstance+ ]+ ]
text-show.cabal view
@@ -1,5 +1,5 @@ name: text-show-version: 0.3.0.0+version: 0.3.1.0 synopsis: Efficient conversion of values into Text description: @text-show@ offers a replacement for the @Show@ typeclass intended for use with @Text@ instead of @String@s. This package was created@@ -23,12 +23,13 @@ @ {-# LANGUAGE NoImplicitPrelude #-} module Main where+ . import Data.Text (Text) import Prelude hiding (Show(..), print) import Text.Show.Text . number :: Text- number = show 27+ number = show (Just \"Hello, World!\") . main :: IO () main = print number@@ -100,6 +101,7 @@ Text.Show.Text.Instances Text.Show.Text.System Text.Show.Text.Text+ Text.Show.Text.TH.Internal Text.Show.Text.Utils build-depends: array >= 0.3 && < 0.6 , base >= 4.2 && < 5@@ -131,6 +133,7 @@ Instances.Derived Properties.BaseAndFriends Properties.Derived+ Properties.MkShow Properties.Utils hs-source-dirs: tests build-depends: array >= 0.3 && < 0.6