EqInst related clean up

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

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 141afb1..4be39c3 100644 (file)
--- 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,17 +544,19 @@ 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
       = do { env0 <- tcInitTidyEnv
-           ; let (env1, tidy_ty1)  =  tidyOpenType env0 ty1
-                 (env2, tidy_ty2)  =  tidyOpenType env1 ty2
-                 extra                  = sep [ppr tidy_ty1, char '~', ppr tidy_ty2]
-                 msg            = ptext SLIT("Couldn't match expected type against inferred type")
+           ; let (env1, tidy_ty1) = tidyOpenType env0 ty1
+                 (env2, tidy_ty2) = tidyOpenType env1 ty2
+                 extra                   = sep [ppr tidy_ty1, char '~', ppr tidy_ty2]
+                 msg             = 
+                   ptext SLIT("Unsolvable equality constraint:")
            ; failWithTcM (env2, hang msg 2 extra)
            }
       where