[Git][ghc/ghc][wip/eqtycon-rn] Export (~) from Data.Type.Equality (#18862)

Vladislav Zavialov gitlab at gitlab.haskell.org
Sun Oct 18 15:35:07 UTC 2020



Vladislav Zavialov pushed to branch wip/eqtycon-rn at Glasgow Haskell Compiler / GHC


Commits:
8c1aa21f by Vladislav Zavialov at 2020-10-18T18:34:50+03:00
Export (~) from Data.Type.Equality (#18862)

* Users can define their own (~) type operator
* Haddock can display documentation for the built-in (~)

Updates the haddock submodule.

- - - - -


14 changed files:

- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Env.hs
- libraries/base/Data/Type/Equality.hs
- libraries/base/GHC/Exts.hs
- libraries/ghc-prim/GHC/Types.hs
- testsuite/tests/rename/should_fail/T15214.hs → testsuite/tests/rename/should_compile/T15214.hs
- + testsuite/tests/rename/should_compile/T18862.hs
- testsuite/tests/rename/should_compile/all.T
- − testsuite/tests/rename/should_fail/T15214.stderr
- testsuite/tests/rename/should_fail/all.T
- utils/haddock


Changes:

=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -2600,4 +2600,5 @@ pretendNameIsInScope :: Name -> Bool
 pretendNameIsInScope n
   = any (n `hasKey`)
     [ liftedTypeKindTyConKey, tYPETyConKey
-    , runtimeRepTyConKey, liftedRepDataConKey ]
+    , runtimeRepTyConKey, liftedRepDataConKey
+    , eqTyConKey ]


=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -295,18 +295,14 @@ eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelI
 The (~) type operator used in equality constraints (a~b) is considered built-in
 syntax. This has a few consequences:
 
-* The user is not allowed to define their own type constructors with this name:
-
-    ghci> class a ~ b
-    <interactive>:1:1: error: Illegal binding of built-in syntax: ~
-
 * Writing (a ~ b) does not require enabling -XTypeOperators. It does, however,
   require -XGADTs or -XTypeFamilies.
 
 * The (~) type operator is always in scope. It doesn't need to be imported,
   and it cannot be hidden.
 
-* We have a bunch of special cases in the compiler to arrange all of the above.
+In the past, users also could not define their own (~), but this restriction
+has been lifted.
 
 There's no particular reason for (~) to be special, but fixing this would be a
 breaking change.


=====================================
compiler/GHC/Parser.y
=====================================
@@ -87,7 +87,7 @@ import GHC.Parser.Errors
 
 import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
                            unboxedUnitTyCon, unboxedUnitDataCon,
-                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)
+                           listTyCon_RDR, consDataCon_RDR )
 }
 
 %expect 0 -- shift/reduce conflicts
@@ -3517,11 +3517,7 @@ qtyconsym :: { Located RdrName }
 
 tyconsym :: { Located RdrName }
         : CONSYM                { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
-        | VARSYM                { sL1 $1 $!
-                                    -- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types
-                                    if getVARSYM $1 == fsLit "~"
-                                      then eqTyCon_RDR
-                                      else mkUnqual tcClsName (getVARSYM $1) }
+        | VARSYM                { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
         | ':'                   { sL1 $1 $! consDataCon_RDR }
         | '-'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
         | '.'                   { sL1 $1 $! mkUnqual tcClsName (fsLit ".") }


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -121,7 +121,7 @@ import GHC.Utils.Lexeme ( isLexCon )
 import GHC.Core.Type    ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )
 import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
-                          listTyConName, listTyConKey, eqTyCon_RDR )
+                          listTyConName, listTyConKey )
 import GHC.Types.ForeignCall
 import GHC.Types.SrcLoc
 import GHC.Types.Unique ( hasKey )
@@ -2128,8 +2128,7 @@ checkPrecP (L l (_,i)) (L _ ol)
  | otherwise = addFatalError $ Error (ErrPrecedenceOutOfRange i) [] l
   where
     -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs
-    specialOp op = unLoc op `elem` [ eqTyCon_RDR
-                                   , getRdrName unrestrictedFunTyCon ]
+    specialOp op = unLoc op `elem` [ getRdrName unrestrictedFunTyCon ]
 
 mkRecConstrOrUpdate
         :: LHsExpr GhcPs


=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -90,6 +90,7 @@ import qualified Data.Semigroup as Semi
 import Data.Either      ( partitionEithers )
 import Data.List        ( find, sortBy )
 import Control.Arrow    ( first )
