[commit: ghc] master: Simplify the plumbing for checkValidTyCl (1745779)
git at git.haskell.org
git
Fri Oct 4 18:16:21 UTC 2013
Repository : ssh://git at git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/174577912de7a21b8fe01881a28f5aafce02b92e/ghc
>---------------------------------------------------------------
commit 174577912de7a21b8fe01881a28f5aafce02b92e
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Fri Oct 4 18:50:08 2013 +0100
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.
>---------------------------------------------------------------
174577912de7a21b8fe01881a28f5aafce02b92e
compiler/parser/RdrHsSyn.lhs | 18 +++++++---
compiler/typecheck/TcTyClsDecls.lhs | 62 ++++++++++++++++-------------------
2 files changed, 41 insertions(+), 39 deletions(-)
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 715af25..363d49f 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -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 })) }
@@ -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
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c4d24d4..6736e2d 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -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
More information about the ghc-commits
mailing list