[project @ 2003-11-17 14:23:30 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / Inst.lhs

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index b742a4c..615d157 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -5,8 +5,6 @@
 
 \begin{code}
 module Inst ( 
-       LIE, emptyLIE, unitLIE, plusLIE, consLIE, 
-       plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
        showLIE,
 
        Inst, 
@@ -62,8 +60,9 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
                  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
                  isClassPred, isTyVarClassPred, isLinearPred, 
                  getClassPredTys, getClassPredTys_maybe, mkPredName,
-                 isInheritablePred, isIPPred, 
-                 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
+                 isInheritablePred, isIPPred, matchTys,
+                 tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, 
+                 pprPred, pprParendType, pprThetaArrow, pprClassPred
                )
 import HscTypes        ( ExternalPackageState(..) )
 import CoreFVs ( idFreeTyVars )
@@ -72,16 +71,17 @@ import Id   ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique
 import PrelInfo        ( isStandardClass, isNoDictClass )
 import Name    ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
 import NameSet ( addOneToNameSet )
-import PprType ( pprPred, pprParendType, pprThetaArrow, pprClassPred ) 
 import Subst   ( substTy, substTyWith, substTheta, mkTyVarSubst )
 import Literal ( inIntRange )
 import Var     ( TyVar )
 import VarEnv  ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
-import VarSet  ( elemVarSet, emptyVarSet, unionVarSet )
+import VarSet  ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
 import TysWiredIn ( floatDataCon, doubleDataCon )
 import PrelNames       ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
 import BasicTypes( IPName(..), mapIPName, ipNameName )
 import UniqSupply( uniqsFromSupply )
+import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
+import Maybes  ( isJust )
 import Outputable
 \end{code}
 
@@ -538,37 +538,40 @@ tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
   -- Add new locally-defined instances
 tcExtendLocalInstEnv dfuns thing_inside
  = do { traceDFuns dfuns
-      ; eps <- getEps
       ; env <- getGblEnv
       ; dflags  <- getDOpts
-      ; inst_env' <- foldlM (extend dflags (eps_inst_env eps)) 
-                           (tcg_inst_env env) 
-                           dfuns
+      ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
                         tcg_inst_env = inst_env' }
       ; setGblEnv env' thing_inside }
- where
-  extend dflags pkg_ie home_ie dfun
-   = do        { checkNewInst dflags (home_ie, pkg_ie) dfun
-       ; return (extendInstEnv home_ie dfun) }
 
-checkNewInst :: DynFlags -> (InstEnv, InstEnv) -> DFunId -> TcM ()
--- Check that the proposed new instance is OK
-checkNewInst dflags ies dfun
-  = do {       -- Check functional dependencies
-         case checkFunDeps (home_ie, pkg_ie) dfun of
+addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
+-- Check that the proposed new instance is OK, 
+-- and then add it to the home inst env
+addInst dflags home_ie dfun
+  = do {       -- Load imported instances, so that we report
+               -- duplicates correctly
+         pkg_ie  <- loadImportedInsts cls tys
+
+               -- Check functional dependencies
+       ; case checkFunDeps (pkg_ie, home_ie) dfun of
                Just dfuns -> funDepErr dfun dfuns
                Nothing    -> return ()
 
                -- Check for duplicate instance decls
-       ; mappM_ (dupInstErr dfun) dup_dfuns }
+       ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
+             ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
+                                       isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
+               -- Find memebers of the match list which 
+               -- dfun itself matches. If the match is 2-way, it's a duplicate
+       ; case dup_dfuns of
+           dup_dfun : _ -> dupInstErr dfun dup_dfun
+           []           -> return ()
+
+               -- OK, now extend the envt
+       ; return (extendInstEnv home_ie dfun) }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
-    (matches, _) = lookupInstEnv dflags ies clas tys
-    dup_dfuns = [dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
-                       isJust (matchTys tvs tys dup_tys)]
-       -- Find memebers of the match list which 
-       -- dfun itself matches. If the match is 2-way, it's a duplicate
 
 traceDFuns dfuns
   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
@@ -643,21 +646,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.