X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=2a516618fefbacb3a01a483c53fefa5c85b99f31;hp=1aa126f44f8762d239eec716389588c57d2946c6;hb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;hpb=a4572b40a9668d949b906c000e40d65ca9dc2798

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 1aa126f..2a51661 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -22,13 +22,13 @@ import Inst		( newDictBndr, newDictBndrs, instToId, showLIE,
 import InstEnv		( mkLocalInstance, instanceDFunId )
 import TcDeriv		( tcDeriving )
 import TcEnv		( InstInfo(..), InstBindings(..), 
-			  newDFunName, tcExtendIdEnv
+			  newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
 			)
 import TcHsType		( kcHsSigType, tcHsKindedType )
 import TcUnify		( checkSigTyVars )
 import TcSimplify	( tcSimplifySuperClasses )
 import Type		( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
-                          splitFunTys )
+                          splitFunTys, TyThing )
 import Coercion         ( mkSymCoercion )
 import TyCon            ( TyCon, newTyConCo, tyConTyVars )
 import DataCon		( classDataCon, dataConTyCon, dataConInstArgTys )
@@ -44,6 +44,7 @@ import ListSetOps	( minusList )
 import Outputable
 import Bag
 import BasicTypes	( Activation( AlwaysActive ), InlineSpec(..) )
+import HscTypes		( implicitTyThings )
 import FastString
 \end{code}
 
@@ -146,24 +147,35 @@ tcInstDecls1 tycl_decls inst_decls
 		-- (1) Do the ordinary instance declarations and instances of
 		--     indexed types
        ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
-       ; local_inst_infos <- mappM tcLocalInstDecl1 inst_decls
-       ; idxty_inst_infos <- mappM tcIdxTyInstDecl idxty_decls
-
-       ; let { local_inst_info = concat local_inst_infos ++ 
-				 catMaybes idxty_inst_infos
-	     ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls }
-
-	        -- (2) Instances from generic class declarations
+       ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
+       ; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls
+
+       ; let { (local_infos,
+	        local_tycons)    = unzip local_info_tycons
+	     ; (idxty_infos, 
+	        idxty_tycons)    = unzip idxty_info_tycons
+	     ; local_idxty_info  = concat local_infos ++ catMaybes idxty_infos
+	     ; local_idxty_tycon = concat local_tycons ++ 
+				   catMaybes idxty_tycons
+	     ; clas_decls        = filter (isClassDecl.unLoc) tycl_decls 
+	     ; implicit_things   = concatMap implicitTyThings local_idxty_tycon
+	     }
+
+	        -- (2) Add the tycons of associated types and their implicit
+	        --     tythings to the global environment
+       ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do {
+
+	        -- (3) Instances from generic class declarations
        ; generic_inst_info <- getGenericInstances clas_decls
 
 	        -- Next, construct the instance environment so far, consisting
 	        -- of 
 		--   a) local instance decls
 		--   b) generic instances
-       ; addInsts local_inst_info   $ do {
+       ; addInsts local_idxty_info  $ do {
        ; addInsts generic_inst_info $ do {
 
-	        -- (3) Compute instances from "deriving" clauses; 
+	        -- (4) Compute instances from "deriving" clauses; 
 		-- This stuff computes a context for the derived instance
 		-- decl, so it needs to know about all the instances possible
        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
@@ -171,9 +183,9 @@ tcInstDecls1 tycl_decls inst_decls
 
        ; gbl_env <- getGblEnv
        ; returnM (gbl_env, 
-		  generic_inst_info ++ deriv_inst_info ++ local_inst_info,
+		  generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
 		  deriv_binds) 
-    }}}}
+    }}}}}
 
 addInsts :: [InstInfo] -> TcM a -> TcM a
 addInsts infos thing_inside
@@ -182,14 +194,14 @@ addInsts infos thing_inside
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name 
-		 -> TcM [InstInfo]	-- [] if there was an error
+		 -> TcM ([InstInfo], [TyThing])	-- [] if there was an error
 	-- A source-file instance declaration
 	-- Type-check all the stuff before the "where"
 	--
 	-- We check for respectable instance type, and context
 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
   =	-- Prime error recovery, set source location
-    recoverM (returnM [])		$
+    recoverM (returnM ([], []))		$
     setSrcSpan loc			$
     addErrCtxt (instDeclCtxt1 poly_ty)	$
 
@@ -208,18 +220,22 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
 	; checkValidInstance tyvars theta clas inst_tys
 
 	-- Next, process any associated types.
-	; idxty_inst_info <- mappM tcIdxTyInstDecl ats
+	; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
 
 	-- Finally, construct the Core representation of the instance.
 	-- (This no longer includes the associated types.)
 	; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
 	; overlap_flag <- getOverlapFlag
-	; let dfun  = mkDictFunId dfun_name tyvars theta clas inst_tys
-	      ispec = mkLocalInstance dfun overlap_flag
-
-	; return $ [InstInfo { iSpec  = ispec, 
-			       iBinds = VanillaInst binds uprags }] ++
-                   catMaybes idxty_inst_info }
+	; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
+	      ispec          = mkLocalInstance dfun overlap_flag
+	      (idxty_infos, 
+	       idxty_tycons) = unzip idxty_info_tycons
+
+	; return ([InstInfo { iSpec  = ispec, 
+			      iBinds = VanillaInst binds uprags }] ++
+                  catMaybes idxty_infos,
+		  catMaybes idxty_tycons)
+        }
 \end{code}