Add TextShow instances for SomeChar and S{Nat,Symbol,Char}

CHANGELOG.md

@@ -1,5 +1,8 @@
 ### next [????.??.??]
 * Allow building with GHC 9.6.
+* Add `TextShow` instances for `SomeChar` (if building with `base-4.16` or
+  later), as well as `SNat`, `SSymbol`, and `SChar` (if building with
+  `base-4.18` or later).
 
 ### 3.10.1 [2023.02.27]
 * Support `th-abstraction-0.5.*`.

src/TextShow/GHC/TypeLits.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-|
 Module:      TextShow.GHC.TypeLits
@@ -14,6 +15,9 @@ Portability: GHC
 module TextShow.GHC.TypeLits () where
 
 import GHC.TypeLits (SomeNat(..), SomeSymbol(..), natVal, symbolVal)
+#if MIN_VERSION_base(4,16,0)
+import GHC.TypeLits (SomeChar(..), charVal)
+#endif
 
 import Prelude ()
 import Prelude.Compat
@@ -22,6 +26,15 @@ import TextShow.Classes (TextShow(..))
 import TextShow.Data.Char ()
 import TextShow.Data.Integral ()
 
+#if MIN_VERSION_base(4,18,0)
+import Data.Text.Lazy.Builder (fromString)
+import GHC.Show (appPrec, appPrec1)
+import GHC.TypeLits ( SNat, SSymbol, SChar
+                    , fromSNat, fromSSymbol, fromSChar
+                    )
+import TextShow.Classes (showbParen)
+#endif
+
 -- | /Since: 2/
 instance TextShow SomeNat where
     showbPrec p (SomeNat x) = showbPrec p $ natVal x
