Properly ppr InstEqs in wanteds of implication constraints

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

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 8d21d1b..da80df4 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -42,17 +42,17 @@ module Inst (
        isTyVarDict, isMethodFor, 
 
        zonkInst, zonkInsts,
-       instToId, instToVar, instType, instName,
+       instToId, instToVar, instType, instName, instToDictBind,
+       addInstToDictBind,
 
        InstOrigin(..), InstLoc, pprInstLoc,
 
        mkWantedCo, mkGivenCo,
        fromWantedCo, fromGivenCo,
-       eitherEqInst, mkEqInst, mkEqInsts,
+       eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
        finalizeEqInst, writeWantedCoercion,
        eqInstType, updateEqInstCoercion,
-       eqInstCoercion,
-       eqInstLeftTy, eqInstRightTy
+       eqInstCoercion, eqInstTys
     ) where
 
 #include "HsVersions.h"
@@ -91,12 +91,15 @@ import PrelNames
 import BasicTypes
 import SrcLoc
 import DynFlags
+import Bag
 import Maybes
 import Util
 import Outputable
 import Data.List
 import TypeRep
 import Class
+
+import Control.Monad ( liftM )
 \end{code}
 
 
@@ -137,7 +140,7 @@ instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
 
 mkImplicTy tvs givens wanteds  -- The type of an implication constraint
-  = ASSERT( all isDict givens )
+  = ASSERT( all isAbstractableInst givens )
     -- pprTrace "mkImplicTy" (ppr givens) $
     -- See [Equational Constraints in Implication Constraints]
     let dict_wanteds = filter (not . isEqInst) wanteds
@@ -205,6 +208,15 @@ tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unio
 
 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
+
+
+--------------------------
+instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
+instToDictBind inst rhs 
+  = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
+
+addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
+addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
 \end{code}
 
 Predicates
@@ -544,11 +556,11 @@ zonkInst implic@(ImplicInst {})
 
 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
   = do { co' <- eitherEqInst eqinst 
-                       (\covar -> return (mkWantedCo covar)) 
-                       (\co    -> zonkTcType co >>= \coercion -> return (mkGivenCo coercion))
+                 (\covar -> return (mkWantedCo covar)) 
+                 (\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 insts = mappM zonkInst insts
@@ -591,11 +603,14 @@ pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
                (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
                (\co    -> text "Given"  <+> ppr co              <+> dcolon <+> ppr (EqPred ty1 ty2))
 pprInst inst = ppr (instName inst) <+> dcolon 
-               <+> (braces (ppr (instType inst)) $$
+               <+> (braces (ppr (instType inst) <> implicWantedEqs) $$
                     ifPprDebug implic_stuff)
   where
-    implic_stuff | isImplicInst inst = ppr (tci_reft inst)
-                | otherwise         = empty
+    (implic_stuff, implicWantedEqs) 
+      | isImplicInst inst = (ppr (tci_reft inst),
+                            text " &" <+> 
+                            ppr (filter isEqInst (tci_wanted inst)))
+      | otherwise        = (empty, empty)
 
 pprInstInFull inst@(EqInst {}) = pprInst inst
 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
@@ -765,7 +780,7 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo
 -- [Same shortcut as in newOverloadedLit, but we
 --  may have done some unification by now]             
 
-lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
   | Just expr <- shortCutIntLit i ty
   = returnM (GenInst [] (noLoc expr))
   | otherwise
@@ -777,7 +792,7 @@ lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty
                     (mkHsApp (L (instLocSpan loc)
                                 (HsVar (instToId method_inst))) integer_lit))
 
-lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
   | Just expr <- shortCutFracLit f ty
   = returnM (GenInst [] (noLoc expr))
 
@@ -789,7 +804,7 @@ lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty,
     returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) 
                                               (HsVar (instToId method_inst))) rat_lit))
 
-lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
+lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
   | Just expr <- shortCutStringLit s ty
   = returnM (GenInst [] (noLoc expr))
   | otherwise
@@ -979,11 +994,10 @@ fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
 fromWantedCo _ (Left covar) = covar
 fromWantedCo msg _         = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
 
-eitherEqInst 
-       :: Inst                 -- given or wanted EqInst
-       -> (TcTyVar  -> a)      --      result if wanted
-       -> (Coercion -> a)      --      result if given
-       -> a            
+eitherEqInst :: Inst               -- given or wanted EqInst
+            -> (TcTyVar  -> a)     --  result if wanted
+            -> (Coercion -> a)     --  result if given
+            -> a               
 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
        = case either_co of
                Left  covar -> withWanted covar
@@ -1004,6 +1018,12 @@ mkEqInst (EqPred ty1 ty2) co
             }
        where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
 
+mkWantedEqInst :: PredType -> TcM Inst
+mkWantedEqInst pred@(EqPred ty1 ty2)
+  = do { cotv <- newMetaCoVar ty1 ty2
+       ; mkEqInst pred (Left cotv)
+       }
+
 -- type inference:
 --     We want to promote the wanted EqInst to a given EqInst
 --     in the signature context.
@@ -1034,9 +1054,8 @@ eqInstType inst = eitherEqInst inst mkTyVarTy id
 eqInstCoercion :: Inst -> Either TcTyVar Coercion
 eqInstCoercion = tci_co
 
-eqInstLeftTy, eqInstRightTy :: Inst -> TcType
-eqInstLeftTy  = tci_left
-eqInstRightTy = tci_right
+eqInstTys :: Inst -> (TcType, TcType)
+eqInstTys inst = (tci_left inst, tci_right inst)
 
 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}