diff options
-rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 13 | ||||
-rw-r--r-- | compiler/parser/Parser.y.pp | 30 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 22 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.lhs | 12 |
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 |