Embrace -XTypeInType, add -XStarIsType

Summary:
Implement the "Embrace Type :: Type" GHC proposal,
.../ghc-proposals/blob/master/proposals/0020-no-type-in-type.rst

GHC 8.0 included a major change to GHC's type system: the Type :: Type
axiom. Though casual users were protected from this by hiding its
features behind the -XTypeInType extension, all programs written in GHC
8+ have the axiom behind the scenes. In order to preserve backward
compatibility, various legacy features were left unchanged. For example,
with -XDataKinds but not -XTypeInType, GADTs could not be used in types.
Now these restrictions are lifted and -XTypeInType becomes a redundant
flag that will be eventually deprecated.

* Incorporate the features currently in -XTypeInType into the
  -XPolyKinds and -XDataKinds extensions.
* Introduce a new extension -XStarIsType to control how to parse * in
  code and whether to print it in error messages.

Test Plan: Validate

Reviewers: goldfire, hvr, bgamari, alanz, simonpj

Reviewed By: goldfire, simonpj

Subscribers: rwbarton, thomie, mpickering, carter

GHC Trac Issues: #15195

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

3 files changed, 223 insertions, 159 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 69dc0992c8..2887edff04 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -68,6 +68,8 @@ module Lexer (
    explicitNamespacesEnabled,
    patternSynonymsEnabled,
    sccProfilingOn, hpcEnabled,
+   typeOperatorsEnabled,
+   starIsTypeEnabled,
    addWarning,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
@@ -682,6 +684,7 @@ data Token
   | ITdarrow            IsUnicodeSyntax
   | ITminus
   | ITbang
+  | ITstar              IsUnicodeSyntax
   | ITdot
 
   | ITbiglam                    -- GHC-extension symbols
@@ -893,6 +896,8 @@ reservedSymsFM = listToUFM $
        ,("-",   ITminus,               always)
        ,("!",   ITbang,                always)
 
+       ,("*", ITstar NormalSyntax, starIsTypeEnabled)
+
         -- For 'forall a . t'
        ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
 
@@ -915,6 +920,8 @@ reservedSymsFM = listToUFM $
                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
        ,("⤜",   ITRarrowtail UnicodeSyntax,
                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("★",   ITstar UnicodeSyntax,
+                  \i -> unicodeSyntaxEnabled i && starIsTypeEnabled i)
 
         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
@@ -2257,6 +2264,8 @@ data ExtBits
   | TypeApplicationsBit
   | StaticPointersBit
   | NumericUnderscoresBit
+  | TypeOperatorsBit
+  | StarIsTypeBit
   deriving Enum
 
 
@@ -2325,6 +2334,10 @@ staticPointersEnabled :: ExtsBitmap -> Bool
 staticPointersEnabled = xtest StaticPointersBit
 numericUnderscoresEnabled :: ExtsBitmap -> Bool
 numericUnderscoresEnabled = xtest NumericUnderscoresBit
+typeOperatorsEnabled :: ExtsBitmap -> Bool
+typeOperatorsEnabled = xtest TypeOperatorsBit
+starIsTypeEnabled :: ExtsBitmap -> Bool
+starIsTypeEnabled = xtest StarIsTypeBit
 
 -- PState for parsing options pragmas
 --
@@ -2343,47 +2356,56 @@ mkParserFlags flags =
     , pExtsBitmap = bitmap
     }
   where
-      bitmap =     FfiBit                      `setBitIf` xopt LangExt.ForeignFunctionInterface flags
-               .|. InterruptibleFfiBit         `setBitIf` xopt LangExt.InterruptibleFFI         flags
-               .|. CApiFfiBit                  `setBitIf` xopt LangExt.CApiFFI                  flags
-               .|. ArrowsBit                   `setBitIf` xopt LangExt.Arrows                   flags
-               .|. ThBit                       `setBitIf` xopt LangExt.TemplateHaskell          flags
-               .|. ThQuotesBit                 `setBitIf` xopt LangExt.TemplateHaskellQuotes    flags
-               .|. QqBit                       `setBitIf` xopt LangExt.QuasiQuotes              flags
-               .|. IpBit                       `setBitIf` xopt LangExt.ImplicitParams           flags
-               .|. OverloadedLabelsBit         `setBitIf` xopt LangExt.OverloadedLabels         flags
-               .|. ExplicitForallBit           `setBitIf` xopt LangExt.ExplicitForAll           flags
-               .|. BangPatBit                  `setBitIf` xopt LangExt.BangPatterns             flags
-               .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                      flags
-               .|. MagicHashBit                `setBitIf` xopt LangExt.MagicHash                flags
-               .|. RecursiveDoBit              `setBitIf` xopt LangExt.RecursiveDo              flags
-               .|. UnicodeSyntaxBit            `setBitIf` xopt LangExt.UnicodeSyntax            flags
-               .|. UnboxedTuplesBit            `setBitIf` xopt LangExt.UnboxedTuples            flags
-               .|. UnboxedSumsBit              `setBitIf` xopt LangExt.UnboxedSums              flags
-               .|. DatatypeContextsBit         `setBitIf` xopt LangExt.DatatypeContexts         flags
-               .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.TransformListComp        flags
-               .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.MonadComprehensions      flags
-               .|. RawTokenStreamBit           `setBitIf` gopt Opt_KeepRawTokenStream           flags
-               .|. HpcBit                      `setBitIf` gopt Opt_Hpc                          flags
-               .|. AlternativeLayoutRuleBit    `setBitIf` xopt LangExt.AlternativeLayoutRule    flags
-               .|. RelaxedLayoutBit            `setBitIf` xopt LangExt.RelaxedLayout            flags
-               .|. SccProfilingOnBit           `setBitIf` gopt Opt_SccProfilingOn               flags
-               .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags
-               .|. SafeHaskellBit              `setBitIf` safeImportsOn                         flags
-               .|. TraditionalRecordSyntaxBit  `setBitIf` xopt LangExt.TraditionalRecordSyntax  flags
-               .|. ExplicitNamespacesBit       `setBitIf` xopt LangExt.ExplicitNamespaces flags
-               .|. LambdaCaseBit               `setBitIf` xopt LangExt.LambdaCase               flags
-               .|. BinaryLiteralsBit           `setBitIf` xopt LangExt.BinaryLiterals           flags
-               .|. NegativeLiteralsBit         `setBitIf` xopt LangExt.NegativeLiterals         flags
-               .|. HexFloatLiteralsBit         `setBitIf` xopt LangExt.HexFloatLiterals         flags
-               .|. PatternSynonymsBit          `setBitIf` xopt LangExt.PatternSynonyms          flags
-               .|. TypeApplicationsBit         `setBitIf` xopt LangExt.TypeApplications         flags
-               .|. StaticPointersBit           `setBitIf` xopt LangExt.StaticPointers           flags
-               .|. NumericUnderscoresBit       `setBitIf` xopt LangExt.NumericUnderscores       flags
-
-      setBitIf :: ExtBits -> Bool -> ExtsBitmap
-      b `setBitIf` cond | cond      = xbit b
-                        | otherwise = 0
+    bitmap = safeHaskellBit .|. langExtBits .|. optBits
+    safeHaskellBit =
+          SafeHaskellBit `setBitIf` safeImportsOn flags
+    langExtBits =
+          FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface
+      .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI
+      .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI
+      .|. ArrowsBit                   `xoptBit` LangExt.Arrows
+      .|. ThBit                       `xoptBit` LangExt.TemplateHaskell
+      .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes
+      .|. QqBit                       `xoptBit` LangExt.QuasiQuotes
+      .|. IpBit                       `xoptBit` LangExt.ImplicitParams
+      .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels
+      .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll
+      .|. BangPatBit                  `xoptBit` LangExt.BangPatterns
+      .|. MagicHashBit                `xoptBit` LangExt.MagicHash
+      .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo
+      .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax
+      .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples
+      .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums
+      .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts
+      .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp
+      .|. TransformComprehensionsBit  `xoptBit` LangExt.MonadComprehensions
+      .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule
+      .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout
+      .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation
+      .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax
+      .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces
+      .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase
+      .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals
+      .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals
+      .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals
+      .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms
+      .|. 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
+      .|. RawTokenStreamBit `goptBit` Opt_KeepRawTokenStream
+      .|. HpcBit            `goptBit` Opt_Hpc
+      .|. SccProfilingOnBit `goptBit` Opt_SccProfilingOn
+
+    xoptBit bit ext = bit `setBitIf` xopt ext flags
+    goptBit bit opt = bit `setBitIf` gopt opt flags
+
+    setBitIf :: ExtBits -> Bool -> ExtsBitmap
+    b `setBitIf` cond | cond      = xbit b
+                      | otherwise = 0
 
 -- | Creates a parse state from a 'DynFlags' value
 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 25edb3e591..c1ee8a4855 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -88,7 +88,7 @@ import GhcPrelude
 import qualified GHC.LanguageExtensions as LangExt
 }
 
