diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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 @@ -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 () diff --git a/src/Text/Show/Text/Class.hs b/src/Text/Show/Text/Class.hs --- a/src/Text/Show/Text/Class.hs +++ b/src/Text/Show/Text/Class.hs @@ -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 diff --git a/src/Text/Show/Text/Data/Array.hs b/src/Text/Show/Text/Data/Array.hs --- a/src/Text/Show/Text/Data/Array.hs +++ b/src/Text/Show/Text/Data/Array.hs @@ -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 diff --git a/src/Text/Show/Text/Data/ByteString.hs b/src/Text/Show/Text/Data/ByteString.hs --- a/src/Text/Show/Text/Data/ByteString.hs +++ b/src/Text/Show/Text/Data/ByteString.hs @@ -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 diff --git a/src/Text/Show/Text/Data/Containers.hs b/src/Text/Show/Text/Data/Containers.hs --- a/src/Text/Show/Text/Data/Containers.hs +++ b/src/Text/Show/Text/Data/Containers.hs @@ -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 #-} diff --git a/src/Text/Show/Text/Data/Text.hs b/src/Text/Show/Text/Data/Text.hs --- a/src/Text/Show/Text/Data/Text.hs +++ b/src/Text/Show/Text/Data/Text.hs @@ -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 diff --git a/src/Text/Show/Text/TH.hs b/src/Text/Show/Text/TH.hs --- a/src/Text/Show/Text/TH.hs +++ b/src/Text/Show/Text/TH.hs @@ -1,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 diff --git a/src/Text/Show/Text/TH/Internal.hs b/src/Text/Show/Text/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/TH/Internal.hs @@ -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 diff --git a/tests/Instances/BaseAndFriends.hs b/tests/Instances/BaseAndFriends.hs --- a/tests/Instances/BaseAndFriends.hs +++ b/tests/Instances/BaseAndFriends.hs @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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 diff --git a/tests/Properties/BaseAndFriends.hs b/tests/Properties/BaseAndFriends.hs --- a/tests/Properties/BaseAndFriends.hs +++ b/tests/Properties/BaseAndFriends.hs @@ -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) diff --git a/tests/Properties/MkShow.hs b/tests/Properties/MkShow.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/MkShow.hs @@ -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 + ] + ] diff --git a/text-show.cabal b/text-show.cabal --- a/text-show.cabal +++ b/text-show.cabal @@ -1,5 +1,5 @@ name: text-show -version: 0.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