@@ -31,3 +44,36 @@ instance TextShow SomeNat where
 instance TextShow SomeSymbol where
     showb (SomeSymbol x) = showbList $ symbolVal x
     {-# INLINE showb #-}
+
+#if MIN_VERSION_base(4,16,0)
+-- | /Since: 3.10.1/
+instance TextShow SomeChar where
+    showbPrec p (SomeChar x) = showbPrec p $ charVal x
+    {-# INLINE showbPrec #-}
+#endif
+
+#if MIN_VERSION_base(4,18,0)
+-- | /Since: 3.10.1/
+instance TextShow (SNat n) where
+  showbPrec p sn
+    = showbParen (p > appPrec)
+      ( fromString "SNat @"
+     <> showbPrec appPrec1 (fromSNat sn)
+      )
+
+-- | /Since: 3.10.1/
+instance TextShow (SSymbol s) where
+  showbPrec p ss
+    = showbParen (p > appPrec)
+      ( fromString "SSymbol @"
+     <> showbList (fromSSymbol ss)
+      )
+
+-- | /Since: 3.10.1/
+instance TextShow (SChar c) where
+  showbPrec p sc
+    = showbParen (p > appPrec)
+      ( fromString "SChar @"
+     <> showbPrec appPrec1 (fromSChar sc)
+      )
+#endif

tests/Instances/GHC/TypeLits.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -19,6 +20,12 @@ import Prelude ()
 import Prelude.Compat
 
 import Test.QuickCheck (Arbitrary(..), getNonNegative)
+import Test.QuickCheck.Instances ()
+
+#if MIN_VERSION_base(4,18,0)
+import qualified GHC.TypeNats as TN
+import Spec.Utils (GArbitrary(..), Some(..))
+#endif
 
 instance Arbitrary SomeNat where
     arbitrary = do
@@ -29,3 +36,25 @@ instance Arbitrary SomeNat where
 
 instance Arbitrary SomeSymbol where
     arbitrary = someSymbolVal <$> arbitrary
+
+#if MIN_VERSION_base(4,16,0)
+instance Arbitrary SomeChar where
+    arbitrary = someCharVal <$> arbitrary
+#endif
+
+#if MIN_VERSION_base(4,18,0)
+instance GArbitrary SNat where
+  garbitrary = do
+    n <- arbitrary
+    TN.withSomeSNat n (pure . Some)
+
+instance GArbitrary SSymbol where
+  garbitrary = do
+    s <- arbitrary
+    withSomeSSymbol s (pure . Some)
+
+instance GArbitrary SChar where
+  garbitrary = do
+    c <- arbitrary
+    withSomeSChar c (pure . Some)
+#endif

tests/Spec/GHC/TypeLitsSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 
 {-|
@@ -22,6 +23,9 @@ import Prelude ()
 import Prelude.Compat
 
 import Spec.Utils (matchesTextShowSpec)
+#if MIN_VERSION_base(4,18,0)
+import Spec.Utils (Some)
+#endif
 
 import Test.Hspec (Spec, describe, hspec, parallel)
 
@@ -34,3 +38,15 @@ spec = parallel $ do
         matchesTextShowSpec (Proxy :: Proxy SomeNat)
     describe "SomeSymbol" $
         matchesTextShowSpec (Proxy :: Proxy SomeSymbol)
+#if MIN_VERSION_base(4,16,0)
+    describe "SomeChar" $
+        matchesTextShowSpec (Proxy :: Proxy SomeChar)
+#endif
+#if MIN_VERSION_base(4,18,0)
+    describe "Some SNat" $
+        matchesTextShowSpec (Proxy :: Proxy (Some SNat))
+    describe "Some SSymbol" $
+        matchesTextShowSpec (Proxy :: Proxy (Some SSymbol))
+    describe "Some SChar" $
+        matchesTextShowSpec (Proxy :: Proxy (Some SChar))
+#endif

tests/Spec/Utils.hs

@@ -1,6 +1,13 @@
-{-# LANGUAGE CPP                 #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE QuantifiedConstraints #-}
+#endif
 
 {-|
 Module:      Spec.Utils
@@ -21,6 +28,9 @@ module Spec.Utils (
 #endif
     , genericTextShowSpec
     , genericTextShow1Spec
+
+    , Some(..)
+    , GArbitrary(..)
     ) where
 
 import Data.Functor.Classes (Show1, showsPrec1)
@@ -30,7 +40,7 @@ import Generics.Deriving.Base
 
 import Test.Hspec (Expectation, Spec, shouldBe)
 import Test.Hspec.QuickCheck (prop)
-import Test.QuickCheck (Arbitrary)
+import Test.QuickCheck (Arbitrary(..), Gen)
 
 import TextShow (TextShow(..), TextShow1(..), showbPrec1, fromString)
 import TextShow.Generic
@@ -40,6 +50,11 @@ import Data.Functor.Classes (Show2, showsPrec2)
 import TextShow (TextShow2(..), showbPrec2)
 #endif
 
+#if __GLASGOW_HASKELL__ >= 806
+import GHC.Show (appPrec, appPrec1)
+import TextShow (showbParen, showbSpace)
+#endif
+
 -- | Expect a type's 'Show' instances to coincide for both 'String's and 'Text',
 -- irrespective of precedence.
 matchesTextShowSpec :: forall a. (Arbitrary a, Show a, TextShow a)
@@ -107,3 +122,22 @@ prop_genericTextShow1 :: ( TextShow1 f, Generic1 f
                       => Int -> f a -> Expectation
 prop_genericTextShow1 p x =
     showbPrec1 p x `shouldBe` genericLiftShowbPrec showbPrec showbList p x
+
+-- | A data type that existentially closes over something.
+data Some t where
+  Some :: t a -> Some t
+
+#if __GLASGOW_HASKELL__ >= 806
+deriving instance (forall a. Show (t a)) => Show (Some t)
+instance (forall a. TextShow (t a)) => TextShow (Some t) where
+  showbPrec p (Some x) =
+    showbParen (p > appPrec) $
+    fromString "Some" <> showbSpace <> showbPrec appPrec1 x
+#endif
+
+instance GArbitrary t => Arbitrary (Some t) where
+  arbitrary = garbitrary
+
+-- | An 'Arbitrary'-like class for 1-type-parameter GADTs.
+class GArbitrary t where
+  garbitrary :: Gen (Some t)