Commit ac11b1f1 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor (again) the treatment of record-selector bindings

We were generating them from the tcg_tcs field of the TcGblEnv,
but that goes badly wrong when there are top-level Template
Haskell splices, because the tcg_tcs field grows successively.
If we generate record-selector binds for all the TyCons in the
accumulated list, we generate them multiple times for TyCons
earlier in the program.  This what was happening in Trac #5665:
  data T = T { x :: Int }
  $(f 4)  -- Top level splice
  ..more code..
Here the record selector bindings for T were being generated
twice.

Better instead to generate the record-selector bindings in
TcTyClsDecls, right where the new TyCons are being declared (as indeed
they were some time ago).  This pushed me into doing some refactoring:
instead of returning the record bindings, tcTyAndClassDecls adds them
to the tcg_binds field of the TcGblEnv.  I think the result is a bit
nicer, and it has the additional merit of working.
parent e332180e
......@@ -5,7 +5,7 @@
\section[TcBinds]{TcBinds}
\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
tcHsBootSigs, tcPolyBinds,
PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
TcSigInfo(..), SigFun, mkSigFun,
......@@ -16,7 +16,7 @@ import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import DynFlags
import HsSyn
import HscTypes( isHsBoot )
import TcRnMonad
import TcEnv
import TcUnify
......@@ -26,7 +26,6 @@ import TcPat
import TcMType
import TyCon
import TcType
-- import Coercion
import TysPrim
import Id
import Var
......@@ -83,21 +82,37 @@ At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.
\begin{code}
tcTopBinds :: HsValBinds Name
-> TcM ( LHsBinds TcId -- Typechecked bindings
, [LTcSpecPrag] -- SPECIALISE prags for imported Ids
, TcLclEnv) -- Augmented environment
-- Note: returning the TcLclEnv is more than we really
-- want. The bit we care about is the local bindings
-- and the free type variables thereof
tcTopBinds binds
= do { (ValBindsOut prs sigs, env) <- tcValBinds TopLevel binds getLclEnv
; let binds = foldr (unionBags . snd) emptyBag prs
; specs <- tcImpPrags sigs
; return (binds, specs, env) }
tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
tcTopBinds (ValBindsOut binds sigs)
= do { tcg_env <- getGblEnv
; (binds', tcl_env) <- tcValBinds TopLevel binds sigs getLclEnv
; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
(tcg_binds tcg_env)
binds'
, tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }
; return (tcg_env', tcl_env) }
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive LHsBinds
tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
tcRecSelBinds (ValBindsOut binds sigs)
= tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
; let tcg_env'
| isHsBoot (tcg_src tcg_env) = tcg_env
| otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
(tcg_binds tcg_env)
rec_sel_binds }
-- Do not add the code for record-selector bindings when
-- compiling hs-boot files
; return tcg_env' }
tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
......@@ -125,9 +140,10 @@ tcLocalBinds EmptyLocalBinds thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds, thing) }
tcLocalBinds (HsValBinds binds) thing_inside
= do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
; return (HsValBinds binds', thing) }
tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
= do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
; return (HsValBinds (ValBindsOut binds' sigs), thing) }
tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
= do { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
......@@ -168,13 +184,11 @@ untouchable-range idea.
\begin{code}
tcValBinds :: TopLevelFlag
-> HsValBinds Name -> TcM thing
-> TcM (HsValBinds TcId, thing)
tcValBinds _ (ValBindsIn binds _) _
= pprPanic "tcValBinds" (ppr binds)
-> [(RecFlag, LHsBinds Name)] -> [LSig Name]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
tcValBinds top_lvl binds sigs thing_inside
= do { -- Typecheck the signature
; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
; ty_sigs = filter isTypeLSig sigs
......@@ -193,7 +207,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
tcBindGroups top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
; return (binds', thing) }
------------------------
tcBindGroups :: TopLevelFlag -> SigFun -> PragFun
......
......@@ -337,7 +337,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
; let all_tycons = map ATyCon (bagToList newTyCons)
; gbl_env <- tcExtendGlobalEnv all_tycons $
tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
......
......@@ -52,7 +52,6 @@ import Bag
import BasicTypes
import DynFlags
import FastString
import HscTypes
import Id
import MkId
import Name
......@@ -380,20 +379,20 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
; implicit_things = concatMap implicitTyConThings at_idx_tycons
; aux_binds = mkRecSelBinds at_idx_tycons }
; at_things = map ATyCon at_idx_tycons }
-- (2) Add the tycons of indexed types and their implicit
-- tythings to the global environment
; tcExtendGlobalEnvImplicit
(map ATyCon at_idx_tycons ++ implicit_things) $ do {
; tcExtendGlobalEnvImplicit at_things $ do
{ tcg_env <- tcAddImplicits at_things
; setGblEnv tcg_env $
-- Next, construct the instance environment so far, consisting
-- of
-- (a) local instance decls
-- (b) local family instance decls
; addInsts local_info $
addInsts local_info $
addFamInsts at_idx_tycons $ do {
-- (3) Compute instances from "deriving" clauses;
......@@ -422,7 +421,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; return ( gbl_env
, (bagToList deriv_inst_info) ++ local_info
, aux_binds `plusHsValBinds` deriv_binds)
, deriv_binds)
}}}
where
typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames
......@@ -945,7 +944,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tc_item (sel_id, dm_info)
= case findMethodBind (idName sel_id) binds of
Just user_bind -> tc_body sel_id standalone_deriv user_bind
Nothing -> tc_default sel_id dm_info
Nothing -> traceTc "tc_def" (ppr sel_id) >>
tc_default sel_id dm_info
----------------------
tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
......@@ -971,7 +971,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
; tc_body sel_id False {- Not generated code? -} meth_bind }
tc_default sel_id NoDefMeth -- No default method at all
= do { warnMissingMethod sel_id
= do { traceTc "tc_def: warn" (ppr sel_id)
; warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; return (meth_id, mkVarBind meth_id $
......@@ -1163,6 +1164,7 @@ derivBindCtxt sel_id clas tys _bind
warnMissingMethod :: Id -> TcM ()
warnMissingMethod sel_id
= do { warn <- woptM Opt_WarnMissingMethods
; traceTc "warn" (ppr sel_id <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName sel_id))))
; warnTc (warn -- Warn only if -fwarn-missing-methods
&& not (startsWithUnderscore (getOccName sel_id)))
-- Don't warn about _foo methods
......
......@@ -344,7 +344,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
setGblEnv tcg_env $ do {
......@@ -557,7 +557,6 @@ tcRnHsBootDecls decls
-- Typecheck type/class decls
; traceTc "Tc2" empty
; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
; let aux_binds = mkRecSelBinds [tc | ATyCon tc <- nameEnvElts (tcg_type_env tcg_env)]
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
......@@ -580,18 +579,13 @@ tcRnHsBootDecls decls
-- Make the final type-env
-- Include the dfun_ids so that their type sigs
-- are written into the interface file.
-- And similarly the aux_ids from aux_binds
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
; type_env3 = extendTypeEnvWithIds type_env2 aux_ids
; dfun_ids = map iDFunId inst_infos
; aux_ids = case aux_binds of
ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
_ -> panic "tcRnHsBoodDecls"
}
; setGlobalTypeEnv gbl_env type_env3
; setGlobalTypeEnv gbl_env type_env2
}}}
; traceTc "boot" (ppr lie); return gbl_env }
......@@ -907,10 +901,7 @@ tcTopSrcDecls boot_details
traceTc "Tc2" empty ;
tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
let { aux_binds = mkRecSelBinds [tc | tc <- tcg_tcs tcg_env] } ;
-- If there are any errors, tcTyAndClassDecls fails here
setGblEnv tcg_env $ do {
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
......@@ -932,16 +923,13 @@ tcTopSrcDecls boot_details
-- Now GHC-generated derived bindings, generics, and selectors
-- Do not generate warnings from compiler-generated code;
-- hence the use of discardWarnings
(tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
(tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $
discardWarnings (tcTopBinds deriv_binds) ;
tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
setEnvs tc_envs $ do {
-- Value declarations next
traceTc "Tc5" empty ;
(tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
tcTopBinds val_binds;
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
setEnvs tc_envs $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
-- now using the kind-checked decls
......@@ -963,11 +951,7 @@ tcTopSrcDecls boot_details
-- Wrap up
traceTc "Tc7a" empty ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
tc_aux_binds `unionBags`
inst_binds `unionBags`
let { all_binds = inst_binds `unionBags`
foe_binds
; sig_names = mkNameSet (collectHsValBinders val_binds)
......@@ -976,8 +960,6 @@ tcTopSrcDecls boot_details
-- Extend the GblEnv with the (as yet un-zonked)
-- bindings, rules, foreign decls
; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
, tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++
specs3
, tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names
, tcg_rules = tcg_rules tcg_env ++ rules
, tcg_vects = tcg_vects tcg_env ++ vects
......@@ -985,7 +967,7 @@ tcTopSrcDecls boot_details
, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}
}}}}}}}
\end{code}
......
......@@ -611,10 +611,15 @@ discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
= do { errs_var <- newTcRef emptyMessages
; result <- setErrsVar errs_var thing_inside
; (_warns, errs) <- readTcRef errs_var
; addMessages (emptyBag, errs)
= do { errs_var <- getErrsVar
; (old_warns, _) <- readTcRef errs_var ;
; result <- thing_inside
-- Revert warnings to old_warns
; (_new_warns, new_errs) <- readTcRef errs_var
; writeTcRef errs_var (old_warns, new_errs)
; return result }
\end{code}
......@@ -627,7 +632,7 @@ discardWarnings thing_inside
\begin{code}
addReport :: Message -> Message -> TcRn ()
addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
addReport msg extra_info = do { traceTc "addr" msg; loc <- getSrcSpanM; addReportAt loc msg extra_info }
addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
addReportAt loc msg extra_info
......
......@@ -14,7 +14,7 @@ TcTyClsDecls: Typecheck type and class declarations
-- for details
module TcTyClsDecls (
tcTyAndClassDecls, mkRecSelBinds,
tcTyAndClassDecls, tcAddImplicits,
-- Functions used by TcInstDcls to check
-- data/type family instance declarations
......@@ -31,12 +31,13 @@ import BuildTyCl
import TcUnify
import TcRnMonad
import TcEnv
import TcBinds( tcRecSelBinds )
import TcTyDecls
import TcClassDcl
import TcHsType
import TcMType
import TcType
import TysWiredIn ( unitTy )
import TysWiredIn( unitTy )
import Type
import Kind
import Class
......@@ -96,9 +97,9 @@ instantiate k to *.
\begin{code}
tcTyAndClassDecls :: ModDetails
-> [TyClGroup Name] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv) -- Input env extended by types and classes
-- and their implicit Ids,DataCons
-> [TyClGroup Name] -- Mutually-recursive groups in dependency order
-> TcM TcGblEnv -- Input env extended by types and classes
-- and their implicit Ids,DataCons
-- Fails if there are any errors
tcTyAndClassDecls boot_details decls_s
= checkNoErrs $ do -- The code recovers internally, but if anything gave rise to
......@@ -111,8 +112,8 @@ tcTyAndClassDecls boot_details decls_s
fold_env :: [TyClGroup Name] -> TcM TcGblEnv
fold_env [] = getGblEnv
fold_env (tyclds:tyclds_s)
= do { env <- tcTyClGroup boot_details tyclds
; setGblEnv env $ fold_env tyclds_s }
= do { tcg_env <- tcTyClGroup boot_details tyclds
; setGblEnv tcg_env $ fold_env tyclds_s }
-- remaining groups are typecheck in the extended global env
tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv
......@@ -154,11 +155,16 @@ tcTyClGroup boot_details tyclds
-- Step 4: Add the implicit things;
-- we want them in the environment because
-- they may be mentioned in interface files
; let implicit_things = concatMap implicitTyThings tyclss
dm_ids = mkDefaultMethodIds tyclss
; tcExtendGlobalEnvImplicit implicit_things $
tcExtendGlobalValEnv dm_ids $
getGblEnv } }
; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $
tcAddImplicits tyclss } }
tcAddImplicits :: [TyThing] -> TcM TcGblEnv
tcAddImplicits tyclss
= tcExtendGlobalEnvImplicit implicit_things $
tcRecSelBinds rec_sel_binds
where
implicit_things = concatMap implicitTyThings tyclss
rec_sel_binds = mkRecSelBinds tyclss
zipRecTyClss :: TyClGroup Name
-> [TyThing] -- Knot-tied
......@@ -1472,7 +1478,7 @@ must bring the default method Ids into scope first (so they can be seen
when typechecking the [d| .. |] quote, and typecheck them later.
\begin{code}
mkRecSelBinds :: [TyCon] -> HsValBinds Name
mkRecSelBinds :: [TyThing] -> HsValBinds Name
-- NB We produce *un-typechecked* bindings, rather like 'deriving'
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
......@@ -1481,7 +1487,7 @@ mkRecSelBinds tycons
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
| tc <- tycons
| ATyCon tc <- tycons
, fld <- tyConFields tc ]
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
......
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