diff options
author | Ben Gamari <ben@smart-cactus.org> | 2015-10-27 17:10:40 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-10-27 17:25:51 +0100 |
commit | e493718d67d00954f584af9eefa0340ea7119129 (patch) | |
tree | 4a13e086d3020d928e76f17d4a0c9c0204c334e4 | |
parent | 2c8a85b127526844f73032c8554bc8e86c80cc9a (diff) | |
download | haskell-e493718d67d00954f584af9eefa0340ea7119129.tar.gz |
Fix
-rw-r--r-- | compiler/typecheck/TcBinds.hs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 43 |
2 files changed, 24 insertions, 21 deletions
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 1afeda0fd8..1e52a22392 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -194,7 +194,7 @@ tcTopBinds (ValBindsIn {}) = panic "tcTopBinds" tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv tcRecSelBinds (ValBindsOut binds sigs) - = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ + = -- tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ -- this envt extension happens in tcValBinds do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index ea96bb5a19..83ef841bf9 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -27,7 +27,7 @@ module TcTyDecls( import TcRnMonad import TcEnv import TcTypeable( mkTypeableBinds ) -import TcBinds( tcRecSelBinds, addTypecheckedBinds ) +import TcBinds( tcValBinds, addTypecheckedBinds ) import TypeRep( Type(..) ) import TcType import TysWiredIn( unitTy ) @@ -816,11 +816,10 @@ tcAddImplicits tyclss = discardWarnings $ tcExtendGlobalEnvImplicit implicit_things $ tcExtendGlobalValEnv def_meth_ids $ - do { (typeable_ids, typeable_binds) <- mkTypeableBinds tycons - ; gbl_env <- tcExtendGlobalValEnv typeable_ids - $ tcRecSelBinds $ mkRecSelBinds tyclss - ; traceTc "tcAddImplicits" (ppr $ mkRecSelBinds tyclss) - ; return (gbl_env `addTypecheckedBinds` typeable_binds) } + do { (rec_sel_ids, rec_sel_binds) <- mkRecSelBinds tycons + ; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons + ; gbl_env <- tcExtendGlobalValEnv (rec_sel_ids ++ typeable_ids) getGblEnv + ; return (gbl_env `addTypecheckedBinds` (rec_sel_binds ++ typeable_binds)) } where implicit_things = concatMap implicitTyThings tyclss tycons = [tc | ATyCon tc <- tyclss] @@ -860,22 +859,26 @@ must bring the default method Ids into scope first (so they can be seen when typechecking the [d| .. |] quote, and typecheck them later. -} -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 +mkRecSelBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id]) mkRecSelBinds tycons - = ValBindsOut [(NonRecursive, b) | b <- binds] sigs - where - (sigs, binds) = unzip rec_sels - rec_sels = map mkRecSelBind [ (tc,fld) - | ATyCon tc <- tycons - , fld <- tyConFieldLabels tc ] - - -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) + = do { -- We generate *un-typechecked* bindings in mkRecSelBind, and + -- then typecheck them, rather like 'deriving'. This makes life + -- easier, because the later type checking will add all necessary + -- type abstractions and applications + + let sel_binds :: [(RecFlag, LHsBinds Name)] + sel_sigs :: [LSig Name] + (sel_sigs, sel_binds) + = mapAndUnzip mkRecSelBind [ (tc,fld) + | tc <- tycons + , fld <- tyConFieldLabels tc ] + sel_ids = [sel_id | L _ (IdSig sel_id) <- sel_sigs] + ; (sel_binds, _) <- tcValBinds TopLevel sel_binds sel_sigs (return ()) + ; return (sel_ids, map snd sel_binds) } + +mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name)) mkRecSelBind (tycon, fl) - = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind))) where loc = getSrcSpan sel_name sel_id = mkExportedLocalId rec_details sel_name sel_ty |