[Git][ghc/ghc][wip/T18470] Move renamer-based validity check to typechecker

Ryan Scott gitlab at gitlab.haskell.org
Tue Jul 28 01:18:57 UTC 2020



Ryan Scott pushed to branch wip/T18470 at Glasgow Haskell Compiler / GHC


Commits:
f6e8c7f2 by Ryan Scott at 2020-07-27T21:18:23-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,13 +851,6 @@ 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)
@@ -865,19 +858,8 @@ 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)
+       ; (eqn', 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) }
 
 rnTyFamDefltDecl :: Name
@@ -2023,7 +2005,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 +2017,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 +2170,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/f6e8c7f27f2871d89797defaa69509995c30fa11

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6e8c7f27f2871d89797defaa69509995c30fa11
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/20200727/25ccb7b1/attachment-0001.html>


More information about the ghc-commits mailing list