X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=df6eac119cdc2be3e92d0ed0837b88c7bbd7460f;hb=d64022dc071b587c20a693b7f355f69dc110b707;hp=8c37e087053a4604a9d5a94835a2e78fba5d23b2;hpb=79a6f3fa318020567566f92740ba6b9eb542f73f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 8c37e08..df6eac1 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -70,11 +70,9 @@ import TypeRep
 import Class
 import Name
 import NameEnv
-import OccName
 import HscTypes
 import SrcLoc
 import Outputable
-import Maybes
 import Unique
 import FastString
 \end{code}
@@ -126,11 +124,8 @@ tcLookupGlobal name
 	}}}}}
 
 tcLookupField :: Name -> TcM Id		-- Returns the selector Id
-tcLookupField name = do
-    thing <- tcLookup name	-- Note [Record field lookup]
-    case thing of
-	AGlobal (AnId id) -> return id
-	thing -> wrongThingErr "field name" thing name
+tcLookupField name 
+  = tcLookupId name	-- Note [Record field lookup]
 
 {- Note [Record field lookup]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -176,9 +171,13 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon
 
 -- Look up the instance tycon of a family instance.
 --
--- The match must be unique - ie, match exactly one instance - but the 
--- type arguments used for matching may be more specific than those of 
--- the family instance declaration.
+-- The match may be ambiguous (as we know that overlapping instances have
+-- identical right-hand sides under overlapping substitutions - see
+-- 'FamInstEnv.lookupFamInstEnvConflicts').  However, the type arguments used
+-- for matching must be equal to or be more specific than those of the family
+-- instance declaration.  We pick one of the matches in case of ambiguity; as
+-- the right-hand sides are identical under the match substitution, the choice
+-- does not matter.
 --
 -- Return the instance tycon and its type instance.  For example, if we have
 --
@@ -199,9 +198,9 @@ tcLookupFamInst tycon tys
        ; eps <- getEps
        ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
        ; case lookupFamInstEnv instEnv tycon tys of
-	   [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst, 
-                                                   rep_tys)
-	   _                     -> return Nothing
+	   []                      -> return Nothing
+	   ((fam_inst, rep_tys):_) 
+             -> return $ Just (famInstTyCon fam_inst, rep_tys)
        }
 \end{code}
 
@@ -338,7 +337,7 @@ tcExtendTyVarEnv2 binds thing_inside = do
                    tcl_tyvars = gtvs,
                    tcl_rdr = rdr_env}) <- getLclEnv
     let
-	rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
+	rdr_env'   = extendLocalRdrEnvList rdr_env (map fst binds)
 	new_tv_set = tcTyVarsOfTypes (map snd binds)
  	le'        = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
 
@@ -409,7 +408,7 @@ tc_extend_local_id_env env th_lvl names_w_ids thing_inside
 						  _        -> Wobbly})
     		      | (name,id) <- names_w_ids, let id_ty = idType id]
     le'		    = extendNameEnvList (tcl_env env) extra_env
-    rdr_env'	    = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
+    rdr_env'	    = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
 \end{code}
 
 
@@ -641,6 +640,7 @@ data InstBindings a
 	(LHsBinds a)		-- Bindings for the instance methods
 	[LSig a]		-- User pragmas recorded for generating 
 				-- specialised instances
+	Bool			-- True <=> This code came from a standalone deriving clause
 
   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
 	CoercionI		-- witness dictionary is identical to the argument 
@@ -656,8 +656,8 @@ pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info)
 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
   where
-    details (VanillaInst b _)  = pprLHsBinds b
-    details (NewTypeDerived _) = text "Derived from the representation type"
+    details (VanillaInst b _ _) = pprLHsBinds b
+    details (NewTypeDerived _)  = text "Derived from the representation type"
 
 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
@@ -678,17 +678,13 @@ name, like otber top-level names, and hence must be made with newGlobalBinder.
 
 \begin{code}
 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas (ty:_) loc
-  = do	{ index   <- nextDFunIndex
-	; is_boot <- tcIsHsBoot
+newDFunName clas tys loc
+  = do	{ is_boot <- tcIsHsBoot
 	; mod     <- getModule
 	; let info_string = occNameString (getOccName clas) ++ 
-			    occNameString (getDFunTyKey ty)
-	      dfun_occ = mkDFunOcc info_string is_boot index
-
+			    concatMap (occNameString.getDFunTyKey) tys
+        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
 	; newGlobalBinder mod dfun_occ loc }
-
-newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 \end{code}
 
 Make a name for the representation tycon of a family instance.  It's an
@@ -696,12 +692,13 @@ Make a name for the representation tycon of a family instance.  It's an
 newGlobalBinder.
 
 \begin{code}
-newFamInstTyConName :: Name -> SrcSpan -> TcM Name
-newFamInstTyConName tc_name loc
-  = do	{ index <- nextDFunIndex
-	; mod   <- getModule
-	; let occ = nameOccName tc_name
-	; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
+newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name
+newFamInstTyConName tc_name tys loc
+  = do	{ mod   <- getModule
+	; let info_string = occNameString (getOccName tc_name) ++ 
+			    concatMap (occNameString.getDFunTyKey) tys
+        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+	; newGlobalBinder mod occ loc }
 \end{code}
 
 Stable names used for foreign exports and annotations.