X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=b5eeff0b6b5ef9b2dc2bfba94ca83eadcdf18626;hp=57e4ab7e1bfad3dd034c59cdc71ca1a2312eaefe;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=5656eb8f9bc7ee43da889da4847856a0f70d9461

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 57e4ab7..b5eeff0 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -40,14 +40,11 @@ module Inst (
 
 	InstOrigin(..), InstLoc, pprInstLoc,
 
-	mkWantedCo, mkGivenCo,
-	isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType,
-        mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo,
-        mkRightTransEqInstCo, mkAppEqInstCo,
-        isValidWantedEqInst,
-	eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, finalizeEqInst, 
-	eqInstType, updateEqInstCoercion,
-	eqInstCoercion,	eqInstTys
+	mkWantedCo, mkGivenCo, isWantedCo, eqInstCoType, mkIdEqInstCo, 
+        mkSymEqInstCo, mkLeftTransEqInstCo, mkRightTransEqInstCo, mkAppEqInstCo,
+        wantedEqInstIsUnsolved, eitherEqInst, mkEqInst, mkWantedEqInst,
+        wantedToLocalEqInst, finalizeEqInst, eqInstType, eqInstCoercion,
+        eqInstTys
     ) where
 
 #include "HsVersions.h"
@@ -120,8 +117,11 @@ instToVar (Dict {tci_name = nm, tci_pred = pred})
 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
 		       tci_wanted = wanteds})
   = mkLocalId nm (mkImplicTy tvs givens wanteds)
-instToVar i@(EqInst {})
-  = eitherEqInst i id (\(TyVarTy covar) -> covar)
+instToVar inst@(EqInst {})
+  = eitherEqInst inst id assertCoVar
+  where
+    assertCoVar (TyVarTy cotv) = cotv
+    assertCoVar coty           = pprPanic "Inst.instToVar" (ppr coty)
 
 instType :: Inst -> Type
 instType (LitInst {tci_ty = ty})  = ty
@@ -286,7 +286,7 @@ newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 newDictBndr inst_loc pred@(EqPred ty1 ty2)
   = do { uniq <- newUnique 
 	; let name = mkPredName uniq inst_loc pred 
-	      co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
+	      co   = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
 	; return (EqInst {tci_name  = name, 
 			  tci_loc   = inst_loc, 
 			  tci_left  = ty1, 
@@ -859,7 +859,8 @@ record_dfun_usage :: Id -> TcRn ()
 record_dfun_usage dfun_id 
   = do	{ hsc_env <- getTopEnv
 	; let  dfun_name = idName dfun_id
-	       dfun_mod  = nameModule dfun_name
+	       dfun_mod  = ASSERT( isExternalName dfun_name ) 
+	         	   nameModule dfun_name
 	; if isInternalName dfun_name ||    -- Internal name => defined in this module
 	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 	  then return () -- internal, or in another package
@@ -969,15 +970,6 @@ isWantedCo :: EqInstCo -> Bool
 isWantedCo (Left _) = True
 isWantedCo _        = False
 
-fromGivenCo :: EqInstCo -> Coercion
-fromGivenCo (Right co) 	 = co
-fromGivenCo _		 = panic "fromGivenCo: not a wanted coercion"
-
-fromWantedCo :: String -> EqInstCo -> TcTyVar
-fromWantedCo _ (Left covar) = covar
-fromWantedCo msg _	    = 
-  panic ("fromWantedCo: not a wanted coercion: " ++ msg)
-
 eqInstCoType :: EqInstCo -> TcType
 eqInstCoType (Left cotv) = mkTyVarTy cotv
 eqInstCoType (Right co)  = co
@@ -1049,11 +1041,12 @@ mkAppEqInstCo (Right co) _ _
 Operations on entire EqInst.
 
 \begin{code}
--- For debugging, make sure the cotv of a wanted is not filled.
+-- |A wanted equality is unsolved as long as its cotv is unfilled.
 --
-isValidWantedEqInst (EqInst {tci_co = Left cotv})
+wantedEqInstIsUnsolved :: Inst -> TcM Bool
+wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
   = liftM not $ isFilledMetaTyVar cotv
-isValidWantedEqInst _ = return True
+wantedEqInstIsUnsolved _ = return True
 
 eitherEqInst :: Inst 	            -- given or wanted EqInst
 	     -> (TcTyVar  -> a)     -- 	result if wanted
@@ -1065,9 +1058,6 @@ eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
 		Right co    -> withGiven  co
 eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
 
-mkEqInsts :: [PredType] -> [EqInstCo] -> TcM [Inst]
-mkEqInsts preds cos = zipWithM mkEqInst preds cos
-
 mkEqInst :: PredType -> EqInstCo -> TcM Inst
 mkEqInst (EqPred ty1 ty2) co
 	= do { uniq <- newUnique
@@ -1094,6 +1084,15 @@ mkWantedEqInst pred@(EqPred ty1 ty2)
        }
 mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
 
+-- Turn a wanted equality into a local that propagates the uninstantiated
+-- coercion variable as witness.  We need this to propagate wanted irreds into
+-- attempts to solve implication constraints.
+--
+wantedToLocalEqInst :: Inst -> Inst
+wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
+  = eq {tci_co = Right (mkTyVarTy cotv)}
+wantedToLocalEqInst eq = eq
+
 -- Turn a wanted into a local EqInst (needed during type inference for
 -- signatures) 
 --
@@ -1101,11 +1100,11 @@ mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
 --
 finalizeEqInst :: Inst			-- wanted
 	       -> TcM Inst		-- given
-finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, tci_name = name})
+finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, 
+                              tci_name = name, tci_co = Left cotv})
   = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
 
          -- fill the coercion hole
-       ; let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
        ; writeMetaTyVar cotv (TyVarTy var)
 
          -- set the new coercion
@@ -1123,7 +1122,4 @@ eqInstCoercion = tci_co
 
 eqInstTys :: Inst -> (TcType, TcType)
 eqInstTys inst = (tci_left inst, tci_right inst)
-
-updateEqInstCoercion :: (EqInstCo -> EqInstCo) -> Inst -> Inst
-updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
 \end{code}