From e26b57633244b75c41f684e48f2681d25978f43f Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 10 Nov 2003 12:05:04 +0000
Subject: [PATCH] [project @ 2003-11-10 12:05:04 by simonpj] Corner case fix
 for -fundecidable-instances

---
 ghc/compiler/typecheck/Inst.lhs       |   24 +++++++++++++++---------
 ghc/compiler/typecheck/TcSimplify.lhs |   11 +++++++++--
 2 files changed, 24 insertions(+), 11 deletions(-)

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 8b2058d..2b8f125 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -82,7 +82,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon )
 import PrelNames	( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
 import BasicTypes( IPName(..), mapIPName, ipNameName )
 import UniqSupply( uniqsFromSupply )
-import CmdLineOpts( DynFlags )
+import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
 import Maybes	( isJust )
 import Outputable
 \end{code}
@@ -648,21 +648,27 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 
 -- Dictionaries
 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
-  | all tcIsTyVarTy tys	 -- Common special case; no lookup
-			 -- NB: tcIsTyVarTy... don't look through newtypes!
-  = returnM NoInstance
-	
-  | otherwise
-  = do	{ pkg_ie  <- loadImportedInsts clas tys
+  = do	{ dflags  <- getDOpts
+	; if all tcIsTyVarTy tys && 
+	     not (dopt Opt_AllowUndecidableInstances dflags)
+		-- Common special case; no lookup
+		-- NB: tcIsTyVarTy... don't look through newtypes!
+		-- Don't take this short cut if we allow undecidable instances
+		-- because we might have "instance T a where ...".
+		-- [That means we need -fallow-undecidable-instances in the 
+		--  client module, as well as the module with the instance decl.]
+	  then return NoInstance
+
+	  else do
+	{ pkg_ie  <- loadImportedInsts clas tys
 		-- Suck in any instance decls that may be relevant
 	; tcg_env <- getGblEnv
-	; dflags  <- getDOpts
 	; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 	    ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
 	    (matches, unifs)		  -> do
 	{ traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
 					       text "unifs" <+> ppr unifs])
-	; return NoInstance } } }
+	; return NoInstance } } } }
 		-- In the case of overlap (multiple matches) we report
 		-- NoInstance here.  That has the effect of making the 
 		-- context-simplifier return the dict as an irreducible one.
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 7a971ab..02ed4d5 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -2051,8 +2051,15 @@ addNoInstanceErrs mb_what givens dicts
 	  | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts)
 	  | otherwise
 	  = case lookupInstEnv dflags inst_envs clas tys of
-		([], _)  -> (overlap_doc, dict : no_inst_dicts) 	-- No matches
-		inst_res -> (mk_overlap_msg dict inst_res $$ overlap_doc, no_inst_dicts)
+		res@(ms, _) 
+		  | length ms > 1 -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts)
+		  | otherwise     -> (overlap_doc, dict : no_inst_dicts) 	-- No match
+		-- NB: there can be exactly one match, in the case where we have
+		--	instance C a where ...
+		-- (In this case, lookupInst doesn't bother to look up, 
+		--  unless -fallow-undecidable-instances is set.)
+		-- So we report this as "no instance" rather than "overlap"; the fix is
+		-- to specify -fallow-undecidable-instances, but we leave that to the programmer!
 	  where
 	    (clas,tys) = getDictClassTys dict
     in
-- 
1.7.10.4