-%expect 233 -- shift/reduce conflicts
+%expect 235 -- shift/reduce conflicts
 
 {- Last updated: 04 June 2018
 
@@ -158,7 +158,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 143 contains 14 shift/reduce conflicts.
+state 144 contains 15 shift/reduce conflicts.
 
         exp -> infixexp . '::' sigtype
         exp -> infixexp . '-<' exp
@@ -169,7 +169,7 @@ state 143 contains 14 shift/reduce conflicts.
         infixexp -> infixexp . qop exp10
 
     Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'
-               '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+               '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM
 
 Examples of ambiguity:
     'if x then y else z -< e'
@@ -183,7 +183,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 148 contains 68 shift/reduce conflicts.
+state 149 contains 67 shift/reduce conflicts.
 
     *** exp10 -> fexp .
         fexp -> fexp . aexp
@@ -201,7 +201,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 204 contains 28 shift/reduce conflicts.
+state 204 contains 27 shift/reduce conflicts.
 
         aexp2 -> TH_TY_QUOTE . tyvar
         aexp2 -> TH_TY_QUOTE . gtycon
@@ -220,7 +220,7 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 308 contains 1 shift/reduce conflicts.
+state 300 contains 1 shift/reduce conflicts.
 
         rule -> STRING . rule_activation rule_forall infixexp '=' exp
 
@@ -238,7 +238,7 @@ a rule instructing how to rewrite the expression '[0] f'.
 
 -------------------------------------------------------------------------------
 
-state 318 contains 1 shift/reduce conflict.
+state 310 contains 1 shift/reduce conflict.
 
     *** type -> btype .
         type -> btype . '->' ctype
@@ -249,7 +249,7 @@ Same as state 61 but without contexts.
 
 -------------------------------------------------------------------------------
 
-state 362 contains 1 shift/reduce conflicts.
+state 354 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(' commas . ')'
@@ -264,7 +264,7 @@ if -XTupleSections is not specified.
 
 -------------------------------------------------------------------------------
 
-state 418 contains 1 shift/reduce conflicts.
+state 409 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(#' commas . '#)'
@@ -272,21 +272,21 @@ state 418 contains 1 shift/reduce conflicts.
 
     Conflict: '#)' (empty tup_tail reduces)
 
-Same as State 362 for unboxed tuples.
+Same as State 354 for unboxed tuples.
 
 -------------------------------------------------------------------------------
 
-state 429 contains 68 shift/reduce conflicts.
+state 417 contains 67 shift/reduce conflicts.
 
     *** exp10 -> '-' fexp .
         fexp -> fexp . aexp
         fexp -> fexp . TYPEAPP atype
 
-Same as 148 but with a unary minus.
+Same as 149 but with a unary minus.
 
 -------------------------------------------------------------------------------
 
-state 493 contains 1 shift/reduce conflict.
+state 481 contains 1 shift/reduce conflict.
 
         oqtycon -> '(' qtyconsym . ')'
     *** qtyconop -> qtyconsym .
@@ -300,7 +300,7 @@ parenthesized infix type expression of length 1.
 
 -------------------------------------------------------------------------------
 
-state 694 contains 1 shift/reduce conflicts.
+state 675 contains 1 shift/reduce conflicts.
 
     *** aexp2 -> ipvar .
         dbind -> ipvar . '=' exp
@@ -315,7 +315,7 @@ sensible meaning, namely the lhs of an implicit binding.
 
 -------------------------------------------------------------------------------
 
-state 771 contains 1 shift/reduce conflicts.
+state 752 contains 1 shift/reduce conflicts.
 
         rule -> STRING rule_activation . rule_forall infixexp '=' exp
 
@@ -332,7 +332,7 @@ doesn't include 'forall'.
 
 -------------------------------------------------------------------------------
 
-state 1019 contains 1 shift/reduce conflicts.
+state 986 contains 1 shift/reduce conflicts.
 
         transformqual -> 'then' 'group' . 'using' exp
         transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -342,7 +342,7 @@ state 1019 contains 1 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 1404 contains 1 shift/reduce conflict.
+state 1367 contains 1 shift/reduce conflict.
 
     *** atype -> tyvar .
         tv_bndr -> '(' tyvar . '::' kind ')'
@@ -526,6 +526,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  '=>'           { L _ (ITdarrow _) }
  '-'            { L _ ITminus }
  '!'            { L _ ITbang }
+ '*'            { L _ (ITstar _) }
  '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation
  '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation
  '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation
@@ -1160,11 +1161,7 @@ deriv_strategy_no_via :: { LDerivStrategy GhcPs }
                                        [mj AnnNewtype $1] }
 
 deriv_strategy_via :: { LDerivStrategy GhcPs }
-  : 'via' tyapp                 {% splitTildeApps [$2] >>= \tys -> let
-                                     ty :: LHsType GhcPs
-                                     ty = sL1 $1 $ mkHsAppsTy tys
-
-                                     in ams (sLL $1 $> (ViaStrategy (mkLHsSigType ty)))
+  : 'via' type              {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2)))
                                             [mj AnnVia $1] }
 
 deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
