X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstUtil.lhs;h=991eb6a325487381720b7a9941f7b37a6a193e74;hb=edeb362f70b892ae56ad97a6b308ce53f8a4c2fd;hp=38b8f2fb41034190e33bac527b54999a06f127a0;hpb=f7ecf7234c224489be8a5e63fced903b655d92ee;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 38b8f2f..991eb6a 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -20,16 +20,17 @@ import HsSyn		( MonoBinds, Fake, InPat, Sig )
 import RnHsSyn		( SYN_IE(RenamedMonoBinds), RenamedSig(..), 
 			  RenamedInstancePragmas(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
+import TcEnv		( tcAddImportedIdInfo )
+import TcMonad
 import Inst		( SYN_IE(InstanceMapper) )
 
-import Bag		( bagToList )
+import Bag		( bagToList, Bag )
 import Class		( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
 			  classBigSig, classOps, classOpLocalType,
-			  SYN_IE(ClassOp)
+			  SYN_IE(ClassOp), SYN_IE(Class)
 			)
 import CoreSyn		( GenCoreExpr(..), mkValLam, mkTyApp )
-import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
+import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, SYN_IE(Id) )
 import MatchEnv		( nullMEnv, insertMEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
 import Name		( getSrcLoc, Name{--O only-} )
@@ -38,13 +39,15 @@ import Pretty
 import SpecEnv		( SpecEnv, nullSpecEnv, addOneToSpecEnv )
 import SrcLoc		( SrcLoc )
 import Type		( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
-			  splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) )
-import TyVar		( GenTyVar )
+			  instantiateTy, matchTy, SYN_IE(ThetaType),
+			  SYN_IE(Type) )
+import TyVar		( GenTyVar, SYN_IE(TyVar) )
 import Unique		( Unique )
