-- 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,
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}
-
%************************************************************************
%* *
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
-- 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)
; new_inst <- mkEqInst (EqPred ty2 ty1) wg_co
; return (new_inst,True)
}
- go _ _ = return (i,False)
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
decompInsts :: [Inst] -> TcM ([Inst],Bool)
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
-- 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