diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## 3.7 [2017.12.07] +* Use `EmptyCase` on GHC 7.8 or later for `TextShow(1)` instances for empty data types that are derived using `TextShow.Generic`. +* Derived `TextShow(1)(2)` instances (using `TextShow.TH`) will now force their argument instead of simply `error`ing. +* Add `emptyCaseBehavior` to `Options`, which configures whether derived instances (using `TextShow.TH`) for empty data types should use the `EmptyCase` extension (this is disabled by default). + ### 3.6.2 [2017.06.18] * Drop support for GHC 7.0 and 7.2 * Require `QuickCheck-2.10`/`quickcheck-instances-0.13.6` or later diff --git a/src/TextShow/Generic.hs b/src/TextShow/Generic.hs --- a/src/TextShow/Generic.hs +++ b/src/TextShow/Generic.hs @@ -21,6 +21,10 @@ {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +#endif + #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} #endif @@ -325,12 +329,18 @@ hash_prec = id #endif +#if __GLASGOW_HASKELL__ >= 708 +#define EMPTY_CASE(x) case x of {} +#else +#define EMPTY_CASE(x) case x of !_ -> undefined +#endif + #define GTEXT_SHOW(text_type,show_funs,no_show_funs,show1_funs,one_hash,two_hash,hash_prec,gtext_show,gshow_prec,gtext_show_con,gshow_prec_con,show_prec,lift_show_prec,show_space,show_paren,show_list_with,from_char,from_string) \ {- | A 'show_funs' value either stores nothing (for 'TextShow') or it stores \ the two function arguments that show occurrences of the type parameter (for \ 'TextShow1'). \ \ -/Since: 3.4/ \ +/Since: 3.4/ \ -}; \ data show_funs arity a where { \ no_show_funs :: show_funs Zero a \ @@ -347,7 +357,7 @@ used. @'gtext_show' 'Zero'@ indicates 'TextShow' behavior, and \ @'gtext_show' 'One'@ indicates 'TextShow1' behavior. \ \ -/Since: 3.4/ \ +/Since: 3.4/ \ -}; \ class gtext_show arity f where { \ {- | This is used as the default generic implementation of 'show_prec' (if the \ @@ -363,11 +373,11 @@ }; \ \ instance gtext_show Zero V1 where { \ - gshow_prec _ _ !_ = error "Void show_prec" \ + gshow_prec _ _ x = EMPTY_CASE(x) \ }; \ \ instance gtext_show One V1 where { \ - gshow_prec _ _ !_ = error "Void lift_show_prec" \ + gshow_prec _ _ x = EMPTY_CASE(x) \ }; \ \ instance (gtext_show arity f, gtext_show arity g) => gtext_show arity (f :+: g) where { \ diff --git a/src/TextShow/Options.hs b/src/TextShow/Options.hs --- a/src/TextShow/Options.hs +++ b/src/TextShow/Options.hs @@ -18,7 +18,7 @@ #endif {-| -Module: TextShow.FromStringTextShow +Module: TextShow.Options Copyright: (C) 2014-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott @@ -41,10 +41,20 @@ -- | Options that specify how to derive 'TextShow' instances using Template Haskell. -- -- /Since: 3.4/ -newtype Options = Options +data Options = Options { genTextMethods :: GenTextMethods -- ^ When Template Haskell should generate definitions for methods which -- return @Text@? + -- + -- /Since: 3.4/ + , emptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + -- + -- /Since: 3.7/ } deriving ( Data , Eq , Generic @@ -84,7 +94,10 @@ -- -- /Since: 3.4/ defaultOptions :: Options -defaultOptions = Options { genTextMethods = SometimesTextMethods } +defaultOptions = + Options { genTextMethods = SometimesTextMethods + , emptyCaseBehavior = False + } ------------------------------------------------------------------------------- diff --git a/src/TextShow/TH/Internal.hs b/src/TextShow/TH/Internal.hs --- a/src/TextShow/TH/Internal.hs +++ b/src/TextShow/TH/Internal.hs @@ -349,14 +349,14 @@ -- -- /Since: 2/ makeShowtPrec :: Name -> Q Exp -makeShowtPrec = makeShowbPrecClass TextShow ShowtPrec +makeShowtPrec = makeShowbPrecClass TextShow ShowtPrec defaultOptions -- | Generates a lambda expression which behaves like 'showtlPrec' (without -- requiring a 'TextShow' instance). -- -- /Since: 2/ makeShowtlPrec :: Name -> Q Exp -makeShowtlPrec = makeShowbPrecClass TextShow ShowtlPrec +makeShowtlPrec = makeShowbPrecClass TextShow ShowtlPrec defaultOptions -- | Generates a lambda expression which behaves like 'showtList' (without requiring a -- 'TextShow' instance). @@ -384,14 +384,14 @@ -- -- /Since: 2/ makeShowbPrec :: Name -> Q Exp -makeShowbPrec = makeShowbPrecClass TextShow ShowbPrec +makeShowbPrec = makeShowbPrecClass TextShow ShowbPrec defaultOptions -- | Generates a lambda expression which behaves like 'liftShowbPrec' (without -- requiring a 'TextShow1' instance). -- -- /Since: 3/ makeLiftShowbPrec :: Name -> Q Exp -makeLiftShowbPrec = makeShowbPrecClass TextShow1 ShowbPrec +makeLiftShowbPrec = makeShowbPrecClass TextShow1 ShowbPrec defaultOptions -- | Generates a lambda expression which behaves like 'showbPrec1' (without -- requiring a 'TextShow1' instance). @@ -405,7 +405,7 @@ -- -- /Since: 3/ makeLiftShowbPrec2 :: Name -> Q Exp -makeLiftShowbPrec2 = makeShowbPrecClass TextShow2 ShowbPrec +makeLiftShowbPrec2 = makeShowbPrecClass TextShow2 ShowbPrec defaultOptions -- | Generates a lambda expression which behaves like 'showbPrec2' (without -- requiring a 'TextShow2' instance). @@ -491,15 +491,15 @@ genMethod method methodName = funD methodName [ clause [] - (normalB $ makeTextShowForCons tsClass method vars cons) + (normalB $ makeTextShowForCons tsClass method opts vars cons) [] ] -- | Generates a lambda expression which behaves like showbPrec (for TextShow), -- liftShowbPrec (for TextShow1), or liftShowbPrec2 (for TextShow2). -makeShowbPrecClass :: TextShowClass -> TextShowFun -> Name -> Q Exp -makeShowbPrecClass tsClass tsFun name = do +makeShowbPrecClass :: TextShowClass -> TextShowFun -> Options -> Name -> Q Exp +makeShowbPrecClass tsClass tsFun opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt @@ -512,14 +512,13 @@ -- or not the provided datatype can actually have showbPrec/liftShowbPrec/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance tsClass parentName ctxt vars variant - `seq` makeTextShowForCons tsClass tsFun vars cons + >> makeTextShowForCons tsClass tsFun opts vars cons -- | Generates a lambda expression for showbPrec/liftShowbPrec/etc. for the -- given constructors. All constructors must be from the same type. -makeTextShowForCons :: TextShowClass -> TextShowFun -> [Type] -> [ConstructorInfo] +makeTextShowForCons :: TextShowClass -> TextShowFun -> Options -> [Type] -> [ConstructorInfo] -> Q Exp -makeTextShowForCons _ _ _ [] = error "Must have at least one data constructor" -makeTextShowForCons tsClass tsFun vars cons = do +makeTextShowForCons tsClass tsFun opts vars cons = do p <- newName "p" value <- newName "value" sps <- newNameList "sp" $ fromEnum tsClass @@ -528,13 +527,33 @@ spsAndSls = interleave sps sls lastTyVars = map varTToName $ drop (length vars - fromEnum tsClass) vars splMap = Map.fromList $ zip lastTyVars spls - matches <- mapM (makeTextShowForCon p tsClass tsFun splMap) cons + + makeFun + | null cons && emptyCaseBehavior opts && ghc7'8OrLater + = caseE (varE value) [] + + | null cons + = appE (varE 'seq) (varE value) `appE` + appE (varE 'error) + (stringE $ "Void " ++ nameBase (showPrecName tsClass tsFun)) + + | otherwise + = caseE (varE value) + (map (makeTextShowForCon p tsClass tsFun splMap) cons) + lamE (map varP $ spsAndSls ++ [p, value]) . appsE $ [ varE $ showPrecConstName tsClass tsFun - , caseE (varE value) (map return matches) + , makeFun ] ++ map varE spsAndSls ++ [varE p, varE value] + where + ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 + ghc7'8OrLater = True +#else + ghc7'8OrLater = False +#endif -- | Generates a lambda expression for howbPrec/liftShowbPrec/etc. for a -- single constructor. diff --git a/tests/Instances/Options.hs b/tests/Instances/Options.hs --- a/tests/Instances/Options.hs +++ b/tests/Instances/Options.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| @@ -14,10 +12,12 @@ -} module Instances.Options () where +import Instances.Utils.GenericArbitrary (genericArbitrary) import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum) import TextShow.TH (Options(..), GenTextMethods) -deriving instance Arbitrary Options +instance Arbitrary Options where + arbitrary = genericArbitrary instance Arbitrary GenTextMethods where arbitrary = arbitraryBoundedEnum 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: 3.6.2 +version: 3.7 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 @@ -49,7 +49,7 @@ , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 - , GHC == 8.2.1 + , GHC == 8.2.2 extra-source-files: CHANGELOG.md, README.md, include/*.h cabal-version: >=1.10 @@ -336,6 +336,8 @@ -- Only exports tests if base >= 4.9 Spec.GHC.StackSpec + + TextShow.TH.Names build-depends: array >= 0.3 && < 0.6 , base-compat >= 0.8.2 && < 1 , base-orphans >= 0.6 && < 0.7