Use HsTupleTy [] for unit tuples, uniformly

This is just a tidy-up triggered by #5719.  We were parsing () as a
type constructor, rather than as a HsTupleTy, but it's better dealt
with uniformly as the former, I think.  Somewhat a matter of taste.

4 files changed, 44 insertions, 33 deletions

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index b76ff4b0f5..accb3ddc14 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -195,6 +195,19 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
 mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
 \end{code}
 
+Note [Unit tuples]
+~~~~~~~~~~~~~~~~~~
+Consider the type
+    type instance F Int = ()
+We want to parse that "()" 
+    as HsTupleTy HsBoxedOrConstraintTuple [], 
+NOT as HsTyVar unitTyCon
+
+Why? Because F might have kind (* -> Constraint), so we when parsing we
+don't know if that tuple is going to be a constraint tuple or an ordinary
+unit tuple.  The HsTupleSort flag is specifically designed to deal with
+that, but it has to work for unit tuples too.
+
 Note [Promotions (HsTyVar)]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 HsTyVar: A name in a type or kind.
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 861c15aadc..8a41fa4983 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1047,20 +1047,22 @@ btype :: { LHsType RdrName }
         | atype                         { $1 }
 
 atype :: { LHsType RdrName }
-        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
-        | tyvar                         { L1 (HsTyVar (unLoc $1)) }
-        | strict_mark atype             { LL (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
-        | '{' fielddecls '}'            {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only
-        | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy HsBoxedOrConstraintTuple  ($2:$4) }
-        | '(#' comma_types1 '#)'        { LL $ HsTupleTy HsUnboxedTuple $2     }
-        | '[' ctype ']'                 { LL $ HsListTy  $2 }
-        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
-        | '(' ctype ')'                 { LL $ HsParTy   $2 }
-        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 $4 }
-        | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }
-        | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
-        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $
-                                          mkUnqual varName (getTH_ID_SPLICE $1) }
+        : ntgtycon                       { L1 (HsTyVar (unLoc $1)) }      -- Not including unit tuples
+        | tyvar                          { L1 (HsTyVar (unLoc $1)) }      -- (See Note [Unit tuples])
+        | strict_mark atype              { LL (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
+        | '{' fielddecls '}'             {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only
+        | '(' ')'                        { LL $ HsTupleTy HsBoxedOrConstraintTuple []      }
+        | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) }
+        | '(#' '#)'                      { LL $ HsTupleTy HsUnboxedTuple           []      }       
+        | '(#' comma_types1 '#)'         { LL $ HsTupleTy HsUnboxedTuple           $2      }
+        | '[' ctype ']'                  { LL $ HsListTy  $2 }
+        | '[:' ctype ':]'                { LL $ HsPArrTy  $2 }
+        | '(' ctype ')'                  { LL $ HsParTy   $2 }
+        | '(' ctype '::' kind ')'        { LL $ HsKindSig $2 $4 }
+        | quasiquote                     { L1 (HsQuasiQuoteTy (unLoc $1)) }
+        | '$(' exp ')'                   { LL $ mkHsSpliceTy $2 }
+        | TH_ID_SPLICE                   { LL $ mkHsSpliceTy $ L1 $ HsVar $
+                                           mkUnqual varName (getTH_ID_SPLICE $1) }
                                                       -- see Note [Promotion] for the followings
         | SIMPLEQUOTE qconid                          { LL $ HsTyVar $ unLoc $2 }
         | SIMPLEQUOTE  '(' ')'                        { LL $ HsTyVar $ getRdrName unitDataCon }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 10e731b3e0..14778171f5 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -56,7 +56,7 @@ import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
                           InlinePragma(..), InlineSpec(..) )
 import TcEvidence       ( idHsWrapper )
 import Lexer
-import TysWiredIn       ( unitTyCon )
+import TysWiredIn       ( unitTyCon, unitDataCon )
 import ForeignCall
 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
                           occNameString )
@@ -360,10 +360,12 @@ splitCon :: LHsType RdrName
 splitCon ty
  = split ty []
  where
-   split (L _ (HsAppTy t u)) ts = split t (u : ts)
-   split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
-                                     return (data_con, mk_rest ts)
-   split (L l _) _              = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
+   split (L _ (HsAppTy t u)) ts    = split t (u : ts)
+   split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon l tc
+                                        return (data_con, mk_rest ts)
+   split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon [])
+                                         -- See Note [Unit tuples] in HsTypes
+   split (L l _) _                 = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
 
    mk_rest [L _ (HsRecTy flds)] = RecCon flds
    mk_rest ts                   = PrefixCon ts
@@ -535,12 +537,13 @@ checkTyClHdr ty
     goL (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc) acc 
-        | isRdrTc tc         = return (L l tc, acc)
-                                     
+        | isRdrTc tc          = return (L l tc, acc)
     go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
         | isRdrTc tc         = return (ltc, t1:t2:acc)
     go _ (HsParTy ty)    acc = goL ty acc
     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
+    go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), [])
+                                   -- See Note [Unit tuples] in HsTypes
     go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
 
 -- Check that associated type declarations of a class are all kind signatures.
@@ -560,14 +563,11 @@ checkContext (L l orig_t)
   = check orig_t
  where
   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
-    = return (L l ts)
+    = return (L l ts)           -- Ditto ()
 
   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
     = check (unLoc ty)
 
-  check (HsTyVar t)     -- Empty context shows up as a unit type ()
-    | t == getRdrName unitTyCon = return (L l [])
-
   check _
     = return (L l [L l orig_t])
 
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 3a35046959..218539d138 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -349,14 +349,10 @@ kc_hs_type (HsParTy ty) exp_kind = do
    ty' <- kc_lhs_type ty exp_kind
    return (HsParTy ty')
 
-kc_hs_type (HsTyVar name) exp_kind
-  -- Special case for the unit tycon so it benefits from kind overloading
-  | name == tyConName unitTyCon
-  = kc_hs_type (HsTupleTy HsBoxedOrConstraintTuple []) exp_kind
-  | otherwise = do 
-      (ty, k) <- kcTyVar name
-      checkExpectedKind ty k exp_kind
-      return ty
+kc_hs_type (HsTyVar name) exp_kind = do
+   (ty, k) <- kcTyVar name
+   checkExpectedKind ty k exp_kind
+   return ty
 
 kc_hs_type (HsListTy ty) exp_kind = do
     ty' <- kcLiftedType ty