@@ -1856,7 +1853,7 @@ context :: { LHsContext GhcPs }
                                                 } }
 
 context_no_ops :: { LHsContext GhcPs }
-        : btype_no_ops                 {% do { ty <- splitTilde $1
+        : btype_no_ops                 {% do { ty <- splitTilde (reverse (unLoc $1))
                                              ; (anns,ctx) <- checkContext ty
                                              ; if null (unLoc ctx)
                                                    then addAnnotation (gl ty) AnnUnit (gl ty)
@@ -1911,29 +1908,27 @@ typedoc :: { LHsType GhcPs }
 
 -- See Note [Parsing ~]
 btype :: { LHsType GhcPs }
-        : tyapps                      {%  splitTildeApps (reverse (unLoc $1)) >>=
-                                          \ts -> return $ sL1 $1 $ mkHsAppsTy ts }
+      : tyapps                      {%  mergeOps (unLoc $1) }
 
 -- Used for parsing Haskell98-style data constructors,
 -- in order to forbid the blasphemous
 -- > data Foo = Int :+ Char :* Bool
 -- See also Note [Parsing data constructors is hard] in RdrHsSyn
-btype_no_ops :: { LHsType GhcPs }
-        : btype_no_ops atype_docs       { sLL $1 $> $ HsAppTy noExt $1 $2 }
-        | atype_docs                    { $1 }
+btype_no_ops :: { Located [LHsType GhcPs] } -- NB: This list is reversed
+        : atype_docs                    { sL1 $1 [$1] }
+        | btype_no_ops atype_docs       { sLL $1 $> $ $2 : (unLoc $1) }
 
-tyapps :: { Located [LHsAppType GhcPs] }   -- NB: This list is reversed
+tyapps :: { Located [Located TyEl] } -- NB: This list is reversed
         : tyapp                         { sL1 $1 [$1] }
         | tyapps tyapp                  { sLL $1 $> $ $2 : (unLoc $1) }
 
--- See Note [HsAppsTy] in HsTypes
-tyapp :: { LHsAppType GhcPs }
-        : atype                         { sL1 $1 $ HsAppPrefix noExt $1 }
-        | qtyconop                      { sL1 $1 $ HsAppInfix noExt $1 }
-        | tyvarop                       { sL1 $1 $ HsAppInfix noExt $1 }
-        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ HsAppInfix noExt $2)
+tyapp :: { Located TyEl }
+        : atype                         { sL1 $1 $ TyElOpd (unLoc $1) }
+        | qtyconop                      { sL1 $1 $ TyElOpr (unLoc $1) }
+        | tyvarop                       { sL1 $1 $ TyElOpr (unLoc $1) }
+        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
                                                [mj AnnSimpleQuote $1] }
-        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix noExt $2)
+        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
                                                [mj AnnSimpleQuote $1] }
 
 atype_docs :: { LHsType GhcPs }
