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

* Users can define their own (~) type operator
* Haddock can display documentation for the built-in (~)
* New transitional warnings implemented:
    -Wtype-equality-out-of-scope
    -Wtype-equality-requires-operators

Updates the haddock submodule.

13 files changed, 111 insertions, 59 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 9b1c9bad01..e17f2dda44 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -2770,4 +2770,5 @@ pretendNameIsInScope n
     [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey
     , liftedDataConKey, unliftedDataConKey
     , tYPETyConKey
-    , runtimeRepTyConKey, boxedRepDataConKey ]
+    , runtimeRepTyConKey, boxedRepDataConKey
+    , eqTyConKey ]
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 347afad5c0..54354fcd5f 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -343,27 +343,6 @@ eqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~")   eqTyConK
 eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon
 eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId
 
-{- Note [eqTyCon (~) is built-in syntax]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-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.
-
-There's no particular reason for (~) to be special, but fixing this would be a
-breaking change.
--}
 eqTyCon_RDR :: RdrName
 eqTyCon_RDR = nameRdrName eqTyConName
 
@@ -893,9 +872,6 @@ isBuiltInOcc_maybe occ =
       "[]" -> Just $ choose_ns listTyConName nilDataConName
       ":"    -> Just consDataConName
 
-      -- equality tycon
-      "~"    -> Just eqTyConName
-
       -- function tycon
       "FUN"  -> Just funTyConName
       "->"  -> Just unrestrictedFunTyConName
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 21649c9c54..1d1222fbab 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -553,6 +553,8 @@ data WarningFlag =
    | Opt_WarnForallIdentifier                        -- Since 9.4
    | Opt_WarnUnicodeBidirectionalFormatCharacters    -- Since 9.0.2
    | Opt_WarnGADTMonoLocalBinds                      -- Since 9.4
+   | Opt_WarnTypeEqualityOutOfScope                  -- Since 9.4
+   | Opt_WarnTypeEqualityRequiresOperators           -- Since 9.4
    deriving (Eq, Ord, Show, Enum)
 
 -- | Return the names of a WarningFlag
@@ -655,6 +657,8 @@ warnFlagNames wflag = case wflag of
   Opt_WarnForallIdentifier                        -> "forall-identifier" :| []
   Opt_WarnUnicodeBidirectionalFormatCharacters    -> "unicode-bidirectional-format-characters" :| []
   Opt_WarnGADTMonoLocalBinds                      -> "gadt-mono-local-binds" :| []
+  Opt_WarnTypeEqualityOutOfScope                  -> "type-equality-out-of-scope" :| []
+  Opt_WarnTypeEqualityRequiresOperators           -> "type-equality-requires-operators" :| []
 
 -- -----------------------------------------------------------------------------
 -- Standard sets of warning options
@@ -748,7 +752,8 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnOperatorWhitespaceExtConflict,
         Opt_WarnForallIdentifier,
         Opt_WarnUnicodeBidirectionalFormatCharacters,
-        Opt_WarnGADTMonoLocalBinds
+        Opt_WarnGADTMonoLocalBinds,
+        Opt_WarnTypeEqualityRequiresOperators
       ]
 
 -- | Things you get with -W
@@ -801,6 +806,7 @@ minusWcompatOpts
       , Opt_WarnNonCanonicalMonoidInstances
       , Opt_WarnStarIsType
       , Opt_WarnCompatUnqualifiedImports
+      , Opt_WarnTypeEqualityOutOfScope
       ]
 
 -- | Things you get with -Wunused-binds
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 49e322bbd2..d62660c519 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3295,7 +3295,9 @@ wWarningFlagsDeps = mconcat [
   warnSpec    Opt_WarnMissingExportedPatternSynonymSignatures,
   warnSpec    Opt_WarnForallIdentifier,
   warnSpec    Opt_WarnUnicodeBidirectionalFormatCharacters,
-  warnSpec    Opt_WarnGADTMonoLocalBinds
+  warnSpec    Opt_WarnGADTMonoLocalBinds,
+  warnSpec    Opt_WarnTypeEqualityOutOfScope,
+  warnSpec    Opt_WarnTypeEqualityRequiresOperators
  ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index a11a438d89..24ef753453 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -90,7 +90,7 @@ import GHC.Parser.Errors.Ppr ()
 import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,
                            tupleTyCon, tupleDataCon, nilDataCon,
                            unboxedUnitTyCon, unboxedUnitDataCon,
-                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)
+                           listTyCon_RDR, consDataCon_RDR)
 
 import qualified Data.Semigroup as Semi
 }
