-
-
--- Functional dependencies, instantiation of equations
--------------------------------------------------------
-
-mkDerivedFunDepEqns :: WantedLoc
- -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
- -> TcS [FlavoredEvVar] -- All Derived
-mkDerivedFunDepEqns _ [] = return []
-mkDerivedFunDepEqns loc eqns
- = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
- ; evvars <- mapM to_work_item eqns
- ; return $ concat evvars }
- where
- to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [FlavoredEvVar]
- to_work_item ((qtvs, pairs), d1, d2)
- = do { let tvs = varSetElems qtvs
- ; tvs' <- mapM instFlexiTcS tvs
- ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
- loc' = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
- flav = Derived loc'
- ; mapM (do_one subst flav) pairs }
-
- do_one subst flav (ty1, ty2)
- = do { let sty1 = substTy subst ty1
- sty2 = substTy subst ty2
- ; ev <- newCoVar sty1 sty2
- ; return (mkEvVarX ev flav) }
-
-pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
-pprEquationDoc (eqn, (p1, _), (p2, _))
- = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
-
-mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
- -> TcM (TidyEnv, SDoc)
-mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
- = do { pred1' <- TcM.zonkTcPredType pred1
- ; pred2' <- TcM.zonkTcPredType pred2
- ; let { pred1'' = tidyPred tidy_env pred1'
- ; pred2'' = tidyPred tidy_env pred2' }
- ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
- nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]),
- nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
- ; return (tidy_env, msg) }