@@ -1943,6 +1938,8 @@ atype_docs :: { LHsType GhcPs }
 atype :: { LHsType GhcPs }
         : ntgtycon                       { sL1 $1 (HsTyVar noExt NotPromoted $1) }      -- Not including unit tuples
         | tyvar                          { sL1 $1 (HsTyVar noExt NotPromoted $1) }      -- (See Note [Unit tuples])
+        | '*'                            {% do { warnStarIsType (getLoc $1)
+                                               ; return $ sL1 $1 (HsStarTy noExt (isUnicode $1)) } }
         | strict_mark atype              {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2))
                                                 (fst $ unLoc $1) }  -- Constructor sigs only
         | '{' fielddecls '}'             {% amms (checkRecordSyntax
@@ -2061,13 +2058,13 @@ Note [Parsing ~]
 
 Due to parsing conflicts between laziness annotations in data type
 declarations (see strict_mark) and equality types ~'s are always
-parsed as laziness annotations, and turned into HsEqTy's in the
+parsed as laziness annotations, and turned into HsOpTy's in the
 correct places using RdrHsSyn.splitTilde.
 
 Since strict_mark is parsed as part of atype which is part of type,
 typedoc and context (where HsEqTy previously appeared) it made most
 sense and was simplest to parse ~ as part of strict_mark and later
-turn them into HsEqTy's.
+turn them into HsOpTy's.
 
 -}
 
@@ -2191,14 +2188,15 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) }
 
 constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) }
     -- See Note [Parsing data constructors is hard] in RdrHsSyn
