[project @ 2003-11-10 12:05:04 by simonpj]

Corner case fix for -fundecidable-instances

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 8b2058d..2b8f125 100644 (file)
--- 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 (file)
--- 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