Commit 43b08cfb authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add a solveEqualities to tcClassDecl1

Trac #15505 showed that, when we have a type error, we
could have an unfilled-in coercion hole.  We don't want an
assertion error in that case.

The underlying cause is that tcClassDecl1 should call
solveEqualities to fully solve all top-level equalities
(or fail in the attempt).

I also refactored the ClassDecl case for tcTyClDecl1 into
a new function tcClassDecl1.  That makes it symmetrical
with the others.
parent 828e9493
......@@ -470,10 +470,10 @@ repAssocTyFamDefaults = mapM rep_deflt
-------------------------
-- represent fundeps
--
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
repLFunDeps fds = repList funDepTyConName repLFunDep fds
repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys))
= do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
ys' <- repList nameTyConName (lookupBinder . unLoc) ys
......
......@@ -598,7 +598,7 @@ cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
; returnL cs' }
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
; ys' <- mapM tNameL ys
; returnL (xs', ys') }
......
......@@ -18,7 +18,7 @@
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
module HsDecls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
-- ** Class or type declarations
......@@ -528,8 +528,7 @@ data TyClDecl pass
tcdLName :: Located (IdP pass), -- ^ Name of the class
tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables
tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration
tcdFDs :: [Located (FunDep (Located (IdP pass)))],
-- ^ Functional deps
tcdFDs :: [LHsFunDep pass], -- ^ Functional deps
tcdSigs :: [LSig pass], -- ^ Methods' signatures
tcdMeths :: LHsBinds pass, -- ^ Default methods
tcdATs :: [LFamilyDecl pass], -- ^ Associated types;
......@@ -546,6 +545,8 @@ data TyClDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
| XTyClDecl (XXTyClDecl pass)
type LHsFunDep pass = Located (FunDep (Located (IdP pass)))
data DataDeclRn = DataDeclRn
{ tcdDataCusk :: Bool -- ^ does this have a CUSK?
, tcdFVs :: NameSet }
......
......@@ -78,7 +78,6 @@ module RdrHsSyn (
import GhcPrelude
import HsSyn -- Lots of it
import Class ( FunDep )
import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
import DataCon ( DataCon, dataConTyCon )
import ConLike ( ConLike(..) )
......@@ -142,7 +141,7 @@ mkInstD (L loc d) = L loc (InstD noExt d)
mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[Located (FunDep (Located RdrName))])
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
-> P (LTyClDecl GhcPs)
......
......@@ -2141,8 +2141,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
*********************************************************
-}
rnFds :: [Located (FunDep (Located RdrName))]
-> RnM [Located (FunDep (Located Name))]
rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds fds
= mapM (wrapLocM rn_fds) fds
where
......
......@@ -207,7 +207,8 @@ tcHsSigType ctxt sig_ty
-- of kind * in a Template Haskell quote eg [t| Maybe |]
-- Generalise here: see Note [Kind generalisation]
; ty <- tc_hs_sig_type_and_gen skol_info sig_ty kind >>= zonkTcType
; ty <- tc_hs_sig_type_and_gen skol_info sig_ty kind
; ty <- zonkTcType ty
; checkValidType ctxt ty
; traceTc "end tcHsSigType }" (ppr ty)
......@@ -226,10 +227,9 @@ tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext = sig_vars
= do { ((tkvs, ty), wanted) <- captureConstraints $
tcImplicitTKBndrs skol_info sig_vars $
tc_lhs_type typeLevelMode hs_ty kind
-- Any remaining variables (unsolved in the solveLocalEqualities in the
-- tcImplicitTKBndrs)
-- should be in the global tyvars, and therefore won't be quantified
-- over.
-- Any remaining variables (unsolved in the solveLocalEqualities
-- in the tcImplicitTKBndrs) should be in the global tyvars,
-- and therefore won't be quantified over
; let ty1 = mkSpecForAllTys tkvs ty
; kvs <- kindGeneralizeLocal wanted ty1
......
This diff is collapsed.
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