-        : btype_no_ops                         {% do { c <- splitCon $1
-                                                     ; return $ sLL $1 $> c } }
+        : btype_no_ops                     {% do { c <- splitCon (unLoc $1)
+                                                 ; return $ sL1 $1 c } }
         | btype_no_ops conop maybe_docprev btype_no_ops
-            {% do { lhs <- splitTilde $1
-                              ; (_, ds_l) <- checkInfixConstr lhs
-                  ; (rhs, ds_r) <- checkInfixConstr $4
+            {% do { lhs <- splitTilde (reverse (unLoc $1))
+                  ; (_, ds_l) <- checkInfixConstr lhs
+                  ; let rhs1 = foldl1 mkHsAppTy (reverse (unLoc $4))
+                  ; (rhs, ds_r) <- checkInfixConstr rhs1
                   ; return $ if isJust (ds_l `mplus` $3)
-                               then sLL $1 $> ($2, InfixCon lhs $4, $3)
+                               then sLL $1 $> ($2, InfixCon lhs rhs1, $3)
                                else sLL $1 $> ($2, InfixCon lhs rhs, ds_r) } }
 
 fielddecls :: { [LConDeclField GhcPs] }
@@ -3370,6 +3368,7 @@ special_id
 special_sym :: { Located FastString }
 special_sym : '!'       {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
             | '.'       { sL1 $1 (fsLit ".") }
+            | '*'       { sL1 $1 (fsLit (if isUnicode $1 then "★" else "*")) }
 
 -----------------------------------------------------------------------------
 -- Data constructors
@@ -3552,6 +3551,7 @@ isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax
 isUnicode _                           = False
 
 hasE :: Located Token -> Bool
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 35371af9c8..64b74d3317 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -57,7 +57,8 @@ module   RdrHsSyn (
         checkRecordSyntax,
         checkEmptyGADTs,
         parseErrorSDoc, hintBangPat,
-        splitTilde, splitTildeApps,
+        splitTilde,
+        TyEl(..), mergeOps,
 
         -- Help with processing exports
         ImpExpSubSpec(..),
@@ -67,6 +68,10 @@ module   RdrHsSyn (
         mkImpExpSubSpec,
         checkImportSpec,
 
+        -- Warnings and errors
+        warnStarIsType,
+        failOpFewArgs,
+
         SumOrTuple (..), mkSumOrTuple
 
     ) where
@@ -87,8 +92,7 @@ import Lexeme           ( isLexCon )
 import Type             ( TyThing(..) )
 import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
-                          listTyConName, listTyConKey,
-                          starKindTyConName, unicodeStarKindTyConName )
+                          listTyConName, listTyConKey )
 import ForeignCall
 import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
 import SrcLoc
@@ -103,7 +107,7 @@ import ApiAnnotation
 import HsExtension      ( noExt )
 import Data.List
 import qualified GHC.LanguageExtensions as LangExt
-import MonadUtils
+import DynFlags ( WarningFlag(..) )
 
 import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
@@ -479,9 +483,15 @@ So the plan is:
      data T = (+++)
   will parse ok (since tycons can be operators), but we should reject
   it (Trac #12051).
+
+'splitCon' takes a reversed list @apps@ of types as input, such that
+@foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because
+this is easy for the parser to produce and we avoid the overhead of unrolling
+'HsAppTy'.
+
 -}
 
-splitCon :: LHsType GhcPs
+splitCon :: [LHsType GhcPs]
       -> P ( Located RdrName         -- constructor name
            , HsConDeclDetails GhcPs  -- constructor field information
            , Maybe LHsDocString      -- docstring to go on the constructor
@@ -491,15 +501,11 @@ splitCon :: LHsType GhcPs
 --      C Int Bool
 -- or   C { x::Int, y::Bool }
 -- and returns the pieces
-splitCon ty
+splitCon apps
  = split apps' []
  where
-   -- This is used somewhere where HsAppsTy is not used
-   unrollApps (L _ (HsAppTy _ t u)) = u : unrollApps t
-   unrollApps t = [t]
-
-   apps = unrollApps ty
    oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
+   ty = foldl1 mkHsAppTy (reverse apps)
 
    -- the trailing doc, if any, can be extracted first
    (apps', trailing_doc)
@@ -865,15 +871,6 @@ checkTyClHdr is_cls ty
       | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
     go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
     go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
-    go _ (HsAppsTy _ ts)   acc ann _fix
-      | Just (head, args, fixity) <- getAppsTyHead_maybe ts
-      = goL head (args ++ acc) ann fixity
-
-    go _ (HsAppsTy _ [L _ (HsAppInfix _ (L loc star))]) [] ann fix
-      | isStar star
-      = return (L loc (nameRdrName starKindTyConName), [], fix, ann)
-      | isUniStar star
-      = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
 
     go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
       = return (L l (nameRdrName tup_name), ts, fix, ann)
@@ -927,10 +924,6 @@ checkContext (L l orig_t)
     -- be used as context constraints.
     = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
 
-    -- don't let HsAppsTy get in the way
-  check anns (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)]))
-    = check anns ty
-
   check anns (L lp1 (HsParTy _ ty))
                                   -- to be sure HsParTy doesn't get into the way
        = check anns' ty
@@ -1276,56 +1269,78 @@ isFunLhs e = go e [] []
                  _ -> return Nothing }
    go _ _ _ = return Nothing
 
