[Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal

Oleg Grenrus (@phadej) gitlab at gitlab.haskell.org
Wed Dec 6 17:06:04 UTC 2023



Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC


Commits:
efced8b8 by Oleg Grenrus at 2023-12-06T19:05:44+02:00
Move definitions of SNat, SChar and SSymbol to ghc-internal

... and expose their constructors there

- - - - -


5 changed files:

- libraries/base/src/GHC/TypeLits.hs
- libraries/base/src/GHC/TypeNats.hs
- libraries/ghc-internal/ghc-internal.cabal
- + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs
- + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs


Changes:

=====================================
libraries/base/src/GHC/TypeLits.hs
=====================================
@@ -12,11 +12,15 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RoleAnnotations #-}
 
+-- orphan instances for SChar and SSymbol
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 {-|
 GHC's @DataKinds@ language extension lifts data constructors, natural
 numbers, and strings to the type level. This module provides the
@@ -90,6 +94,8 @@ import Unsafe.Coerce(unsafeCoerce)
 import GHC.TypeLits.Internal(CmpSymbol, CmpChar)
 import qualified GHC.TypeNats as N
 
+import "ghc-internal" GHC.TypeLits.Internal
+
 --------------------------------------------------------------------------------
 
 -- | This class gives the string associated with a type-level symbol.
@@ -325,24 +331,6 @@ withSomeSNat n k
   | n >= 0    = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn))
   | otherwise = k Nothing
 
--- | A value-level witness for a type-level symbol. This is commonly referred
--- to as a /singleton/ type, as for each @s@, there is a single value that
--- inhabits the type @'SSymbol' s@ (aside from bottom).
---
--- The definition of 'SSymbol' is intentionally left abstract. To obtain an
--- 'SSymbol' value, use one of the following:
---
--- 1. The 'symbolSing' method of 'KnownSymbol'.
---
--- 2. The @SSymbol@ pattern synonym.
---
--- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a
---    'String'.
---
--- @since 4.18.0.0
-newtype SSymbol (s :: Symbol) = UnsafeSSymbol String
-type role SSymbol nominal
-
 -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a
 -- 'KnownSymbol' constraint.
 --
@@ -377,14 +365,6 @@ data KnownSymbolInstance (s :: Symbol) where
 knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s
 knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance
 
--- | @since 4.19.0.0
-instance Eq (SSymbol s) where
-  _ == _ = True
-
--- | @since 4.19.0.0
-instance Ord (SSymbol s) where
-  compare _ _ = EQ
-
 -- | @since 4.18.0.0
 instance Show (SSymbol s) where
   showsPrec p (UnsafeSSymbol s)
@@ -429,22 +409,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s)
 -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats"
 -- The issue described there applies to `withSomeSSymbol` as well.
 
--- | A value-level witness for a type-level character. This is commonly referred
--- to as a /singleton/ type, as for each @c@, there is a single value that
--- inhabits the type @'SChar' c@ (aside from bottom).
---
--- The definition of 'SChar' is intentionally left abstract. To obtain an
--- 'SChar' value, use one of the following:
---
--- 1. The 'charSing' method of 'KnownChar'.
---
--- 2. The @SChar@ pattern synonym.
---
--- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'.
---
--- @since 4.18.0.0
-newtype SChar (s :: Char) = UnsafeSChar Char
-type role SChar nominal
+
 
 -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a
 -- 'KnownChar' constraint.
@@ -480,14 +445,6 @@ data KnownCharInstance (n :: Char) where
 knownCharInstance :: SChar c -> KnownCharInstance c
 knownCharInstance sc = withKnownChar sc KnownCharInstance
 
--- | @since 4.19.0.0
-instance Eq (SChar c) where
-  _ == _ = True
-
--- | @since 4.19.0.0
-instance Ord (SChar c) where
-  compare _ _ = EQ
-
 -- | @since 4.18.0.0
 instance Show (SChar c) where
   showsPrec p (UnsafeSChar c)


=====================================
libraries/base/src/GHC/TypeNats.hs
=====================================
@@ -14,10 +14,14 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RoleAnnotations #-}
 
