Do not imply NoStarIsType by TypeOperators/TypeInType

Implementation of the "Embrace TypeInType" proposal was done according
to the spec, which specified that TypeOperators must imply NoStarIsType.
This implication was meant to prevent breakage and to be removed in 2
releases.  However, compiling head.hackage has shown that this
implication only magnified the breakage, so there is no reason to have
it in the first place.

To remain in compliance with the three-release policy, we add a
workaround to define the (*) type operator even when -XStarIsType is on.

Test Plan: ./validate

Reviewers: bgamari, RyanGlScott, goldfire, phadej, hvr

Reviewed By: bgamari, RyanGlScott

Subscribers: harpocrates, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4865

2 files changed, 17 insertions, 8 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 2887edff04..a6650acb15 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -68,7 +68,6 @@ module Lexer (
    explicitNamespacesEnabled,
    patternSynonymsEnabled,
    sccProfilingOn, hpcEnabled,
-   typeOperatorsEnabled,
    starIsTypeEnabled,
    addWarning,
    lexTokenStream,
@@ -2264,7 +2263,6 @@ data ExtBits
   | TypeApplicationsBit
   | StaticPointersBit
   | NumericUnderscoresBit
-  | TypeOperatorsBit
   | StarIsTypeBit
   deriving Enum
 
@@ -2334,8 +2332,6 @@ staticPointersEnabled :: ExtsBitmap -> Bool
 staticPointersEnabled = xtest StaticPointersBit
 numericUnderscoresEnabled :: ExtsBitmap -> Bool
 numericUnderscoresEnabled = xtest NumericUnderscoresBit
-typeOperatorsEnabled :: ExtsBitmap -> Bool
-typeOperatorsEnabled = xtest TypeOperatorsBit
 starIsTypeEnabled :: ExtsBitmap -> Bool
 starIsTypeEnabled = xtest StarIsTypeBit
 
@@ -2392,7 +2388,6 @@ mkParserFlags flags =
       .|. TypeApplicationsBit         `xoptBit` LangExt.TypeApplications
       .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers
       .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores
-      .|. TypeOperatorsBit            `xoptBit` LangExt.TypeOperators
       .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType
     optBits =
           HaddockBit        `goptBit` Opt_Haddock
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 7dc3aafb91..1ffde2222c 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -870,6 +870,12 @@ checkTyClHdr is_cls ty
   where
     goL (L l ty) acc ann fix = go l ty acc ann fix
 
+    -- workaround to define '*' despite StarIsType
+    go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
+      = do { warnStarBndr l
+           ; let name = mkOccName tcClsName (if isUni then "★" else "*")
+           ; return (L l (Unqual name), acc, fix, ann) }
+
     go l (HsTyVar _ _ (L _ tc)) acc ann fix
       | isRdrTc tc               = return (L l tc, acc, fix, ann)
     go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
@@ -1747,11 +1753,19 @@ warnStarIsType span = addWarning Opt_WarnStarIsType span msg
         $$ text "Suggested fix: use" <+> quotes (text "Type")
            <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
 
+warnStarBndr :: SrcSpan -> P ()
+warnStarBndr span = addWarning Opt_WarnStarBinder span msg
+  where
+    msg =  text "Found binding occurrence of" <+> quotes (text "*")
+           <+> text "yet StarIsType is enabled."
+        $$ text "NB. To use (or export) this operator in"
+           <+> text "modules with StarIsType,"
+        $$ text "    including the definition module, you must qualify it."
+
 failOpFewArgs :: Located RdrName -> P a
 failOpFewArgs (L loc op) =
-  do { type_operators <- extension typeOperatorsEnabled
-     ; star_is_type <- extension starIsTypeEnabled
-     ; let msg = too_few $$ starInfo (type_operators, star_is_type) op
+  do { star_is_type <- extension starIsTypeEnabled
+     ; let msg = too_few $$ starInfo star_is_type op
      ; parseErrorSDoc loc msg }
   where
     too_few = text "Operator applied to too few arguments:" <+> ppr op