summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Rename/Module.hs142
-rw-r--r--compiler/GHC/Tc/Instance/Class.hs4
-rw-r--r--compiler/GHC/Tc/TyCl.hs27
-rw-r--r--testsuite/tests/indexed-types/should_fail/Overlap5.stderr8
-rw-r--r--testsuite/tests/rename/should_fail/T16002.stderr8
-rw-r--r--testsuite/tests/th/T15362.hs2
-rw-r--r--testsuite/tests/th/T15362.stderr8
-rw-r--r--testsuite/tests/typecheck/should_compile/T18470.hs7
-rw-r--r--testsuite/tests/typecheck/should_compile/T18470.stderr3
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T1
-rw-r--r--testsuite/tests/typecheck/should_fail/T11623.stderr8
11 files changed, 147 insertions, 71 deletions
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 15775b8cf2..b6c8a9b801 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -424,11 +424,11 @@ patchCCallTarget unit callTarget =
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
- = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi
+ = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi
; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
- = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi
+ = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi
; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }
rnSrcInstDecl (ClsInstD { cid_inst = cid })
@@ -760,8 +760,12 @@ rnFamInstEqn doc atfi rhs_kvars
all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
; warnUnusedTypePatterns all_nms nms_used
- ; let all_fvs = (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon'
- -- type instance => use, hence addOneFV
+ ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
+ -- See Note [Type family equations and occurrences]
+ all_fvs = case atfi of
+ NonAssocTyFamEqn ClosedTyFam
+ -> eqn_fvs
+ _ -> eqn_fvs `addOneFV` unLoc tycon'
; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
, hsib_body
@@ -776,14 +780,14 @@ rnFamInstEqn doc atfi rhs_kvars
-- The parent class, if we are dealing with an associated type family
-- instance.
mb_cls = case atfi of
- NonAssocTyFamEqn -> Nothing
+ NonAssocTyFamEqn _ -> Nothing
AssocTyFamDeflt cls -> Just cls
AssocTyFamInst cls _ -> Just cls
-- The type variables from the instance head, if we are dealing with an
-- associated type family instance.
inst_tvs = case atfi of
- NonAssocTyFamEqn -> []
+ NonAssocTyFamEqn _ -> []
AssocTyFamDeflt _ -> []
AssocTyFamInst _ inst_tvs -> inst_tvs
@@ -806,48 +810,62 @@ rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })
- = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn
+ = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn
; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
-- | Tracks whether we are renaming:
--
-- 1. A type family equation that is not associated
--- with a parent type class ('NonAssocTyFamEqn')
+-- with a parent type class ('NonAssocTyFamEqn'). Examples:
--
--- 2. An associated type family default declaration ('AssocTyFamDeflt')
+-- @
+-- type family F a
+-- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed
--
--- 3. An associated type family instance declaration ('AssocTyFamInst')
+-- type family G a where
+-- G Int = Bool -- NonAssocTyFamEqn Closed
+-- @
+--
+-- 2. An associated type family default declaration ('AssocTyFamDeflt').
+-- Example:
+--
+-- @
+-- class C a where
+-- type A a
+-- type instance A a = a -> a -- AssocTyFamDeflt C
+-- @
+--
+-- 3. An associated type family instance declaration ('AssocTyFamInst').
+-- Example:
+--
+-- @
+-- instance C a => C [a] where
+-- type A [a] = Bool -- AssocTyFamInst C [a]
+-- @
data AssocTyFamInfo
= NonAssocTyFamEqn
- | AssocTyFamDeflt Name -- Name of the parent class
- | AssocTyFamInst Name -- Name of the parent class
- [Name] -- Names of the tyvars of the parent instance decl
+ ClosedTyFamInfo -- Is this a closed type family?
+ | AssocTyFamDeflt
+ Name -- Name of the parent class
+ | AssocTyFamInst
+ Name -- Name of the parent class
+ [Name] -- Names of the tyvars of the parent instance decl
-- | 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
+ | ClosedTyFam
rnTyFamInstEqn :: AssocTyFamInfo
- -> ClosedTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn atfi ctf_info
+rnTyFamInstEqn atfi
eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_rhs = rhs }})
- = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
- ; (eqn'@(HsIB { hsib_body =
- FamEqn { feqn_tycon = L _ tycon' }}), fvs)
- <- rnFamInstEqn (TySynCtx tycon) atfi 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) }
+ = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
+ where
+ rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
@@ -995,6 +1013,51 @@ was previously bound by the `instance C (Maybe a)` part. (see #16116).
In each case, the function which detects improperly bound variables on the RHS
is GHC.Tc.Validity.checkValidFamPats.
+
+Note [Type family equations and occurrences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In most data/type family equations, the type family name used in the equation
+is treated as an occurrence. For example:
+
+ module A where
+ type family F a
+
+ module B () where
+ import B (F)
+ type instance F Int = Bool
+
+We do not want to warn about `F` being unused in the module `B`, as the
+instance constitutes a use site for `F`. The exception to this rule is closed
+type families, whose equations constitute a definition, not occurrences. For
+example:
+
+ module C () where
+ type family CF a where
+ CF Char = Float
+
+Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is
+defined but not used (#18470).
+
+GHC accomplishes this in rnFamInstEqn when determining the set of free
+variables to return at the end. If renaming a data family or open type family
+equation, we add the name of the type family constructor to the set of returned
+free variables to ensure that the name is marked as an occurrence. If renaming
+a closed type family equation, we avoid adding the type family constructor name
+to the free variables. This is quite simple, but it is not a perfect solution.
+Consider this example:
+
+ module X () where
+ type family F a where
+ F Int = Bool
+ F Double = F Int
+
+At present, GHC will treat any use of a type family constructor on the RHS of a
+type family equation as an occurrence. Since `F` is used on the RHS of the
+second equation of `F`, it is treated as an occurrence, causing `F` not to be
+warned about. This is not ideal, since `F` isn't exported—it really /should/
+cause a warning to be emitted. There is some discussion in #10089/#12920 about
+how this limitation might be overcome, but until then, we stick to the
+simplistic solution above, as it fixes the egregious bug in #18470.
-}
@@ -1947,7 +2010,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 tycon' info
+ ; (info', fv2) <- rn_info info
; return (FamilyDecl { fdExt = noExtField
, fdLName = tycon', fdTyVars = tyvars'
, fdFixity = fixity
@@ -1959,18 +2022,16 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
kvs = extractRdrKindSigVars res_sig
----------------------
- rn_info :: Located Name
- -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
- rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns))
+ rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
+ rn_info (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs)
- <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))
+ <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns
-- 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)
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs
@@ -2114,13 +2175,6 @@ are no data constructors we allow h98_style = True
* *
***************************************************** -}
----------------
-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)
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 5446a756a3..c5fc5bcdbe 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -67,8 +67,8 @@ data AssocInstInfo
}
isNotAssociated :: AssocInstInfo -> Bool
-isNotAssociated NotAssociated = True
-isNotAssociated (InClsInst {}) = False
+isNotAssociated (NotAssociated {}) = True
+isNotAssociated (InClsInst {}) = False
{- *******************************************************************
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 013892ee6e..6d33be2e61 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -2833,8 +2833,17 @@ kcTyFamInstEqn tc_fam_tc
, text "feqn_pats =" <+> ppr hs_pats ])
-- this check reports an arity error instead of a kind error; easier for user
; let vis_pats = numVisibleArgs hs_pats
+
+ -- First, check if we're dealing with a closed type family equation, and
+ -- if so, ensure that each equation's type constructor is for the right
+ -- type family. E.g. barf on
+ -- type family F a where { G Int = Bool }
+ ; checkTc (tc_fam_tc_name == eqn_tc_name) $
+ wrongTyFamName tc_fam_tc_name eqn_tc_name
+
; checkTc (vis_pats == vis_arity) $
wrongNumberOfParmsErr vis_arity
+
; discardResult $
bindImplicitTKBndrs_Q_Tv imp_vars $
bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
@@ -2848,7 +2857,7 @@ kcTyFamInstEqn tc_fam_tc
}
where
vis_arity = length (tyConVisibleTyVars tc_fam_tc)
-
+ tc_fam_tc_name = getName tc_fam_tc
--------------------------
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
@@ -2858,22 +2867,22 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
tcTyFamInstEqn fam_tc mb_clsinfo
(L loc (HsIB { hsib_ext = imp_vars
- , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name
- , feqn_bndrs = mb_expl_bndrs
+ , hsib_body = FamEqn { feqn_bndrs = mb_expl_bndrs
, feqn_pats = hs_pats
, feqn_rhs = hs_rhs_ty }}))
- = ASSERT( getName fam_tc == eqn_tc_name )
- setSrcSpan loc $
+ = setSrcSpan loc $
do { traceTc "tcTyFamInstEqn" $
vcat [ ppr fam_tc <+> ppr hs_pats
, text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
, case mb_clsinfo of
- NotAssociated -> empty
+ NotAssociated {} -> empty
InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ]
-- First, check the arity of visible arguments
-- If we wait until validity checking, we'll get kind errors
-- below when an arity error will be much easier to understand.
+ -- Note that for closed type families, kcTyFamInstEqn has already
+ -- checked the arity previously.
; let vis_arity = length (tyConVisibleTyVars fam_tc)
vis_pats = numVisibleArgs hs_pats
; checkTc (vis_pats == vis_arity) $
@@ -4919,6 +4928,12 @@ incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>
text "for class parameters can lead to incoherence.") $$
(text "Use IncoherentInstances to allow this; bad role found")
+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 ])
+
addTyConCtxt :: TyCon -> TcM a -> TcM a
addTyConCtxt tc = addTyConFlavCtxt name flav
where
diff --git a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
index 512859753c..f67549104b 100644
--- a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
+++ b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
@@ -1,6 +1,6 @@
Overlap5.hs:8:3: error:
- Mismatched type name in type family instance.
- Expected: F
- Actual: G
- In the declaration for type family ‘F’
+ • Mismatched type name in type family instance.
+ Expected: F
+ Actual: G
+ • In the type family declaration for ‘F’
diff --git a/testsuite/tests/rename/should_fail/T16002.stderr b/testsuite/tests/rename/should_fail/T16002.stderr
index 98db6f99b6..91279ffeeb 100644
--- a/testsuite/tests/rename/should_fail/T16002.stderr
+++ b/testsuite/tests/rename/should_fail/T16002.stderr
@@ -1,6 +1,6 @@
T16002.hs:6:3: error:
- Mismatched type name in type family instance.
- Expected: B
- Actual: A
- In the declaration for type family ‘B’
+ • Mismatched type name in type family instance.
+ Expected: B
+ Actual: A
+ • In the type family declaration for ‘B’
diff --git a/testsuite/tests/th/T15362.hs b/testsuite/tests/th/T15362.hs
index 183f887252..1bab4d776c 100644
--- a/testsuite/tests/th/T15362.hs
+++ b/testsuite/tests/th/T15362.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds #-}
+{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds, TypeFamilies #-}
module T15362 where
diff --git a/testsuite/tests/th/T15362.stderr b/testsuite/tests/th/T15362.stderr
index 0ec2dd8e48..b63cb3553e 100644
--- a/testsuite/tests/th/T15362.stderr
+++ b/testsuite/tests/th/T15362.stderr
@@ -1,10 +1,6 @@
-T15362.hs:8:10: error:
+T15362.hs:7:2: error:
• Mismatched type name in type family instance.
Expected: +
Actual: Maybe
- In the declaration for type family ‘+’
- • In the Template Haskell quotation
- [d| type family a + b where
- Maybe Zero b = b
- Succ a + b = Succ (a + b) |]
+ • In the type family declaration for ‘+’
diff --git a/testsuite/tests/typecheck/should_compile/T18470.hs b/testsuite/tests/typecheck/should_compile/T18470.hs
new file mode 100644
index 0000000000..618c1433ff
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T18470.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wunused-top-binds #-}
+
+module T18470 () where
+
+type family Closed x where
+ Closed Int = Bool
diff --git a/testsuite/tests/typecheck/should_compile/T18470.stderr b/testsuite/tests/typecheck/should_compile/T18470.stderr
new file mode 100644
index 0000000000..ffefb020d3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T18470.stderr
@@ -0,0 +1,3 @@
+
+T18470.hs:6:1: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)]
+ Defined but not used: type constructor or class ‘Closed’
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 82a30f50f4..d720891df5 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -717,3 +717,4 @@ test('T17775-viewpats-b', normal, compile_fail, [''])
test('T17775-viewpats-c', normal, compile_fail, [''])
test('T17775-viewpats-d', normal, compile_fail, [''])
test('T18412', normal, compile, [''])
+test('T18470', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T11623.stderr b/testsuite/tests/typecheck/should_fail/T11623.stderr
index 78be1651e2..0f6253f103 100644
--- a/testsuite/tests/typecheck/should_fail/T11623.stderr
+++ b/testsuite/tests/typecheck/should_fail/T11623.stderr
@@ -1,6 +1,6 @@
T11623.hs:5:23: error:
- Mismatched type name in type family instance.
- Expected: T
- Actual: Maybe
- In the declaration for type family ‘T’
+ • Mismatched type name in type family instance.
+ Expected: T
+ Actual: Maybe
+ • In the type family declaration for ‘T’
View Lorry Controller Status