+-- orphan instances for SNat
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 {-| This module is an internal GHC module.  It declares the constants used
 in the implementation of type-level natural numbers.  The programmer interface
 for working with type-level naturals should be defined in a separate library.
@@ -67,6 +71,8 @@ import Unsafe.Coerce(unsafeCoerce)
 
 import GHC.TypeNats.Internal(CmpNat)
 
+import "ghc-internal" GHC.TypeNats.Internal
+
 -- | A type synonym for 'Natural'.
 --
 -- Previously, this was an opaque data type, but it was changed to a type
@@ -329,23 +335,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of
 --------------------------------------------------------------------------------
 -- Singleton values
 
--- | A value-level witness for a type-level natural number. This is commonly
--- referred to as a /singleton/ type, as for each @n@, there is a single value
--- that inhabits the type @'SNat' n@ (aside from bottom).
---
--- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat'
--- value, use one of the following:
---
--- 1. The 'natSing' method of 'KnownNat'.
---
--- 2. The @SNat@ pattern synonym.
---
--- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural'
---    number.
---
--- @since 4.18.0.0
-newtype SNat (n :: Nat) = UnsafeSNat Natural
-type role SNat nominal
+
 
 -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a
 -- 'KnownNat' constraint.
@@ -381,14 +371,6 @@ data KnownNatInstance (n :: Nat) where
 knownNatInstance :: SNat n -> KnownNatInstance n
 knownNatInstance sn = withKnownNat sn KnownNatInstance
 
--- | @since 4.19.0.0
-instance Eq (SNat n) where
-  _ == _ = True
-
--- | @since 4.19.0.0
-instance Ord (SNat n) where
-  compare _ _ = EQ
-
 -- | @since 4.18.0.0
 instance Show (SNat n) where
   showsPrec p (UnsafeSNat n)


=====================================
libraries/ghc-internal/ghc-internal.cabal
=====================================
@@ -23,9 +23,10 @@ common warnings
 
 library
     import:           warnings
+
     exposed-modules:
-    other-modules:    Dummy
-    other-extensions:
+        GHC.TypeLits.Internal
+        GHC.TypeNats.Internal
     build-depends:    rts == 1.0.*,
                       ghc-prim >= 0.5.1.0 && < 0.11,
                       ghc-bignum >= 1.0 && < 2.0


=====================================
libraries/ghc-internal/src/GHC/TypeLits/Internal.hs
=====================================
@@ -0,0 +1,62 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RoleAnnotations #-}
+module GHC.TypeLits.Internal (
+  SChar (..),
+  SSymbol (..),
+) where
+
+import GHC.Types (Char, Symbol, Bool (..), Ordering (..))
+import GHC.Classes (Eq (..), Ord (..))
+
+-- | A value-level witness for a type-level character. This is commonly referred
+-- to as a /singleton/ type, as for each @c@, there is a single value that
+-- inhabits the type @'SChar' c@ (aside from bottom).
+--
+-- The definition of 'SChar' is intentionally left abstract. To obtain an
+-- 'SChar' value, use one of the following:
+--
+-- 1. The 'charSing' method of 'KnownChar'.
+--
+-- 2. The @SChar@ pattern synonym.
+--
+-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'.
+--
+-- /since base-4.18.0.0/
+newtype SChar (s :: Char) = UnsafeSChar Char
+type role SChar nominal
+
+-- | /since base-4.19.0.0/
+instance Eq (SChar c) where
+  _ == _ = True
+
+-- | /since base-4.19.0.0/
+instance Ord (SChar c) where
+  compare _ _ = EQ
+
+-- | A value-level witness for a type-level symbol. This is commonly referred
+-- to as a /singleton/ type, as for each @s@, there is a single value that
+-- inhabits the type @'SSymbol' s@ (aside from bottom).
+--
+-- The definition of 'SSymbol' is intentionally left abstract. To obtain an
+-- 'SSymbol' value, use one of the following:
+--
+-- 1. The 'symbolSing' method of 'KnownSymbol'.
+--
+-- 2. The @SSymbol@ pattern synonym.
+--
+-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a
+--    'String'.
+--
+-- /since base-4.18.0.0/
+newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char]
+type role SSymbol nominal
+
+-- | /since base-4.19.0.0/
+instance Eq (SSymbol s) where
+  _ == _ = True
+
+-- | /since base-4.19.0.0/
+instance Ord (SSymbol s) where
+  compare _ _ = EQ


=====================================
libraries/ghc-internal/src/GHC/TypeNats/Internal.hs
=====================================
@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RoleAnnotations #-}
+module GHC.TypeNats.Internal (
+  SNat (..),
+)where
+
+import GHC.Num.Natural(Natural)
+import GHC.Types (Bool (..), Ordering (..))
+import GHC.Classes (Eq (..), Ord (..))
+
+-- | A value-level witness for a type-level natural number. This is commonly
+-- referred to as a /singleton/ type, as for each @n@, there is a single value
+-- that inhabits the type @'SNat' n@ (aside from bottom).
+--
+-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat'
+-- value, use one of the following:
+--
+-- 1. The 'natSing' method of 'KnownNat'.
+--
+-- 2. The @SNat@ pattern synonym.
+--
+-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural'
+--    number.
+--
+-- /since base-4.18.0.0/
+--
+newtype SNat (n :: Natural) = UnsafeSNat Natural
+type role SNat nominal
+
+-- | /since base-4.19.0.0/
+instance Eq (SNat n) where
+  _ == _ = True
+
+-- | /since 4.19.0.0/
+instance Ord (SNat n) where
+  compare _ _ = EQ



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/efced8b830f042b2e24d436bc45e9faa6d11756c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/efced8b830f042b2e24d436bc45e9faa6d11756c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231206/c1d0d8dd/attachment-0001.html>


More information about the ghc-commits mailing list