X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyFuns.lhs;h=4be39c37c7850e2740ff5ad7e4a128d542f8b518;hp=39cee907e85c11aed142cdfd7a475fbb014f17ee;hb=4ba96c06f2b69ea1fe2b27718013713e94c1520c;hpb=e913ed4d009dac1be837b79e99f352ca1d3fc965

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 39cee90..4be39c3 100644
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -4,13 +4,10 @@
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module TcTyFuns(
-	finalizeEqInst,
-	partitionWantedEqInsts, partitionGivenEqInsts,
-
 	tcNormalizeFamInst,
 
 	normaliseGivens, normaliseGivenDicts, 
@@ -46,49 +43,6 @@ import Maybes
 import Data.List
 \end{code}
 
-%************************************************************************
-%*									*
-\section{Eq Insts}
-%*									*
-%************************************************************************
-
-%************************************************************************
-%*									*
-\section{Utility Code}
-%*									*
-%************************************************************************
-
-\begin{code}
-partitionWantedEqInsts 
-	:: [Inst] 		-- wanted insts
-	-> ([Inst],[Inst])	-- (wanted equations,wanted dicts)
-partitionWantedEqInsts = partitionEqInsts True
-
-partitionGivenEqInsts 
-	:: [Inst] 		-- given insts
-	-> ([Inst],[Inst])	-- (given equations,given dicts)
-partitionGivenEqInsts = partitionEqInsts False
-
-
-partitionEqInsts 
-	:: Bool			-- <=> wanted
-	-> [Inst] 		-- insts
-	-> ([Inst],[Inst])	-- (equations,dicts)
-partitionEqInsts wanted [] 
-	= ([],[])
-partitionEqInsts wanted (i:is)
-	| isEqInst i
-	= (i:es,ds)
-	| otherwise
-	= (es,i:ds)
-	where (es,ds) = partitionEqInsts wanted is
-
-isEqDict :: Inst -> Bool
-isEqDict (Dict {tci_pred = EqPred _ _}) = True
-isEqDict _				= False
-
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -503,8 +457,10 @@ trivialInsts (i@(EqInst {}):is)
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 swapInsts :: [Inst] -> TcM ([Inst],Bool)
 -- All the inputs and outputs are equalities
-swapInsts insts = mapAndUnzipM swapInst insts >>= \(insts',changeds) -> return (insts',or changeds)
-		  
+swapInsts insts 
+  = do { (insts', changeds) <- mapAndUnzipM swapInst insts
+       ; return (insts', or changeds)
+       }
 
 	-- (Swap)
 	-- 	g1 : c ~ Fd
@@ -526,7 +482,12 @@ swapInst i@(EqInst {})
 		-- we should swap!
 	      go ty1 ty2@(TyConApp tyCon _) 
 					| isOpenSynTyCon tyCon
-					= do { wg_co <- eitherEqInst i
+					= actual_swap ty1 ty2
+	      go ty1@(TyConApp _ _) ty2@(TyVarTy _)
+					= actual_swap ty1 ty2
+	      go _ _			= return (i,False)
+
+	      actual_swap ty1 ty2 = do { wg_co <- eitherEqInst i
 						          -- old_co := sym new_co
 						          (\old_covar ->
 							   do { new_cotv <- newMetaTyVar TauTv (mkCoKind ty2 ty1)
@@ -539,7 +500,6 @@ swapInst i@(EqInst {})
 					     ; new_inst <- mkEqInst (EqPred ty2 ty1) wg_co
 					     ; return (new_inst,True)
 					     }
-	      go _ _			= return (i,False)
 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 decompInsts :: [Inst] -> TcM ([Inst],Bool)
@@ -576,7 +536,7 @@ decompInst i@(EqInst {})
                         do { cotvs <- zipWithM (\t1 t2 -> 
                                                 newMetaTyVar TauTv 
                                                              (mkCoKind t1 t2)) 
-                                               tys1' tys2'
+                                               tys1 tys2
                            ; let cos = map TyVarTy cotvs
                            ; writeMetaTyVar old_covar (TyConApp con1 cos)
                            ; return $ map mkWantedCo cotvs
@@ -584,9 +544,10 @@ decompInst i@(EqInst {})
                       -- co_i := Con_i old_co
                       (\old_co -> return $ 
                                     map mkGivenCo $
-                                        mkRightCoercions (length tys1') old_co)
-           ; insts <- zipWithM mkEqInst (zipWith EqPred tys1' tys2') cos
-           ; return (insts, not $ null insts)
+                                        mkRightCoercions (length tys1) old_co)
+           ; insts <- zipWithM mkEqInst (zipWith EqPred tys1 tys2) cos
+           ; traceTc (text "decomp identicalHead" <+> ppr insts) 
+           ; return (insts, not $ null insts) 
            }
       | con1 /= con2 && not (isOpenSynTyCon con1 || isOpenSynTyCon con2)
         -- not matching data constructors (of any flavour) are bad news