-
--- | Transform btype_no_ops with strict_mark's into HsEqTy's
--- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
-splitTilde :: LHsType GhcPs -> P (LHsType GhcPs)
-splitTilde t = go t
-  where go (L loc (HsAppTy _ t1 t2))
-          | L lo (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
-                                                                          <- t2
-          = do
-              moveAnnotations lo loc
-              t1' <- go t1
-              return (L loc (HsEqTy noExt t1' t2'))
-          | otherwise
-          = do
-              t1' <- go t1
-              case t1' of
-                (L lo (HsEqTy _ tl tr)) -> do
-                  let lr = combineLocs tr t2
-                  moveAnnotations lo loc
-                  return (L loc (HsEqTy noExt tl
-                                           (L lr (HsAppTy noExt tr t2))))
-                t -> do
-                  return (L loc (HsAppTy noExt t t2))
-
-        go t = return t
-
-
--- | Transform tyapps with strict_marks into uses of twiddle
--- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
-splitTildeApps :: [LHsAppType GhcPs] -> P [LHsAppType GhcPs]
-splitTildeApps []         = return []
-splitTildeApps (t : rest) = do
-  rest' <- concatMapM go rest
-  return (t : rest')
-  where go (L l (HsAppPrefix _
-            (L loc (HsBangTy noExt
-                    (HsSrcBang NoSourceText NoSrcUnpack SrcLazy)
-                    ty))))
-          = addAnnotation l AnnTilde tilde_loc >>
-            return
-              [L tilde_loc (HsAppInfix noExt (L tilde_loc eqTyCon_RDR)),
-               L l (HsAppPrefix noExt ty)]
-               -- NOTE: no annotation is attached to an HsAppPrefix, so the
-               --       surrounding SrcSpan is not critical
-          where
-            tilde_loc = srcSpanFirstCharacter loc
-
-        go t = return [t]
-
-
+-- | Transform a list of 'atype' with 'strict_mark' into
+-- HsOpTy's of 'eqTyCon_RDR':
+--
+--   [~a, ~b, c, ~d] ==> (~a) ~ ((b c) ~ d)
+--
+-- See Note [Parsing ~]
+splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs)
+splitTilde [] = panic "splitTilde"
+splitTilde (x:xs) = go x xs
+  where
+    -- We accumulate applications in the LHS until we encounter a laziness
+    -- annotation. For example, if we have [Foo, x, y, ~Bar, z], the 'lhs'
+    -- accumulator will become '(Foo x) y'. Then we strip the laziness
+    -- annotation off 'Bar' and process the tail [Bar, z] recursively.
+    --
+    -- This leaves us with 'lhs = (Foo x) y' and 'rhs = Bar z'.
+    -- In case the tail contained more laziness annotations, they would be
+    -- processed similarly. This makes '~' right-associative.
+    go lhs [] = return lhs
+    go lhs (x:xs)
+      | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
+      = do { rhs <- splitTilde (t:xs)
+           ; let r = mkLHsOpTy lhs (tildeOp loc) rhs
+           ; moveAnnotations loc (getLoc r)
+           ; return r }
+      | otherwise
+      = go (mkHsAppTy lhs x) xs
+
+    tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR
+
+-- | Either an operator or an operand.
+data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
+
+-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
+--   into a type.
+--
+-- User input: @F x y + G a b * X@
+-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
+-- Output corresponds to what the user wrote assuming all operators are of the
+-- same fixity and right-associative.
+--
+-- It's a bit silly that we're doing it at all, as the renamer will have to
+-- rearrange this, and it'd be easier to keep things separate.
+mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
+mergeOps = go [] id
+  where
+    -- clause (a):
+    -- when we encounter an operator, we must have accumulated
+    -- something for its rhs, and there must be something left
+    -- to build its lhs.
+    go acc ops_acc (L l (TyElOpr op):xs) =
+      if null acc || null xs
+        then failOpFewArgs (L l op)
+        else do { a <- splitTilde acc
+                ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
+
+    -- clause (b):
+    -- whenever an operand is encountered, it is added to the accumulator
+    go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs
+
+    -- clause (c):
+    -- at this point we know that 'acc' is non-empty because
+    -- there are three options when 'acc' can be empty:
+    -- 1. 'mergeOps' was called with an empty list, and this
+    --    should never happen
+    -- 2. 'mergeOps' was called with a list where the head is an
+    --    operator, this is handled by clause (a)
+    -- 3. 'mergeOps' was called with a list where the head is an
+    --    operand, this is handled by clause (b)
+    go acc ops_acc [] =
+      do { a <- splitTilde acc
+         ; return (ops_acc a) }
 
 ---------------------------------------------------------------------------
 -- Check for monad comprehensions
@@ -1715,6 +1730,28 @@ isImpExpQcWildcard ImpExpQcWildcard = True
 isImpExpQcWildcard _                = False
 
 -----------------------------------------------------------------------------
+-- Warnings and failures
+
+warnStarIsType :: SrcSpan -> P ()
+warnStarIsType span = addWarning Opt_WarnStarIsType span msg
+  where
+    msg =  text "Using" <+> quotes (text "*")
+           <+> text "(or its Unicode variant) to mean"
+           <+> quotes (text "Data.Kind.Type")
+        $$ text "relies on the StarIsType extension."
+        $$ text "Suggested fix: use" <+> quotes (text "Type")
+           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
+
+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
+     ; parseErrorSDoc loc msg }
+  where
+    too_few = text "Operator applied to too few arguments:" <+> ppr op
+
+-----------------------------------------------------------------------------
 -- Misc utils
 
 parseErrorSDoc :: SrcSpan -> SDoc -> P a
@@ -1748,3 +1785,8 @@ mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
       text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
 
     ppr_bars n = hsep (replicate n (Outputable.char '|'))
+
+mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
+mkLHsOpTy x op y =
+  let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
+  in L loc (mkHsOpTy x op y)