[commit: ghc] wip/T9858-typeable-ben: Fix (e493718)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T9858-typeable-ben
Link       : http://ghc.haskell.org/trac/ghc/changeset/e493718d67d00954f584af9eefa0340ea7119129/ghc

>---------------------------------------------------------------

commit e493718d67d00954f584af9eefa0340ea7119129
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Tue Oct 27 17:10:40 2015 +0100

    Fix


>---------------------------------------------------------------

e493718d67d00954f584af9eefa0340ea7119129
 compiler/typecheck/TcBinds.hs   |  2 +-
 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 1afeda0..1e52a22 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 ea96bb5..83ef841 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