@@ -3641,11 +3641,7 @@ qtyconsym :: { LocatedN RdrName }
 
 tyconsym :: { LocatedN RdrName }
         : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }
-        | VARSYM                { sL1n $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                { sL1n $1 $! mkUnqual tcClsName (getVARSYM $1) }
         | ':'                   { sL1n $1 $! consDataCon_RDR }
         | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }
         | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index e5557855c0..444471abca 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -137,7 +137,7 @@ import GHC.Types.TyThing
 import GHC.Core.Type    ( 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 )
@@ -2453,8 +2453,7 @@ checkPrecP (L l (_,i)) (L _ ol)
  | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)
   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 == getRdrName unrestrictedFunTyCon
 
 mkRecConstrOrUpdate
         :: Bool
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index cd40ab100a..3525c71f1b 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1047,7 +1047,24 @@ lookupTypeOccRn rdr_name
   = do { mb_name <- lookupOccRn_maybe rdr_name
        ; case mb_name of
              Just name -> return name
-             Nothing   -> lookup_demoted rdr_name }
+             Nothing   ->
+               if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]
+               then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope
+               else lookup_demoted rdr_name }
+
+{- Note [eqTyCon (~) compatibility fallback]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before GHC Proposal #371, the (~) type operator used in type equality
+constraints (a~b) was considered built-in syntax.
+
+This had two implications:
+
+1. Users could use it without importing it from Data.Type.Equality or Prelude.
+2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead)
+
+To ease migration and minimize breakage, we continue to support those usages
+but emit appropriate warnings.
+-}
 
 lookup_demoted :: RdrName -> RnM Name
 lookup_demoted rdr_name
@@ -1919,13 +1936,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]
diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot
index 58f6bbc874..ca66c8168b 100644
--- a/compiler/GHC/Rename/Expr.hs-boot
+++ b/compiler/GHC/Rename/Expr.hs-boot
@@ -1,6 +1,12 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ConstraintKinds #-}
 module GHC.Rename.Expr where
+
+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
+import Data.Type.Equality (type (~))
+#endif
+
 import GHC.Types.Name
 import GHC.Hs
 import GHC.Types.Name.Set ( FreeVars )
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index bf31991e8f..edda60fbee 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -629,7 +629,7 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
 
 rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
   = setSrcSpan (getLocA l_op) $
