Big tidy-up of deriving code

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

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 2fc44dd..49fba35 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -24,7 +24,7 @@ module Inst (
 
        tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
        ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
-       instLoc, getDictClassTys, dictPred,
+       getDictClassTys, dictPred,
 
        lookupSimpleInst, LookupInstResult(..), lookupPred, 
        tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
@@ -83,7 +83,7 @@ Selection
 ~~~~~~~~~
 \begin{code}
 instName :: Inst -> Name
-instName inst = idName (instToId inst)
+instName inst = Var.varName (instToVar inst)
 
 instToId :: Inst -> TcId
 instToId inst = ASSERT2( isId id, ppr inst ) id 
@@ -110,7 +110,8 @@ instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
                                               (tci_wanted imp)
 
 mkImplicTy tvs givens wanteds  -- The type of an implication constraint
-  = -- pprTrace "mkImplicTy" (ppr givens) $
+  = ASSERT( all isDict givens )
+    -- pprTrace "mkImplicTy" (ppr givens) $
     mkForAllTys tvs $ 
     mkPhiTy (map dictPred givens) $
     if isSingleton wanteds then
@@ -118,8 +119,6 @@ mkImplicTy tvs givens wanteds       -- The type of an implication constraint
     else
        mkTupleTy Boxed (length wanteds) (map instType wanteds)
 
-instLoc inst = tci_loc inst
-
 dictPred (Dict {tci_pred = pred}) = pred
 dictPred inst                    = pprPanic "dictPred" (ppr inst)
 
@@ -330,8 +329,15 @@ mkPredName uniq loc pred_ty
   = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
   where
     occ = case pred_ty of
-           ClassP cls tys -> mkDictOcc (getOccName cls)
-           IParam ip ty   -> getOccName (ipNameName ip)
+           ClassP cls _ -> mkDictOcc (getOccName cls)
+           IParam ip  _ -> getOccName (ipNameName ip)
+           EqPred ty  _ -> mkEqPredCoOcc baseOcc
+             where
+               -- we use the outermost tycon of the lhs, if there is one, to
+               -- improve readability of Core code
+               baseOcc = case splitTyConApp_maybe ty of
+                           Nothing      -> mkOccName tcName "$"
+                            Just (tc, _) -> getOccName tc
 \end{code}
 
 %************************************************************************
@@ -665,7 +671,7 @@ lookupSimpleInst :: Inst -> TcM LookupInstResult
 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 -- the LookupInstResult, where they can be further processed by tcSimplify
 
---------------------- Impliciations ------------------------
+--------------------- Implications ------------------------
 lookupSimpleInst (ImplicInst {}) = return NoInstance
 
 --------------------- Methods ------------------------
@@ -745,7 +751,7 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
        (theta, _) = tcSplitPhiTy dfun_rho
        src_loc    = instLocSpan loc
        dfun       = HsVar dfun_id
-       tys        = map (substTyVar tenv') tyvars
+       tys        = substTyVars tenv' tyvars
     ; if null theta then
        returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
       else do
@@ -785,7 +791,7 @@ lookupPred pred@(ClassP clas tys)
                        ; return Nothing }
        }}
 
-lookupPred ip_pred = return Nothing
+lookupPred ip_pred = return Nothing    -- Implicit parameters
 
 record_dfun_usage dfun_id 
   = do { hsc_env <- getTopEnv