ghc/compiler/typecheck/TcImprove.lhs

   1 \begin{code}
   2 module TcImprove ( tcImprove ) where
   3
   4 #include "HsVersions.h"
   5
   6 import Name             ( Name )
   7 import Type             ( Type, tyVarsOfTypes )
   8 import Class            ( className, classInstEnv, classExtraBigSig )
   9 import Unify            ( unifyTyListsX, matchTys )
  10 import Subst            ( mkSubst, substTy )
  11 import TcMonad
  12 import TcType           ( zonkTcType, zonkTcTypes )
  13 import TcUnify          ( unifyTauTyLists )
  14 import Inst             ( Inst, LookupInstResult(..),
  15                           lookupInst, isDict, getFunDepsOfLIE, getIPsOfLIE,
  16                           zonkLIE, zonkFunDeps {- for debugging -} )
  17 import InstEnv          ( InstEnv )             -- Reqd for 4.02; InstEnv is a synonym, and
  18                                                 -- 4.02 doesn't "see" it soon enough
  19 import VarSet           ( VarSet, emptyVarSet, unionVarSet )
  20 import VarEnv           ( emptyVarEnv )
  21 import FunDeps          ( instantiateFdClassTys )
  22 import Outputable
  23 import List             ( elemIndex, nub )
  24 \end{code}
  25
  26 \begin{code}
  27 tcImprove lie =
  28     if null cfdss then
  29         returnTc ()
  30     else
  31         -- zonkCfdss cfdss `thenTc` \ cfdss' ->
  32         -- pprTrace "tcI" (ppr cfdss') $
  33         iterImprove nfdss
  34     where
  35         cfdss = getFunDepsOfLIE lie
  36         clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss
  37         classes = nub (map fst cfdss)
  38         inst_nfdss = concatMap getInstNfdssOf classes
  39         ips = getIPsOfLIE lie
  40         ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
  41         nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
  42
  43 getInstNfdssOf clas = nfdss
  44     where
  45         nm = className clas
  46         ins = classInstEnv clas
  47         mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts)
  48         nfdss = map mk_nfds ins
  49
  50 iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s ()
  51 iterImprove [] = returnTc ()
  52 iterImprove cfdss
  53   = -- zonkCfdss cfdss `thenTc` \ cfdss' ->
  54     -- pprTrace "iterI" (ppr cfdss') $
  55     -- instImprove cfdss                        `thenTc` \ change1 ->
  56     selfImprove pairImprove cfdss       `thenTc` \ change2 ->
  57     if {- change1 || -} change2 then
  58         iterImprove cfdss
  59     else
  60         returnTc ()
  61
  62 -- ZZ debugging...
  63 zonkCfdss ((c, fds) : cfdss)
  64   = zonkFunDeps fds `thenTc` \ fds' ->
  65     zonkCfdss cfdss `thenTc` \ cfdss' ->
  66     returnTc ((c, fds') : cfdss')
  67 zonkCfdss [] = returnTc []
  68
  69 {-
  70 instImprove (cfds@(clas, fds) : cfdss)
  71   = instImprove1 cfds ins       `thenTc` \ changed ->
  72     instImprove cfdss           `thenTc` \ rest_changed ->
  73     returnTc (changed || rest_changed)
  74   where ins = classInstEnv clas
  75 instImprove [] = returnTc False
  76
  77 instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins)
  78   = -- pprTrace "iI1" (ppr (free, ts, i)) $
  79     checkFds fds1 free fds2     `thenTc` \ changed ->
  80     instImprove1 cfds ins       `thenTc` \ rest_changed ->
  81     returnTc (changed || rest_changed)
  82   where fds2 = instantiateFdClassTys clas ts
  83 instImprove1 _ _ = returnTc False
  84 -}
  85
  86 -- ZZ this will do a lot of redundant checking wrt instances
  87 -- it would do to make this operate over two lists, the first
  88 -- with only clas_nfds and ip_nfds, and the second with everything
  89 -- control would otherwise mimic the current loop, so that the
  90 -- caller could control whether the redundant inst improvements
  91 -- were avoided
  92 -- you could then also use this to check for consistency of new instances
  93 selfImprove f [] = returnTc False
  94 selfImprove f (nfds : nfdss)
  95   = mapTc (f nfds) nfdss        `thenTc` \ changes ->
  96     anyTc changes               `thenTc` \ changed ->
  97     selfImprove f nfdss         `thenTc` \ rest_changed ->
  98     returnTc (changed || rest_changed)
  99
 100 pairImprove (free1, n1, fds1) (free2, n2, fds2)
 101   = if n1 == n2 then
 102         checkFds (free1 `unionVarSet` free2) fds1 fds2
 103     else
 104         returnTc False
 105
 106 checkFds free [] [] = returnTc False
 107 checkFds free (fd1 : fd1s) (fd2 : fd2s) =
 108     checkFd free fd1 fd2        `thenTc` \ change ->
 109     checkFds free fd1s fd2s     `thenTc` \ changes ->
 110     returnTc (change || changes)
 111 --checkFds _ _ = returnTc False
 112
 113 checkFd free (t_x, t_y) (s_x, s_y)
 114   -- we need to zonk each time because unification
 115   -- may happen at any time
 116   = zonkUnifyTys free t_x s_x `thenTc` \ msubst ->
 117     case msubst of
 118       Just subst ->
 119         let t_y' = map (substTy (mkSubst emptyVarEnv subst)) t_y
 120             s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y
 121         in
 122             zonkEqTys t_y' s_y' `thenTc` \ eq ->
 123             if eq then
 124                 -- they're the same, nothing changes...
 125                 returnTc False
 126             else
 127                 -- ZZ what happens if two instance vars unify?
 128                 unifyTauTyLists t_y' s_y' `thenTc_`
 129                 -- if we get here, something must have unified
 130                 returnTc True
 131       Nothing ->
 132         returnTc False
 133
 134 zonkEqTys ts1 ts2
 135   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
 136     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
 137     returnTc (ts1' == ts2')
 138
 139 zonkMatchTys ts1 free ts2
 140   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
 141     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
 142     -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
 143     case matchTys free ts2' ts1' of
 144       Just (subst, []) -> -- pprTrace "zMT match!" empty $
 145                           returnTc (Just subst)
 146       Nothing -> returnTc Nothing
 147
 148 zonkUnifyTys free ts1 ts2
 149   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
 150     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
 151     -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
 152     case unifyTyListsX free ts2' ts1' of
 153       Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $
 154                           returnTc (Just subst)
 155       Nothing -> returnTc Nothing
 156 \end{code}
 157
 158 Utilities:
 159
 160 A monadic version of the standard Prelude `or' function.
 161 \begin{code}
 162 anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
 163 \end{code}