-    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op
+    do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op
         ; fix   <- lookupTyFixityRn l_op'
         ; (ty1', fvs2) <- rnLHsTyKi env ty1
         ; (ty2', fvs3) <- rnLHsTyKi env ty2
@@ -822,16 +822,15 @@ rnLTyVar (L loc rdr_name)
        ; return (L loc tyvar) }
 
 --------------
-rnHsTyOp :: Outputable a
-         => RnTyKiEnv -> a -> LocatedN RdrName
+rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName
          -> RnM (LocatedN Name, FreeVars)
 rnHsTyOp env overall_ty (L loc op)
-  = do { ops_ok <- xoptM LangExt.TypeOperators
-       ; op' <- rnTyVar env op
-       ; unless (ops_ok || op' `hasKey` eqTyConKey) $
-           addErr $ TcRnUnknownMessage $ mkPlainError noHints (opTyErr op overall_ty)
-       ; let l_op' = L loc op'
-       ; return (l_op', unitFV op') }
+  = do { op' <- rnTyVar env op
+       ; unlessXOptM LangExt.TypeOperators $
+           if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
+           then addDiagnostic TcRnTypeEqualityRequiresOperators
+           else addErr $ TcRnIllegalTypeOperator overall_ty op
+       ; return (L loc op', unitFV op') }
 
 --------------
 checkWildCard :: RnTyKiEnv
@@ -1660,11 +1659,6 @@ warnUnusedForAll doc (L loc tv) used_names
                    , inHsDocContext doc ]
       addDiagnosticAt (locA loc) msg
 
-opTyErr :: Outputable a => RdrName -> a -> SDoc
-opTyErr op overall_ty
-  = hang (text "Illegal operator" <+> quotes (ppr op) <+> text "in type" <+> quotes (ppr overall_ty))
-         2 (text "Use TypeOperators to allow operators in types")
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index ad78cfaf76..2c9b013e17 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -651,6 +651,23 @@ instance Diagnostic TcRnMessage where
             fsep [ text "The use of" <+> quotes (ppr rdr_name)
                                      <+> text "as an identifier",
                    text "will become an error in a future GHC release." ]
+    TcRnTypeEqualityOutOfScope
+      -> mkDecorated
+           [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$
+             text "Assuming it to stand for an equality constraint."
+           , text "NB:" <+> (quotes (text "~") <+> text "used to be built-in syntax but now is a regular type operator" $$
+                             text "exported from Data.Type.Equality and Prelude.") $$
+             text "If you are using a custom Prelude, consider re-exporting it."
+           , text "This will become an error in a future GHC release." ]
+    TcRnTypeEqualityRequiresOperators
+      -> mkSimpleDecorated $
+            fsep [ text "The use of" <+> quotes (text "~")
+                                     <+> text "without TypeOperators",
+                   text "will become an error in a future GHC release." ]
+    TcRnIllegalTypeOperator overall_ty op
+      -> mkSimpleDecorated $
+           text "Illegal operator" <+> quotes (ppr op) <+>
+           text "in type" <+> quotes (ppr overall_ty)
     TcRnGADTMonoLocalBinds
       -> mkSimpleDecorated $
             fsep [ text "Pattern matching on GADTs without MonoLocalBinds"
@@ -920,6 +937,12 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnForallIdentifier {}
       -> WarningWithFlag Opt_WarnForallIdentifier
+    TcRnTypeEqualityOutOfScope
+      -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope
+    TcRnTypeEqualityRequiresOperators
+      -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators
+    TcRnIllegalTypeOperator {}
+      -> ErrorWithoutFlag
     TcRnGADTMonoLocalBinds {}
       -> WarningWithFlag Opt_WarnGADTMonoLocalBinds
     TcRnIncorrectNameSpace {}
@@ -1152,6 +1175,12 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnForallIdentifier {}
       -> [SuggestRenameForall]
+    TcRnTypeEqualityOutOfScope
+      -> noHints
+    TcRnTypeEqualityRequiresOperators
+      -> [suggestExtension LangExt.TypeOperators]
+    TcRnIllegalTypeOperator {}
+      -> [suggestExtension LangExt.TypeOperators]
     TcRnGADTMonoLocalBinds {}
       -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]]
     TcRnIncorrectNameSpace nm is_th_use
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index abf574df19..58e984011a 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1581,6 +1581,35 @@ data TcRnMessage where
   -}
   TcRnForallIdentifier :: RdrName -> TcRnMessage
 
+  {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope)
+      that occurs when the type equality (a ~ b) is not in scope.
+
+      Test case: T18862b
+  -}
+  TcRnTypeEqualityOutOfScope :: TcRnMessage
+
+  {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators)
+      that occurs when the type equality (a ~ b) is used without the TypeOperators extension.
+
+      Example:
+        {-# LANGUAGE NoTypeOperators #-}
+        f :: (a ~ b) => a -> b
+
+      Test case: T18862a
+  -}
+  TcRnTypeEqualityRequiresOperators :: TcRnMessage
+
+  {-| TcRnIllegalTypeOperator is an error that occurs when a type operator
+      is used without the TypeOperators extension.
+
+      Example:
+        {-# LANGUAGE NoTypeOperators #-}
+        f :: Vec a n -> Vec a m -> Vec a (n + m)
+
+      Test case: T12811
+  -}
+  TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage
+
   {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds
       that occurs when pattern matching on a GADT when -XMonoLocalBinds is off.
 
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 1a5f2f6a41..598b07b8c7 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -1137,7 +1137,9 @@ check_class_pred env dflags ctxt pred cls tys
                          -- but here we want to treat them as equalities
   = -- Equational constraints are valid in all contexts, and
     -- we do not need to check e.g. for FlexibleContexts here, so just do nothing
-    return ()
+    -- We used to require TypeFamilies/GADTs for equality constraints,
+    -- but not anymore (GHC Proposal #371)
+   return ()
 
   | isIPClass cls
   = do { check_arity
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 3aff044b78..5a3794ee37 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -154,6 +154,7 @@ Library
        ,BangPatterns
        ,ScopedTypeVariables
        ,MonoLocalBinds
+       ,TypeOperators
 
     Exposed-Modules:
         GHC