+import Control.Applicative ( (<|>) )
 import Data.Function
 
 {-
@@ -963,10 +964,16 @@ lookupTypeOccRn rdr_name
   = badVarInType rdr_name
   | otherwise
   = do { mb_name <- lookupOccRn_maybe rdr_name
-       ; case mb_name of
+       ; case mb_name <|> matchEqTyName rdr_name of
              Just name -> return name
              Nothing   -> lookup_demoted rdr_name }
 
+-- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types
+matchEqTyName :: RdrName -> Maybe Name
+matchEqTyName rdr_name
+  | occName rdr_name == occName eqTyCon_RDR = Just eqTyConName
+  | otherwise = Nothing
+
 lookup_demoted :: RdrName -> RnM Name
 lookup_demoted rdr_name
   | Just demoted_rdr <- demoteRdrName rdr_name
@@ -1153,6 +1160,7 @@ lookupInfoOccRn rdr_name =
   lookupExactOrOrig rdr_name (:[]) $
     do { rdr_env <- getGlobalRdrEnv
        ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)
+                    ++ maybeToList (matchEqTyName rdr_name)
        ; qual_ns <- lookupQualifiedNameGHCi rdr_name
        ; return (ns ++ (qual_ns `minusList` ns)) }
 
@@ -1655,13 +1663,7 @@ dataTcOccs rdr_name
   = [rdr_name]
   where
     occ = rdrNameOcc rdr_name
-    rdr_name_tc =
-      case rdr_name of
-        -- The (~) type operator is always in scope, so we need a special case
-        -- for it here, or else  :info (~)  fails in GHCi.
-        -- See Note [eqTyCon (~) is built-in syntax]
-        Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR
-        _ -> setRdrNameSpace rdr_name tcName
+    rdr_name_tc = setRdrNameSpace rdr_name tcName
 
 {-
 Note [dataTcOccs and Exact Names]


=====================================
libraries/base/Data/Type/Equality.hs
=====================================
@@ -31,7 +31,9 @@
 
 module Data.Type.Equality (
   -- * The equality types
-  (:~:)(..), type (~~),
+  type (~),
+  type (~~),
+  (:~:)(..),
   (:~~:)(..),
 
   -- * Working with equality


=====================================
libraries/base/GHC/Exts.hs
=====================================
@@ -88,6 +88,7 @@ module GHC.Exts
         unsafeCoerce#,
 
         -- * Equality
+        type (~),
         type (~~),
 
         -- * Representation polymorphism


=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -32,7 +32,7 @@ module GHC.Types (
         SPEC(..),
         Symbol,
         Any,
-        type (~~), Coercible,
+        type (~), type (~~), Coercible,
         TYPE, RuntimeRep(..), Type, Constraint,
           -- The historical type * should ideally be written as
           -- `type *`, without the parentheses. But that's a true
@@ -225,7 +225,6 @@ newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
 *                                                                      *
                     (~) and Coercible
 
-   NB: (~) is built-in syntax, and hence not explicitly exported
 *                                                                      *
 ********************************************************************* -}
 


=====================================
testsuite/tests/rename/should_fail/T15214.hs → testsuite/tests/rename/should_compile/T15214.hs
=====================================


=====================================
testsuite/tests/rename/should_compile/T18862.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE PolyKinds, DataKinds, TypeOperators, TypeFamilies #-}
+
+module T18862 where
+
+import Data.Kind (Constraint)
+import qualified Data.Type.Equality as E
+
+type family (a :: k) ~ (b :: k) :: result_kind
+
+type instance a ~ b = (a E.~ b :: Constraint)
+type instance a ~ b = (a E.== b :: Bool)


=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -162,6 +162,7 @@ test('T14881', [], multimod_compile, ['T14881', '-W'])
 test('T14487', [], multimod_compile, ['T14487', '-v0'])
 test('T14747', [], multimod_compile, ['T14747', '-v0'])
 test('T15149', [], multimod_compile, ['T15149', '-v0'])
+test('T15214', normal, compile, [''])
 test('T13064', normal, compile, [''])
 test('T15994', [], makefile_test, ['T15994'])
 test('T15798a', normal, compile, [''])
@@ -177,3 +178,4 @@ test('T17837', normal, compile, [''])
 test('T18497', [], makefile_test, ['T18497'])
 test('T18264', [], makefile_test, ['T18264'])
 test('T18302', expect_broken(18302), compile, [''])
+test('T18862', normal, compile, [''])


=====================================
testsuite/tests/rename/should_fail/T15214.stderr deleted
=====================================
@@ -1,2 +0,0 @@
-
-T15214.hs:4:1: error: Illegal binding of built-in syntax: ~


=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -135,7 +135,6 @@ test('T14307', normal, compile_fail, [''])
 test('T14591', normal, compile_fail, [''])
 test('T14907a', normal, compile_fail, [''])
 test('T14907b', normal, compile_fail, [''])
-test('T15214', normal, compile_fail, [''])
 test('T15539', normal, compile_fail, [''])
 test('T15487', normal, multimod_compile_fail, ['T15487','-v0'])
 test('T15659', normal, compile_fail, [''])


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit f7d9e0bb987ca31c3b15cbe63198dafbeee3a395
+Subproject commit 75226997a379981cf2e343e166094887bb3a8295



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c1aa21f2dc3858e09e0432ee38bdb3f3c01bd5a
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/20201018/f3ab902e/attachment-0001.html>


More information about the ghc-commits mailing list