2 module TcImprove ( tcImprove ) where
4 #include "HsVersions.h"
7 import Class ( Class, FunDep, className )
8 import Unify ( unifyTyListsX )
9 import Subst ( mkSubst, emptyInScopeSet, substTy )
10 import TcEnv ( tcGetInstEnv )
11 import InstEnv ( classInstEnv )
13 import TcType ( TcType, TcTyVarSet, zonkTcType )
14 import TcUnify ( unifyTauTyLists )
15 import Inst ( LIE, getFunDepsOfLIE, getIPsOfLIE )
16 import VarSet ( VarSet, emptyVarSet, unionVarSet )
17 import FunDeps ( instantiateFdClassTys )
22 tcImprove :: LIE -> TcM ()
23 -- Do unifications based on functional dependencies in the LIE
25 = tcGetInstEnv `thenNF_Tc` \ inst_env ->
27 nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
28 nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
30 cfdss :: [(Class, [FunDep TcType])]
31 cfdss = getFunDepsOfLIE lie
32 clas_nfdss = [(emptyVarSet, className c, fds) | (c,fds) <- cfdss]
34 classes = nub (map fst cfdss)
35 inst_nfdss = [ (free, className c, instantiateFdClassTys c ts)
37 (free, ts, i) <- classInstEnv inst_env c
40 ip_nfdss = [(emptyVarSet, n, [([], [ty])]) | (n,ty) <- getIPsOfLIE lie]
43 class C a b c | a->b where ...
46 Given the LIE FD C (Int->t)
47 we get clas_nfdss = [({}, C, [Int->t, t->Int])
48 inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
50 Another way would be to flatten a bit
51 we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
52 inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
54 iterImprove then matches up the C and Int, and unifies t <-> Bool
61 iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM ()
62 iterImprove [] = returnTc ()
64 = selfImprove pairImprove cfdss `thenTc` \ change2 ->
65 if {- change1 || -} change2 then
70 -- ZZ this will do a lot of redundant checking wrt instances
71 -- it would do to make this operate over two lists, the first
72 -- with only clas_nfds and ip_nfds, and the second with everything
73 -- control would otherwise mimic the current loop, so that the
74 -- caller could control whether the redundant inst improvements
76 -- you could then also use this to check for consistency of new instances
78 -- selfImprove is really just doing a cartesian product of all the fds
79 selfImprove f [] = returnTc False
80 selfImprove f (nfds : nfdss)
81 = mapTc (f nfds) nfdss `thenTc` \ changes ->
82 selfImprove f nfdss `thenTc` \ rest_changed ->
83 returnTc (or changes || rest_changed)
85 pairImprove (free1, n1, fds1) (free2, n2, fds2)
87 checkFds (free1 `unionVarSet` free2) fds1 fds2
91 checkFds free [] [] = returnTc False
92 checkFds free (fd1 : fd1s) (fd2 : fd2s) =
93 checkFd free fd1 fd2 `thenTc` \ change ->
94 checkFds free fd1s fd2s `thenTc` \ changes ->
95 returnTc (change || changes)
96 --checkFds _ _ = returnTc False
98 checkFd free (t_x, t_y) (s_x, s_y)
99 -- we need to zonk each time because unification
100 -- may happen at any time
101 = zonkUnifyTys free t_x s_x `thenTc` \ msubst ->
104 let full_subst = mkSubst emptyInScopeSet subst
105 t_y' = map (substTy full_subst) t_y
106 s_y' = map (substTy full_subst) s_y
108 zonkEqTys t_y' s_y' `thenTc` \ eq ->
110 -- they're the same, nothing changes...
113 -- ZZ what happens if two instance vars unify?
114 unifyTauTyLists t_y' s_y' `thenTc_`
115 -- if we get here, something must have unified
121 = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
122 mapTc zonkTcType ts2 `thenTc` \ ts2' ->
123 returnTc (ts1' == ts2')
125 zonkUnifyTys free ts1 ts2
126 = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
127 mapTc zonkTcType ts2 `thenTc` \ ts2' ->
128 -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
129 case unifyTyListsX free ts2' ts1' of
130 Just subst -> returnTc (Just subst)
131 Nothing -> returnTc Nothing