[Git][ghc/ghc][wip/T18470] Move renamer-based validity check to typechecker
Ryan Scott
gitlab at gitlab.haskell.org
Tue Jul 28 11:49:56 UTC 2020
Ryan Scott pushed to branch wip/T18470 at Glasgow Haskell Compiler / GHC
Commits:
83187784 by Ryan Scott at 2020-07-28T07:49:33-04:00
Move renamer-based validity check to typechecker
- - - - -
11 changed files:
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Types/Basic.hs
- testsuite/tests/indexed-types/should_fail/Overlap5.stderr
- testsuite/tests/rename/should_fail/T16002.stderr
- testsuite/tests/th/T15362.hs
- testsuite/tests/th/T15362.stderr
- testsuite/tests/typecheck/should_fail/T11623.stderr
Changes:
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -55,7 +55,7 @@ import GHC.Types.Name.Env
import GHC.Types.Avail
import GHC.Utils.Outputable
import GHC.Data.Bag
-import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) )
+import GHC.Types.Basic ( pprRuleName, TypeOrKind(..), ClosedTyFamInfo(..) )
import GHC.Data.FastString
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
@@ -763,7 +763,7 @@ rnFamInstEqn doc atfi rhs_kvars
; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
-- See Note [Type family equations and occurrences]
all_fvs = case atfi of
- NonAssocTyFamEqn (ClosedTyFam{})
+ NonAssocTyFamEqn ClosedTyFam
-> eqn_fvs
_ -> eqn_fvs `addOneFV` unLoc tycon'
@@ -851,34 +851,15 @@ data AssocTyFamInfo
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
-
rnTyFamInstEqn :: AssocTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
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
-
- -- For closed type families, check that each equation is for the
- -- right type family. E.g. barf on
- -- type family F a where { G Int = Bool }
- ; case atfi of
- NonAssocTyFamEqn (ClosedTyFam fam_rdr_name fam_name) ->
- checkTc (fam_name == tycon') $
- withHsDocContext (TyFamilyCtx fam_rdr_name) $
- wrongTyFamName fam_name tycon'
- _ -> pure ()
- ; pure (eqn', fvs) }
+ = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
+ where
+ rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
@@ -2023,7 +2004,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
@@ -2035,18 +2016,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
@@ -2190,13 +2169,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)
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Builtin.Types
import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon )
import GHC.Builtin.Names
+import GHC.Types.Basic ( ClosedTyFamInfo(..) )
import GHC.Types.Id
import GHC.Core.Type
import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr )
@@ -58,6 +59,7 @@ import Data.Maybe
-- The @VarEnv Type@ maps class variables to their instance types.
data AssocInstInfo
= NotAssociated
+ ClosedTyFamInfo -- Is this a closed type family?
| InClsInst { ai_class :: Class
, ai_tyvars :: [TyVar] -- ^ The /scoped/ tyvars of the instance
-- Why scoped? See bind_me in
@@ -67,8 +69,8 @@ data AssocInstInfo
}
isNotAssociated :: AssocInstInfo -> Bool
-isNotAssociated NotAssociated = True
-isNotAssociated (InClsInst {}) = False
+isNotAssociated (NotAssociated {}) = True
+isNotAssociated (InClsInst {}) = False
{- *******************************************************************
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -2432,7 +2432,7 @@ tcDefaultAssocDecl fam_tc
-- at an associated type. But this would be wrong, because an associated
-- type default LHS can mention *different* type variables than the
-- enclosing class. So it's treated more as a freestanding beast.
- ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated
+ ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc (NotAssociated NotClosedTyFam)
imp_vars (mb_expl_bndrs `orElse` [])
hs_pats hs_rhs_ty
@@ -2639,7 +2639,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
False {- this doesn't matter here -}
ClosedTypeFamilyFlavour
- ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns
+ ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc (NotAssociated ClosedTyFam)) eqns
-- Do not attempt to drop equations dominated by earlier
-- ones here; in the case of mutual recursion with a data
-- type, we get a knot-tying failure. Instead we check
@@ -2862,16 +2862,25 @@ tcTyFamInstEqn fam_tc mb_clsinfo
, 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
+ -- 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 }
+ ; case mb_clsinfo of
+ NotAssociated ClosedTyFam
+ -> checkTc (fam_tc_name == eqn_tc_name) $
+ wrongTyFamName fam_tc_name eqn_tc_name
+ _ -> pure ()
+
+ -- Next, 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.
; let vis_arity = length (tyConVisibleTyVars fam_tc)
@@ -2886,6 +2895,8 @@ tcTyFamInstEqn fam_tc mb_clsinfo
; return (mkCoAxBranch qtvs [] [] pats rhs_ty
(map (const Nominal) qtvs)
loc) }
+ where
+ fam_tc_name = getName fam_tc
{-
Kind check type patterns and kind annotate the embedded type variables.
@@ -4919,6 +4930,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
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -458,11 +458,11 @@ tcLocalInstDecl :: LInstDecl GhcRn
--
-- We check for respectable instance type, and context
tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
- = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)
+ = do { fam_inst <- tcTyFamInstDecl (NotAssociated NotClosedTyFam) (L loc decl)
; return ([], [fam_inst], []) }
tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
- = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl)
+ = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl (NotAssociated NotClosedTyFam) emptyVarEnv (L loc decl)
; return ([], [fam_inst], maybeToList m_deriv_info) }
tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -2271,7 +2271,7 @@ checkConsistentFamInst :: AssocInstInfo
-> TcM ()
-- See Note [Checking consistent instantiation]
-checkConsistentFamInst NotAssociated _ _
+checkConsistentFamInst (NotAssociated {}) _ _
= return ()
checkConsistentFamInst (InClsInst { ai_class = clas
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -108,7 +108,9 @@ module GHC.Types.Basic (
SpliceExplicitFlag(..),
- TypeOrKind(..), isTypeLevel, isKindLevel
+ TypeOrKind(..), isTypeLevel, isKindLevel,
+
+ ClosedTyFamInfo(..)
) where
import GHC.Prelude
@@ -1843,3 +1845,16 @@ isTypeLevel KindLevel = False
isKindLevel :: TypeOrKind -> Bool
isKindLevel TypeLevel = False
isKindLevel KindLevel = True
+
+{-
+************************************************************************
+* *
+ ClosedTyFamInfo
+* *
+************************************************************************
+-}
+
+-- | Is a type family closed ('ClosedTyFam') or not ('NotClosedTyFam')?
+data ClosedTyFamInfo
+ = NotClosedTyFam
+ | ClosedTyFam
=====================================
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’
=====================================
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’
=====================================
testsuite/tests/th/T15362.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds #-}
+{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds, TypeFamilies #-}
module T15362 where
=====================================
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 ‘+’
=====================================
testsuite/tests/typecheck/should_fail/T11623.stderr
=====================================
@@ -1,6 +1,4 @@
T11623.hs:5:23: error:
- Mismatched type name in type family instance.
- Expected: T
- Actual: Maybe
- In the declaration for type family ‘T’
+ • Number of parameters must match family declaration; expected 0
+ • In the type family declaration for ‘T’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83187784fac82b6e8db016cc68e4d8ae07c83856
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83187784fac82b6e8db016cc68e4d8ae07c83856
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200728/f2334c0f/attachment-0001.html>
More information about the ghc-commits
mailing list