Simon's fixes to the generated type instances in Generics

[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 9ac0a6f..c2e9bc8 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -372,13 +372,12 @@ 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 implicitTyThings at_idx_tycons
-            ; aux_binds       = mkRecSelBinds at_idx_tycons
-             }
+             ; implicit_things = concatMap implicitTyConThings at_idx_tycons
+            ; aux_binds       = mkRecSelBinds at_idx_tycons  }
 
                 -- (2) Add the tycons of indexed types and their implicit
                 --     tythings to the global environment
-       ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+       ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do {
 
 
                 -- Next, construct the instance environment so far, consisting
@@ -401,9 +400,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
 
        -- Extend the global environment also with the generated datatypes for
        -- the generic representation
-       ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $
-                      tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $
-                        addInsts deriv_inst_info getGblEnv
+       ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
+       ; gbl_env <- tcExtendGlobalEnv all_tycons $
+                    tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+                    addFamInsts deriv_ty_insts $
+                    addInsts deriv_inst_info getGblEnv
        ; return ( addTcgDUs gbl_env deriv_dus,
                   deriv_inst_info ++ local_info,
                   aux_binds `plusHsValBinds` deriv_binds)
@@ -413,18 +414,14 @@ addInsts :: [InstInfo Name] -> TcM a -> TcM a
 addInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 
-addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts :: [TyCon] -> TcM a -> TcM a
 addFamInsts tycons thing_inside
-  = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
-  where
-    mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
-    mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
-                                                    (ppr tything)
+  = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
 \end{code}
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name
-                 -> TcM (InstInfo Name, [TyThing])
+                 -> TcM (InstInfo Name, [TyCon])
         -- A source-file instance declaration
         -- Type-check all the stuff before the "where"
         --
@@ -468,7 +465,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
     checkValidAndMissingATs :: Class
                             -> ([TyVar], [TcType])     -- instance types
                             -> [(LTyClDecl Name,       -- source form of AT
-                                 TyThing)]            -- Core form of AT
+                                 TyCon)]              -- Core form of AT
                             -> TcM ()
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
@@ -486,12 +483,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
            ; mapM_ (checkIndexes clas inst_tys) ats
            }
 
-    checkIndexes clas inst_tys (hsAT, ATyCon tycon)
+    checkIndexes clas inst_tys (hsAT, tycon)
 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
       = checkIndexes' clas inst_tys hsAT
                       (tyConTyVars tycon,
                        snd . fromJust . tyConFamInst_maybe $ tycon)
-    checkIndexes _ _ _ = panic "checkIndexes"
 
     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
       = let atName = tcdName . unLoc $ hsAT
@@ -581,7 +577,7 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
 \begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon
 tcFamInstDecl top_lvl (L loc decl)
   =    -- Prime error recovery, set source location
     setSrcSpan loc                             $
@@ -602,7 +598,7 @@ tcFamInstDecl top_lvl (L loc decl)
        ; when (isTopLevel top_lvl && isAssocFamily tc)
               (addErr $ assocInClassErr (tcdName decl))
 
-       ; return (ATyCon tc) }
+       ; return tc }
 
 isAssocFamily :: TyCon -> Bool -- Is an assocaited type
 isAssocFamily tycon