Commit e26b5763 authored by simonpj's avatar simonpj
Browse files

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

Corner case fix for -fundecidable-instances
parent d255dfff
...@@ -82,7 +82,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon ) ...@@ -82,7 +82,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName ) import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply ) import UniqSupply( uniqsFromSupply )
import CmdLineOpts( DynFlags ) import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
import Maybes ( isJust ) import Maybes ( isJust )
import Outputable import Outputable
\end{code} \end{code}
...@@ -648,21 +648,27 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) ...@@ -648,21 +648,27 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
-- Dictionaries -- Dictionaries
lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
| all tcIsTyVarTy tys -- Common special case; no lookup = do { dflags <- getDOpts
-- NB: tcIsTyVarTy... don't look through newtypes! ; if all tcIsTyVarTy tys &&
= returnM NoInstance not (dopt Opt_AllowUndecidableInstances dflags)
-- Common special case; no lookup
| otherwise -- NB: tcIsTyVarTy... don't look through newtypes!
= do { pkg_ie <- loadImportedInsts clas tys -- 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 -- Suck in any instance decls that may be relevant
; tcg_env <- getGblEnv ; tcg_env <- getGblEnv
; dflags <- getDOpts
; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ; ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
(matches, unifs) -> do (matches, unifs) -> do
{ traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches, { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
text "unifs" <+> ppr unifs]) text "unifs" <+> ppr unifs])
; return NoInstance } } } ; return NoInstance } } } }
-- In the case of overlap (multiple matches) we report -- In the case of overlap (multiple matches) we report
-- NoInstance here. That has the effect of making the -- NoInstance here. That has the effect of making the
-- context-simplifier return the dict as an irreducible one. -- context-simplifier return the dict as an irreducible one.
......
...@@ -2051,8 +2051,15 @@ addNoInstanceErrs mb_what givens dicts ...@@ -2051,8 +2051,15 @@ addNoInstanceErrs mb_what givens dicts
| not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts)
| otherwise | otherwise
= case lookupInstEnv dflags inst_envs clas tys of = case lookupInstEnv dflags inst_envs clas tys of
([], _) -> (overlap_doc, dict : no_inst_dicts) -- No matches res@(ms, _)
inst_res -> (mk_overlap_msg dict inst_res $$ overlap_doc, no_inst_dicts) | 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 where
(clas,tys) = getDictClassTys dict (clas,tys) = getDictClassTys dict
in in
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment