Commit 17457791 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Simplify the plumbing for checkValidTyCl

Instead of walking over the source decls, and looking up the Name
to find the TyCon or whatever, we just walk over the list of
TyThings that have been brought into scope.  This is much tidier.

The only wrinkle is that, since we don't have the original declaration,
we don't have its SrcSpan to put in the error message.  I fixed this
by making the SrcSpan for the TyCon itself be the span of the whole
declaration.  This actually makes sense anyway.

There are bunch of error message wibbles in consequence.
parent 8d829544
......@@ -120,7 +120,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = reLocate loc cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs,
tcdFVs = placeHolderNames })) }
......@@ -137,7 +137,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tycl_hdr tparams
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
; return (L loc (DataDecl { tcdLName = reLocate loc tc, tcdTyVars = tyvars,
tcdDataDefn = defn,
tcdFVs = placeHolderNames })) }
......@@ -166,7 +166,7 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = cxt
, dd_ctxt = cxt
, dd_cons = data_cons
, dd_kindSig = ksig
, dd_derivs = maybe_deriv }) }
......@@ -178,8 +178,8 @@ mkTySynonym :: SrcSpan
mkTySynonym loc lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars lhs tparams
; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars,
tcdRhs = rhs, tcdFVs = placeHolderNames })) }
; return (L loc (SynDecl { tcdLName = reLocate loc tc, tcdTyVars = tyvars
, tcdRhs = rhs, tcdFVs = placeHolderNames })) }
mkTyFamInstEqn :: LHsType RdrName
-> LHsType RdrName
......@@ -205,7 +205,15 @@ mkFamDecl :: SrcSpan
mkFamDecl loc info lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars lhs tparams
; return (L loc (FamilyDecl info tc tyvars ksig)) }
; return (L loc (FamilyDecl { fdInfo = info, fdLName = reLocate loc tc
, fdTyVars = tyvars, fdKindSig = ksig })) }
reLocate :: SrcSpan -> Located a -> Located a
-- For the main binder of a declaration, we make its SrcSpan to
-- cover the whole declaration, rather than just the syntactic occurrence
-- of the binder. This makes error messages refer to the declaration as
-- a whole, rather than just the binding site
reLocate loc (L _ x) = L loc x
mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- If the user wrote
......
......@@ -156,7 +156,7 @@ tcTyClGroup boot_details tyclds
-- expects well-formed TyCons
; tcExtendGlobalEnv tyclss $ do
{ traceTc "Starting validity check" (ppr tyclss)
; mapM_ (recoverM (return ()) . addLocM (checkValidTyCl role_annots)) decls
; mapM_ (recoverM (return ()) . checkValidTyCl role_annots) tyclss
-- We recover, which allows us to report multiple validity errors
-- Step 4: Add the implicit things;
......@@ -1350,39 +1350,33 @@ checkClassCycleErrs cls
= unless (null cls_cycles) $ mapM_ recClsErr cls_cycles
where cls_cycles = calcClassCycles cls
checkValidDecl :: SDoc -- the context for error checking
-> Located Name -> RoleAnnots -> TcM ()
checkValidDecl ctxt lname role_annots
= addErrCtxt ctxt $
do { traceTc "Validity of 1" (ppr lname)
; env <- getGblEnv
; traceTc "Validity of 1a" (ppr (tcg_type_env env))
; thing <- tcLookupLocatedGlobal lname
; traceTc "Validity of 2" (ppr lname)
; traceTc "Validity of" (ppr thing)
; case thing of
ATyCon tc -> do
traceTc " of kind" (ppr (tyConKind tc))
checkValidTyCon tc role_annots
AnId _ -> return () -- Generic default methods are checked
-- with their parent class
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
checkValidTyCl :: RoleAnnots -> TyClDecl Name -> TcM ()
checkValidTyCl role_annots decl
= do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) role_annots
; case decl of
ClassDecl { tcdATs = ats } ->
mapM_ (checkValidFamDecl role_annots . unLoc) ats
_ -> return () }
checkValidFamDecl :: RoleAnnots -> FamilyDecl Name -> TcM ()
checkValidFamDecl role_annots (FamilyDecl { fdLName = lname, fdInfo = flav })
= checkValidDecl (hsep [ptext (sLit "In the"), ppr flav,
ptext (sLit "declaration for"), quotes (ppr lname)])
lname role_annots
checkValidTyCl :: RoleAnnots -> TyThing -> TcM ()
checkValidTyCl role_annots thing
= setSrcSpan (getSrcSpan name) $
addErrCtxt ctxt $
case thing of
ATyCon tc -> checkValidTyCon tc role_annots
AnId _ -> return () -- Generic default methods are checked
-- with their parent class
ACoAxiom _ -> return () -- Axioms checked with their parent
-- closed family tycon
_ -> pprTrace "checkValidTyCl" (ppr thing) $ return ()
where
name = getName thing
flav = case thing of
ATyCon tc
| isClassTyCon tc -> ptext (sLit "class")
| isSynFamilyTyCon tc -> ptext (sLit "type family")
| isDataFamilyTyCon tc -> ptext (sLit "data family")
| isSynTyCon tc -> ptext (sLit "type")
| isNewTyCon tc -> ptext (sLit "newtype")
| isDataTyCon tc -> ptext (sLit "data")
_ -> pprTrace "checkValidTyCl strange" (ppr thing)
empty
ctxt = hsep [ ptext (sLit "In the"), flav
, ptext (sLit "declaration for"), quotes (ppr name) ]
-------------------------
-- For data types declared with record syntax, we require
......
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