diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2018-06-15 09:46:30 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2018-06-15 09:47:41 +0100 |
commit | 2f6069ccf21d7be0e09016896238f417d2492ffa (patch) | |
tree | 937dde091434ea52e47d279483eab6b77bda4099 /compiler/typecheck/TcTyDecls.hs | |
parent | f903e5510d4562fddef1d4140971e2b93a45e45e (diff) | |
download | haskell-2f6069ccf21d7be0e09016896238f417d2492ffa.tar.gz |
Make better "fake tycons" in error recovery
Consider (Trac #15215)
data T a = MkT ...
data S a = ...T...MkT....
If there is an error in the definition of 'T' we add a
"fake type constructor" to the type environment, so that we
can continue to typecheck 'S'. But we /were not/ adding
a fake anything for 'MkT' and so there was an internal
error when we met 'MkT' in the body of 'S'.
The fix is to add fake tycons for all the 'implicits' of 'T'.
This is done by mk_fake_tc in TcTyClsDecls.checkValidTyCl,
which now returns a /list/ of TyCons rather than just one.
On the way I did some refactoring:
* Rename TcTyDecls.tcAddImplicits to tcAddTyConsToGblEnv
and make it /include/ the TyCons themeselves as well
as their implicits
* Some incidental refactoring about tcRecSelBinds. The main
thing is that I've avoided creating a HsValBinds that we
immediately decompose. That meant moving some deck chairs
around.
NB: The new error message for the regression test T15215
has the opaque error "Illegal constraint in a type:", flagged
in Trac #14845. But that's the fault of the latter ticket.
The fix here not to blame.
Diffstat (limited to 'compiler/typecheck/TcTyDecls.hs')
-rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 52 |
1 files changed, 30 insertions, 22 deletions
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index da8221d72b..cce0f02a0b 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -19,10 +19,10 @@ module TcTyDecls( checkClassCycles, -- * Implicits - tcAddImplicits, mkDefaultMethodType, + addTyConsToGblEnv, mkDefaultMethodType, -- * Record selectors - mkRecSelBinds, mkOneRecordSelector + tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector ) where #include "HsVersions.h" @@ -31,7 +31,7 @@ import GhcPrelude import TcRnMonad import TcEnv -import TcBinds( tcRecSelBinds ) +import TcBinds( tcValBinds, addTypecheckedBinds ) import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) ) import TcType import TysWiredIn( unitTy ) @@ -743,23 +743,24 @@ updateRoleEnv name n role * * ********************************************************************* -} -tcAddImplicits :: [TyCon] -> TcM TcGblEnv +addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv -- Given a [TyCon], add to the TcGblEnv +-- * extend the TypeEnv with the tycons -- * extend the TypeEnv with their implicitTyThings -- * extend the TypeEnv with any default method Ids -- * add bindings for record selectors --- * add bindings for type representations for the TyThings -tcAddImplicits tycons - = discardWarnings $ +addTyConsToGblEnv tyclss + = tcExtendTyConEnv tyclss $ tcExtendGlobalEnvImplicit implicit_things $ tcExtendGlobalValEnv def_meth_ids $ - do { traceTc "tcAddImplicits" $ vcat - [ text "tycons" <+> ppr tycons + do { traceTc "tcAddTyCons" $ vcat + [ text "tycons" <+> ppr tyclss , text "implicits" <+> ppr implicit_things ] - ; tcRecSelBinds (mkRecSelBinds tycons) } + ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) + ; return gbl_env } where - implicit_things = concatMap implicitTyConThings tycons - def_meth_ids = mkDefaultMethodIds tycons + implicit_things = concatMap implicitTyConThings tyclss + def_meth_ids = mkDefaultMethodIds tyclss mkDefaultMethodIds :: [TyCon] -> [Id] -- We want to put the default-method Ids (both vanilla and generic) @@ -822,30 +823,37 @@ when typechecking the [d| .. |] quote, and typecheck them later. ************************************************************************ -} -mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn +tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv +tcRecSelBinds sel_bind_prs + = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $ + do { (rec_sel_binds, tcg_env) <- discardWarnings $ + tcValBinds TopLevel binds sigs getGblEnv + ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } + where + sigs = [ L loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] + binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] + +mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] -- 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 mkRecSelBinds tycons - = XValBindsLR (NValBinds binds sigs) - where - (sigs, binds) = unzip rec_sels - rec_sels = map mkRecSelBind [ (tc,fld) - | tc <- tycons + = map mkRecSelBind [ (tc,fld) | tc <- tycons , fld <- tyConFieldLabels tc ] -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) +mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) mkRecSelBind (tycon, fl) = mkOneRecordSelector all_cons (RecSelData tycon) fl where all_cons = map RealDataCon (tyConDataCons tycon) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) + -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (L loc (IdSig noExt sel_id), (NonRecursive, unitBag (L loc sel_bind))) + = (sel_id, L loc sel_bind) where - loc = getSrcSpan sel_name + loc = getSrcSpan sel_name lbl = flLabel fl sel_name = flSelector fl |