Add ASSERTs to all calls of nameModule

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

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index d839aba..b5eeff0 100644 (file)
--- 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, 
@@ -513,7 +514,7 @@ Zonking makes sure that the instance types are fully zonked.
 
 \begin{code}
 zonkInst :: Inst -> TcM Inst
-zonkInst dict@(Dict { tci_pred = pred}) = do
+zonkInst dict@(Dict {tci_pred = pred}) = do
     new_pred <- zonkTcPredType pred
     return (dict {tci_pred = new_pred})
 
@@ -544,7 +545,7 @@ zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
                  (\co    -> liftM mkGivenCo $ zonkTcType co)
        ; ty1' <- zonkTcType ty1
        ; ty2' <- zonkTcType ty2
-       ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
+       ; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' })
        }
 
 zonkInsts :: [Inst] -> TcRn [Inst]
@@ -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}