Commit 28f41f1a authored by Ryan Scott's avatar Ryan Scott

Fix #16002 by moving a validity check to the renamer

Summary:
The validity check which rejected things like:

```lang=haskell
type family B x where
  A x = x
```

Used to live in the typechecker. But it turns out that this validity
check was //only// being run on closed type families without CUSKs!
This meant that GHC would silently accept something like this:

```lang=haskell
type family B (x :: *) :: * where
  A x = x
```

This patch fixes the issue by moving this validity check to the
renamer, where we can be sure that the check will //always// be run.

Test Plan: make test TEST=T16002

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: goldfire, rwbarton, carter

GHC Trac Issues: #16002

Differential Revision: https://phabricator.haskell.org/D5420
parent 5f2a8793
......@@ -30,7 +30,8 @@ import RnEnv
import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames
, checkDupRdrNames, inHsDocContext, bindLocalNamesFV
, checkShadowedRdrNames, warnUnusedTypePatterns
, extendTyVarEnvFVRn, newLocalBndrsRn )
, extendTyVarEnvFVRn, newLocalBndrsRn
, withHsDocContext )
import RnUnbound ( mkUnboundName, notInScopeErr )
import RnNames
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
......@@ -804,18 +805,36 @@ rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
= do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
= do { (eqn', fvs) <- rnTyFamInstEqn mb_cls NotClosedTyFam eqn
; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
-- | Tracks whether we are renaming an equation in a closed type family
-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
data ClosedTyFamInfo
= NotClosedTyFam
| ClosedTyFam (Located RdrName) Name
-- The names (RdrName and Name) of the closed type family
rnTyFamInstEqn :: Maybe (Name, [Name])
-> ClosedTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})
rnTyFamInstEqn mb_cls ctf_info
eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})
= do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
; (eqn'@(HsIB { hsib_body =
FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)
<- rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn
; case ctf_info of
NotClosedTyFam -> pure ()
ClosedTyFam fam_rdr_name fam_name ->
checkTc (fam_name == tycon') $
withHsDocContext (TyFamilyCtx fam_rdr_name) $
wrongTyFamName fam_name tycon'
; pure (eqn', fvs) }
rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn GhcPs
......@@ -1853,7 +1872,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
injectivity
; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
; (info', fv2) <- rn_info info
; (info', fv2) <- rn_info tycon' info
; return (FamilyDecl { fdExt = noExt
, fdLName = tycon', fdTyVars = tyvars'
, fdFixity = fixity
......@@ -1865,14 +1884,18 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
kvs = extractRdrKindSigVars res_sig
----------------------
rn_info (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
-- no class context,
rn_info :: Located Name
-> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs)
<- rnList (rnTyFamInstEqn Nothing (ClosedTyFam tycon fam_name))
-- no class context
eqns
; return (ClosedTypeFamily (Just eqns'), fvs) }
rn_info (ClosedTypeFamily Nothing)
rn_info _ (ClosedTypeFamily Nothing)
= return (ClosedTypeFamily Nothing, emptyFVs)
rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info DataFamily = return (DataFamily, emptyFVs)
rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info _ DataFamily = return (DataFamily, emptyFVs)
rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
rnFamResultSig :: HsDocContext
......@@ -2026,6 +2049,12 @@ badAssocRhs ns
<+> pprWithCommas (quotes . ppr) ns)
2 (text "All such variables must be bound on the LHS"))
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName fam_tc_name eqn_tc_name
= hang (text "Mismatched type name in type family instance.")
2 (vcat [ text "Expected:" <+> ppr fam_tc_name
, text " Actual:" <+> ppr eqn_tc_name ])
-----------------
rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
......
......@@ -1733,8 +1733,6 @@ kcTyFamInstEqn tc_fam_tc
, text "hsib_vars =" <+> ppr imp_vars
, text "feqn_bndrs =" <+> ppr mb_expl_bndrs
, text "feqn_pats =" <+> ppr hs_pats ])
; checkTc (fam_name == eqn_tc_name)
(wrongTyFamName fam_name eqn_tc_name)
-- this check reports an arity error instead of a kind error; easier for user
; checkTc (hs_pats `lengthIs` vis_arity) $
wrongNumberOfParmsErr vis_arity
......@@ -1750,7 +1748,6 @@ kcTyFamInstEqn tc_fam_tc
-- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately
}
where
fam_name = tyConName tc_fam_tc
vis_arity = length (tyConVisibleTyVars tc_fam_tc)
kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"
......@@ -3813,12 +3810,6 @@ defaultAssocKindErr fam_tc
= text "Kind mis-match on LHS of default declaration for"
<+> quotes (ppr fam_tc)
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName fam_tc_name eqn_tc_name
= hang (text "Mismatched type name in type family instance.")
2 (vcat [ text "Expected:" <+> ppr fam_tc_name
, text " Actual:" <+> ppr eqn_tc_name ])
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot var annot inferred
= hang (text "Role mismatch on variable" <+> ppr var <> colon)
......
Overlap5.hs:8:3:
Overlap5.hs:8:3: error:
Mismatched type name in type family instance.
Expected: F
Actual: G
In the type family declaration for ‘F’
In the declaration for type family ‘F’
{-# LANGUAGE TypeFamilies #-}
module T16002 where
data A
type family B (x :: *) :: * where
A x = x
T16002.hs:6:3: error:
Mismatched type name in type family instance.
Expected: B
Actual: A
In the declaration for type family ‘B’
......@@ -142,5 +142,6 @@ test('T15607', normal, compile_fail, [''])
test('T15611a', normal, compile_fail, [''])
test('T15611b', normal, ghci_script, ['T15611b.script'])
test('T15828', normal, compile_fail, [''])
test('T16002', normal, compile_fail, [''])
test('ExplicitForAllRules2', normal, compile_fail, [''])
T11623.hs:5:23: error:
Mismatched type name in type family instance.
Expected: T
Actual: Maybe
• In the type family declaration for ‘T’
Mismatched type name in type family instance.
Expected: T
Actual: Maybe
In the declaration for type family ‘T’
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment