Merge pull request #57 from haskellari/SNat-SSymbol-SChar-instances

Add instances for `SNat`, `SSymbol`, and `SChar`

some.cabal

@@ -72,6 +72,10 @@ library
       base     >=4.12    && <4.20
     , deepseq  >=1.4.4.0 && <1.6
 
+  if !impl(ghc >= 9.8)
+    build-depends:
+      base-orphans >= 0.9.1 && <0.10
+
   if impl(ghc >=9.0)
     -- these flags may abort compilation with GHC-8.10
     -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295

src/Data/EqP.hs

@@ -20,6 +20,12 @@ import System.Mem.StableName (StableName, eqStableName)
 #if MIN_VERSION_base(4,18,0)
 import Data.Functor.Product (Product (..))
 import Data.Functor.Sum (Sum (..))
+import qualified GHC.TypeLits as TL
+import qualified GHC.TypeNats as TN
+#endif
+
+#if !MIN_VERSION_base(4,19,0)
+import Data.Orphans ()
 #endif
 
 import qualified Type.Reflection as TR
@@ -88,6 +94,17 @@ instance (EqP a, EqP b) => EqP (a :*: b) where
 instance EqP TR.TypeRep where
     eqp x y = TR.SomeTypeRep x == TR.SomeTypeRep y
 
+#if MIN_VERSION_base(4,18,0)
+instance EqP TL.SChar where
+    eqp x y = TL.fromSChar x == TL.fromSChar y
+
+instance EqP TL.SSymbol where
+    eqp x y = TL.fromSSymbol x == TL.fromSSymbol y
+
+instance EqP TN.SNat where
+    eqp x y = TN.fromSNat x == TN.fromSNat y
+#endif
+
 instance EqP Proxy where
     eqp _ _ = True
 

src/Data/GADT/Internal.hs

@@ -27,6 +27,11 @@ import qualified Type.Reflection as TR
 import Data.Kind (Constraint)
 #endif
 
+#if MIN_VERSION_base(4,18,0)
+import qualified GHC.TypeLits as TL
+import qualified GHC.TypeNats as TN
+#endif
+
 -- $setup
 -- >>> :set -XKindSignatures -XGADTs -XTypeOperators -XStandaloneDeriving -XQuantifiedConstraints
 -- >>> import Data.Type.Equality
@@ -68,6 +73,17 @@ instance GShow ((:~~:) a) where
 instance GShow TR.TypeRep where
     gshowsPrec = showsPrec
 
+#if MIN_VERSION_base(4,18,0)
+instance GShow TL.SChar where
+    gshowsPrec = showsPrec
+
+instance GShow TL.SSymbol where
+    gshowsPrec = showsPrec
+
+instance GShow TN.SNat where
+    gshowsPrec = showsPrec
+#endif
+
 --
 -- | >>> gshow (InL Refl :: Sum ((:~:) Int) ((:~:) Bool) Int)
 -- "InL Refl"
@@ -339,6 +355,17 @@ instance (GEq a, GEq b) => GEq (a :*: b) where
 instance GEq TR.TypeRep where
     geq = testEquality
 
+#if MIN_VERSION_base(4,18,0)
+instance GEq TL.SChar where
+    geq = testEquality
+
+instance GEq TL.SSymbol where
+    geq = testEquality
+
+instance GEq TN.SNat where
+    geq = testEquality
+#endif
+
 -------------------------------------------------------------------------------
 -- GCompare
 -------------------------------------------------------------------------------
@@ -426,20 +453,42 @@ instance GCompare ((:~~:) a) where
     gcompare HRefl HRefl = GEQ
 
 instance GCompare TR.TypeRep where
-    gcompare t1 t2 =
-      case testEquality t1 t2 of
-        Just Refl -> GEQ
-        Nothing ->
-          case compare (TR.SomeTypeRep t1) (TR.SomeTypeRep t2) of
-            LT -> GLT
-            GT -> GGT
-            EQ -> error "impossible: 'testEquality' and 'compare' \
-                        \are inconsistent for TypeRep; report this \
-                        \as a GHC bug"
+    gcompare = gcompareSing "TypeRep" TR.SomeTypeRep
+
+#if MIN_VERSION_base(4,18,0)
+instance GCompare TL.SChar where
+    gcompare = gcompareSing "SChar" TL.fromSChar
+
+instance GCompare TL.SSymbol where
+    gcompare = gcompareSing "SSymbol" TL.fromSSymbol
+
+instance GCompare TN.SNat where
+    gcompare = gcompareSing "SNat" TN.fromSNat
+#endif
 
 defaultCompare :: GCompare f => f a -> f b -> Ordering
 defaultCompare x y = weakenOrdering (gcompare x y)
 
+-- | An implementation of 'gcompare' for a singleton type.
+gcompareSing :: (TestEquality f, Ord c)
+             => String
+             -- ^ The name of the singleton type.
+             -- (Only used for error message purposes.)
+             -> (forall x. f x -> c)
+             -- ^ How to turn the singleton type into a value that can be
+             -- compared with 'Ord'.
+             -> f a -> f b -> GOrdering a b
+gcompareSing singName toOrd t1 t2 =
+  case testEquality t1 t2 of
+    Just Refl -> GEQ
+    Nothing ->
+      case compare (toOrd t1) (toOrd t2) of
+        LT -> GLT
+        GT -> GGT
+        EQ -> error $ "impossible: 'testEquality' and 'compare' are inconsistent for "
+                   ++ singName
+                   ++ "; report this as a GHC bug"
+
 instance (GCompare a, GCompare b) => GCompare (Sum a b) where
     gcompare (InL x) (InL y) = gcompare x y
     gcompare (InL _) (InR _) = GLT

src/Data/OrdP.hs

@@ -20,6 +20,12 @@ import GHC.Generics         ((:*:) (..), (:+:) (..))
 #if MIN_VERSION_base(4,18,0)
 import Data.Functor.Product (Product (..))
 import Data.Functor.Sum (Sum (..))
+import qualified GHC.TypeLits as TL
+import qualified GHC.TypeNats as TN
+#endif
+
+#if !MIN_VERSION_base(4,19,0)
+import Data.Orphans ()
 #endif
 
 import qualified Type.Reflection as TR
@@ -75,6 +81,17 @@ instance (OrdP a, OrdP b) => OrdP (a :*: b) where
 instance OrdP TR.TypeRep where
     comparep x y = compare (TR.SomeTypeRep x) (TR.SomeTypeRep y)
 
+#if MIN_VERSION_base(4,18,0)
+instance OrdP TL.SChar where
+    comparep x y = compare (TL.fromSChar x) (TL.fromSChar y)
+
+instance OrdP TL.SSymbol where
+    comparep x y = compare (TL.fromSSymbol x) (TL.fromSSymbol y)
+
+instance OrdP TN.SNat where
+    comparep x y = compare (TN.fromSNat x) (TN.fromSNat y)
+#endif
+
 instance OrdP Proxy where
     comparep _ _ = EQ