X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstUtil.lhs;h=0c52ae8767928c569def20f2be8d94895692b185;hb=2c8f04b5b883db74f449dfc8c224929fe28b027d;hp=b41b4ea943956c0d29be82802c8dcc957b6a6690;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index b41b4ea..0c52ae8 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -6,43 +6,39 @@
 The bits common to TcInstDcls and TcDeriv.
 
 \begin{code}
-#include "HsVersions.h"
-
 module TcInstUtil (
 	InstInfo(..),
 	mkInstanceRelatedIds,
-	buildInstanceEnvs
+	buildInstanceEnvs,
+	classDataCon
     ) where
 
-import Ubiq
+#include "HsVersions.h"
 
-import HsSyn		( MonoBinds, Fake, InPat, Sig )
-import RnHsSyn		( RenamedMonoBinds(..), RenamedSig(..), 
-			  RenamedInstancePragmas(..) )
+import RnHsSyn		( RenamedMonoBinds, RenamedSig(..) )
 
-import TcMonad		hiding ( rnMtoTcM )
-import Inst		( InstanceMapper(..) )
+import CmdLineOpts	( opt_AllowOverlappingInstances )
+import TcMonad
+import Inst		( InstanceMapper )
 
-import Bag		( bagToList )
-import Class		( GenClass, GenClassOp, ClassInstEnv(..),
-			  classBigSig, classOps, classOpLocalType )
-import CoreSyn		( GenCoreExpr(..), mkValLam, mkTyApp )
-import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
-import MatchEnv		( nullMEnv, insertMEnv )
+import Bag		( bagToList, Bag )
+import Class		( ClassInstEnv, Class, classBigSig )
+import MkId		( mkDictFunId )
+import Id		( Id )
+import SpecEnv		( emptySpecEnv, addToSpecEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
-import Name		( getSrcLoc, Name{--O only-} )
-import PprType		( GenClass, GenType, GenTyVar )
-import Pretty
-import SpecEnv		( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
+import Name		( getSrcLoc, Name )
 import SrcLoc		( SrcLoc )
-import Type		( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
-			  splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
-import TyVar		( GenTyVar )
+import Type		( mkSigmaTy, mkDictTy, instantiateThetaTy,
+			  ThetaType, Type
+			)
+import PprType		( pprConstraint )
+import Class		( classTyCon )
+import TyCon		( tyConDataCons )
+import TyVar		( TyVar, zipTyVarEnv )
 import Unique		( Unique )
-import Util		( equivClasses, zipWithEqual, panic )
-
-import IdInfo		( noIdInfo )
---import TcPragmas	( tcDictFunPragmas, tcGenPragmas )
+import Util		( equivClasses, panic, assertPanic )
+import Outputable
 \end{code}
 
     instance c => k (t tvs) where b
@@ -52,7 +48,7 @@ data InstInfo
   = InstInfo
       Class	        -- Class, k
       [TyVar]		-- Type variables, tvs
-      Type		-- The type at which the class is being instantiated
+      [Type]		-- The types at which the class is being instantiated
       ThetaType		-- inst_decl_theta: the original context, c, from the
 			--   instance declaration.  It constrains (some of)
 			--   the TyVars above
@@ -60,14 +56,27 @@ 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
-      (Maybe Module)	-- Name of module where this instance defined; Nothing => Prelude
       SrcLoc		-- Source location assoc'd with this instance's defn
       [RenamedSig]	-- User pragmas recorded for generating specialised instances
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Creating instance related Ids}
+%*									*
+%************************************************************************
+
+A tiny function which doesn't belong anywhere else.
+It makes a nasty mutual-recursion knot if you put it in Class.
+
+\begin{code}
+classDataCon :: Class -> Id
+classDataCon clas = case tyConDataCons (classTyCon clas) of
+		      (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr 
+\end{code}		      
+
 %************************************************************************
 %*									*
 \subsection{Creating instance related Ids}
@@ -75,95 +84,31 @@ data InstInfo
 %************************************************************************
 
 \begin{code}
-mkInstanceRelatedIds :: Bool
-		     -> SrcLoc
-		     -> Maybe Module
-                     -> RenamedInstancePragmas
+mkInstanceRelatedIds :: Name		-- Name to use for the dict fun;
 		     -> Class 
 		     -> [TyVar]
-		     -> Type
+		     -> [Type]
 		     -> ThetaType
-		     -> [RenamedSig]
-		     -> TcM s (Id, ThetaType, [Id])
+		     -> (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_tys inst_decl_theta
+  = (dfun_id, dfun_theta)
+  where
+    (class_tyvars, sc_theta, _, _, _) = classBigSig clas
+    sc_theta' = instantiateThetaTy (zipTyVarEnv class_tyvars inst_tys) sc_theta
+
+    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.
 
-			other -> inst_decl_theta ++ super_class_theta
+			other -> inst_decl_theta ++ sc_theta'
 					-- 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 not (null inst_decl_theta)
-     then
-	returnTc []
-     else
-	mapTc mk_const_meth_id class_ops
-    )					`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_tys)
 
-    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_tys
 \end{code}
 
 
@@ -175,36 +120,32 @@ mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
 
 \begin{code}
 buildInstanceEnvs :: Bag InstInfo
-		  -> TcM s InstanceMapper
+		  -> NF_TcM s InstanceMapper
 
 buildInstanceEnvs info
   = let
-    	icmp :: InstInfo -> InstInfo -> TAG_
-    	(InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
-	  = c1 `cmp` c2
+    	icmp :: InstInfo -> InstInfo -> Ordering
+    	(InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
+	  = c1 `compare` c2
 
 	info_by_class = equivClasses icmp (bagToList info)
     in
-    mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
+    mapNF_Tc buildInstanceEnv info_by_class    `thenNF_Tc` \ inst_env_entries ->
     let
-	class_lookup_fn = mkLookupFunDef (==) inst_env_entries 
-					 (nullMEnv, \ o -> nullSpecEnv)
+	class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptySpecEnv
     in
-    returnTc class_lookup_fn
+    returnNF_Tc class_lookup_fn
 \end{code}
 
 \begin{code}
 buildInstanceEnv :: [InstInfo]		-- Non-empty, and all for same class
-		 -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+		 -> NF_TcM s (Class, ClassInstEnv)
 
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
-  = foldlTc addClassInstance
-	    (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
-	    inst_infos
-					`thenTc` \ (class_inst_env, op_inst_envs) ->
-    returnTc (clas, (class_inst_env,
-		     mkLookupFunDef (==) op_inst_envs
-				    (panic "buildInstanceEnv")))
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
+  = foldrNF_Tc addClassInstance
+	    emptySpecEnv
+	    inst_infos				`thenNF_Tc` \ class_inst_env ->
+    returnNF_Tc (clas, class_inst_env)
 \end{code}
 
 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
@@ -213,83 +154,30 @@ about any overlap with an existing instance.
 
 \begin{code}
 addClassInstance
-    :: (ClassInstEnv, [(ClassOp,SpecEnv)])
-    -> InstInfo
-    -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
-
-addClassInstance
-    (class_inst_env, op_spec_envs)
-    (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
-	      dfun_id const_meth_ids _ _ _ src_loc _)
-  = 
-
--- We only add specialised/overlapped instances
--- if we are specialising the overloading
--- ToDo ... This causes getConstMethodId errors!
---
---    if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
---    then
---	-- Drop this specialised/overlapped instance
---	returnTc (class_inst_env, op_spec_envs)
---    else	
-
-	-- 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) 
-							 (ty', getSrcLoc dfun_id');
-	Succeeded class_inst_env' -> 
-
-	-- If there are any constant methods, then add them to 
-	-- the SpecEnv of each class op (ie selector)
-	--
-	-- Example.  class    Foo a     where { op :: Baz b => a -> b }
-	--	     instance Foo (p,q) where { op (x,y) = ... }
-	--
-	-- The constant method from the instance decl will be:
-	--	op_Pair :: forall p q b. Baz b => (p,q) -> b
-	--
-	-- What we put in op's SpecEnv is
-	--	(p,q) b	 |-->  (\d::Foo (p,q) -> op_Pair p q b)
-	--
-	-- Here, [p,q] are the inst_tyvars, and d is a dict whose only
-	-- purpose is to cancel with the dict to which op is applied.
-	-- 
-	-- NOTE THAT this correctly deals with the case where there are
-	-- constant methods even though there are type variables in the
-	-- instance declaration.
-
-    tcGetUnique				`thenNF_Tc` \ uniq ->
-    let 
-      dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
-		-- Slightly disgusting, but it's only a placeholder for
-		-- a dictionary to be chucked away.
-
-      op_spec_envs' | null const_meth_ids = op_spec_envs
-		    | otherwise		  = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
-
-      add_const_meth (op,spec_env) meth_id
-        = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
-		 Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
-	         Succeeded spec_env' -> spec_env' )
-        where
-	  (local_tyvars, _) = splitForAllTy (classOpLocalType op)
-	  local_tyvar_tys   = mkTyVarTys local_tyvars
-	  rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id) 
-						  (mkTyVarTys inst_tyvars)) 
-				         local_tyvar_tys)
-    in
-    returnTc (class_inst_env', op_spec_envs')
-    }
+    :: InstInfo
+    -> ClassInstEnv
+    -> NF_TcM s ClassInstEnv
+
+addClassInstance 
+    (InstInfo clas inst_tyvars inst_tys _ _ 
+	      dfun_id _ src_loc _)
+    class_inst_env
+  = 	-- Add the instance to the class's instance environment
+    case addToSpecEnv opt_AllowOverlappingInstances 
+		      class_inst_env inst_tyvars inst_tys dfun_id of
+	Failed (ty', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, src_loc) 
+							       (ty', getSrcLoc dfun_id'))
+						`thenNF_Tc_`
+				     returnNF_Tc class_inst_env
+
+	Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
 \end{code}
 
 \begin{code}
-dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
+dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
 	-- Overlapping/duplicate instances for given class; msg could be more glamourous
-  = tcAddErrCtxt ctxt $
-    failTc (\sty -> ppStr "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]])
+  = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
+         4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
+		 nest 4 (sep [ptext SLIT("at")  <+> ppr locn1,
+		    	      ptext SLIT("and") <+> ppr locn2])])
 \end{code}