X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=b5eeff0b6b5ef9b2dc2bfba94ca83eadcdf18626;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hp=aecaf7f43c6c33e5a6a89ec8df02d4562bad7838;hpb=e891720545a2f088cc48ad62bad7c5b2ad7d183f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index aecaf7f..b5eeff0 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -40,13 +40,11 @@ module Inst (
 
 	InstOrigin(..), InstLoc, pprInstLoc,
 
-	mkWantedCo, mkGivenCo,
-	isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType,
-        mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo,
-        mkRightTransEqInstCo, mkAppEqInstCo,
-	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"
@@ -119,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
@@ -285,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, 
@@ -858,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
@@ -968,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
@@ -1048,6 +1041,13 @@ mkAppEqInstCo (Right co) _ _
 Operations on entire EqInst.
 
 \begin{code}
+-- |A wanted equality is unsolved as long as its cotv is unfilled.
+--
+wantedEqInstIsUnsolved :: Inst -> TcM Bool
+wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
+  = liftM not $ isFilledMetaTyVar cotv
+wantedEqInstIsUnsolved _ = return True
+
 eitherEqInst :: Inst 	            -- given or wanted EqInst
 	     -> (TcTyVar  -> a)     -- 	result if wanted
 	     -> (Coercion -> a)     --	result if given
@@ -1058,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
@@ -1087,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) 
 --
@@ -1094,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
@@ -1116,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}