-import Util		( equivClasses, zipWithEqual, panic )
+import Util		( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
 
-import IdInfo		( noIdInfo )
---import TcPragmas	( tcDictFunPragmas, tcGenPragmas )
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
 \end{code}
 
     instance c => k (t tvs) where b
@@ -62,10 +65,7 @@ data InstInfo
 			--   element for each superclass; the "Mark
 			--   Jones optimisation"
       Id		-- The dfun id
-      [Id]		-- Constant methods (either all or none)
       RenamedMonoBinds	-- Bindings, b
-      Bool		-- True <=> local instance decl
-      Module		-- Name of module where this instance defined
       SrcLoc		-- Source location assoc'd with this instance's defn
       [RenamedSig]	-- User pragmas recorded for generating specialised instances
 \end{code}
@@ -77,22 +77,21 @@ data InstInfo
 %************************************************************************
 
 \begin{code}
-mkInstanceRelatedIds :: Bool
-		     -> SrcLoc
-		     -> Module
-                     -> RenamedInstancePragmas
+mkInstanceRelatedIds :: Name		-- Name to use for the dict fun;
 		     -> Class 
 		     -> [TyVar]
 		     -> Type
 		     -> ThetaType
-		     -> [RenamedSig]
-		     -> TcM s (Id, ThetaType, [Id])
+		     -> NF_TcM s (Id, ThetaType)
 
-mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
-		     clas inst_tyvars inst_ty inst_decl_theta uprags
-  = 	-- MAKE THE DFUN ID
-    let
-	dfun_theta = case inst_decl_theta of
+mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
+  = tcAddImportedIdInfo dfun_id			`thenNF_Tc` \ new_dfun_id ->
+    returnNF_Tc (new_dfun_id, dfun_theta)
+  where
+    (_, super_classes, _, _, _, _) = classBigSig clas
+    super_class_theta = super_classes `zip` repeat inst_ty
+
+    dfun_theta = case inst_decl_theta of
 			[]    -> []	-- If inst_decl_theta is empty, then we don't
 					-- want to have any dict arguments, so that we can
 					-- expose the constant methods.
@@ -101,71 +100,9 @@ mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
 					-- Otherwise we pass the superclass dictionaries to
 					-- the dictionary function; the Mark Jones optimisation.
 
-	dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
-    in
-    tcGetUnique 			`thenNF_Tc` \ dfun_uniq ->
-    fixTc ( \ rec_dfun_id ->
-
-{- LATER
-	tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
-					`thenNF_Tc` \ dfun_pragma_info ->
-	let
-	    dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
-	    dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
-	in
--}
-	let dfun_id_info = noIdInfo in	-- For now
-
-	returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
-    ) `thenTc` \ dfun_id ->
-
-	-- MAKE THE CONSTANT-METHOD IDS
-	-- if there are no type variables involved
-    (if (null inst_decl_theta)
-     then
-	mapTc mk_const_meth_id class_ops
-     else
-	returnTc []
-    )					`thenTc` \ const_meth_ids ->
-
-    returnTc (dfun_id, dfun_theta, const_meth_ids)
-  where
-    (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
-    tenv = [(class_tyvar, inst_ty)]
-  
-    super_class_theta = super_classes `zip` repeat inst_ty
+    dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
 
-    mk_const_meth_id op
-	= tcGetUnique		`thenNF_Tc` \ uniq ->
-	  fixTc (\ rec_const_meth_id ->
-
-{- LATER
-		-- Figure out the IdInfo from the pragmas
-	     (case assocMaybe opname_prag_pairs (getName op) of
-		Nothing   -> returnTc inline_info
-		Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
-	     )			`thenNF_Tc` \ id_info ->
--}
-	     let id_info = noIdInfo 	-- For now
-	     in
-	     returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
-				       from_here src_loc inst_mod id_info)
-	  )
-	where
-	  op_ty       = classOpLocalType op
-	  meth_ty     = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
-{- LATER
-	  inline_me   = isIn "mkInstanceRelatedIds" op ops_to_inline
-	  inline_info = if inline_me
-			then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
-			else noIdInfo
-
-    opname_prag_pairs = case inst_pragmas of
-			   ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
-			   other_inst_pragmas			    -> []
-
-    ops_to_inline = [op | (InlineSig op _) <- uprags]
--}
+    dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty
 \end{code}
 
 
@@ -182,7 +119,7 @@ buildInstanceEnvs :: Bag InstInfo
 buildInstanceEnvs info
   = let
     	icmp :: InstInfo -> InstInfo -> TAG_
-    	(InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
+    	(InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
 	  = c1 `cmp` c2
 
 	info_by_class = equivClasses icmp (bagToList info)
@@ -199,7 +136,7 @@ buildInstanceEnvs info
 buildInstanceEnv :: [InstInfo]		-- Non-empty, and all for same class
 		 -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
 
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
   = foldlTc addClassInstance
 	    (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
 	    inst_infos
@@ -220,9 +157,9 @@ addClassInstance
     -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
 
 addClassInstance
-    (class_inst_env, op_spec_envs)
+    input_stuff@(class_inst_env, op_spec_envs)
     (InstInfo clas inst_tyvars inst_ty _ _ 
-	      dfun_id const_meth_ids _ _ _ src_loc _)
+	      dfun_id _ src_loc _)
   = 
 
 -- We only add specialised/overlapped instances
@@ -237,10 +174,15 @@ addClassInstance
 
 	-- Add the instance to the class's instance environment
     case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
-	Failed (ty', dfun_id')    -> dupInstFailure clas (inst_ty, src_loc) 
+	Failed (ty', dfun_id')    -> recoverTc (returnTc input_stuff) $
+				     dupInstFailure clas (inst_ty, src_loc) 
 							 (ty', getSrcLoc dfun_id');
 	Succeeded class_inst_env' -> 
 
+	    returnTc (class_inst_env', op_spec_envs)
+
+{- 		OLD STUFF FOR CONSTANT METHODS 
+
 	-- If there are any constant methods, then add them to 
 	-- the SpecEnv of each class op (ie selector)
 	--
@@ -280,6 +222,8 @@ addClassInstance
 	  rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
     in
     returnTc (class_inst_env', op_spec_envs')
+		END OF OLD STUFF -}
+
     }
 \end{code}
 
@@ -287,10 +231,10 @@ addClassInstance
 dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
 	-- Overlapping/duplicate instances for given class; msg could be more glamourous
   = tcAddErrCtxt ctxt $
-    failTc (\sty -> ppStr "Duplicate or overlapping instance declarations")
+    failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
   where
-    ctxt sty = ppHang (ppSep [ppBesides[ppStr "Class `", ppr sty clas, ppStr "'"],
-			      ppBesides[ppStr "type `", ppr sty ty1, ppStr "'"]])
-		    4 (ppSep [ppBesides [ppStr "at ", ppr sty locn1],
-		    	      ppBesides [ppStr "and ", ppr sty locn2]])
+    ctxt sty = hang (sep [ptext SLIT("Class"), ppr sty clas,
+			  ptext SLIT("type"),  ppr sty ty1])
+		    4 (sep [hcat [ptext SLIT("at "), ppr sty locn1],
+		    	      hcat [ptext SLIT("and "), ppr sty locn2]])
 \end{code}