ghc/compiler/typecheck/TcImprove.lhs

   1 \begin{code}
   2 module TcImprove ( tcImprove ) where
   3
   4 #include "HsVersions.h"
   5
   6 import Type             ( tyVarsOfTypes )
   7 import Class            ( classInstEnv, classExtraBigSig )
   8 import Unify            ( matchTys )
   9 import Subst            ( mkSubst, substTy )
  10 import TcMonad
  11 import TcType           ( zonkTcType, zonkTcTypes )
  12 import TcUnify          ( unifyTauTyLists )
  13 import Inst             ( Inst, LookupInstResult(..),
  14                           lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
  15                           zonkLIE, zonkFunDeps {- for debugging -} )
  16 import InstEnv          ( InstEnv )             -- Reqd for 4.02; InstEnv is a synonym, and
  17                                                 -- 4.02 doesn't "see" it soon enough
  18 import VarSet           ( emptyVarSet )
  19 import VarEnv           ( emptyVarEnv )
  20 import FunDeps          ( instantiateFdClassTys )
  21 import Bag              ( bagToList )
  22 import Outputable
  23 import List             ( elemIndex )
  24 \end{code}
  25
  26 Improvement goes here.
  27
  28 \begin{code}
  29 tcImprove lie =
  30     if null cfdss then
  31         returnTc ()
  32     else
  33         -- zonkCfdss cfdss `thenTc` \ cfdss' ->
  34         -- pprTrace "tcI" (ppr cfdss') $
  35         iterImprove cfdss
  36     where cfdss = getFunDepsOfLIE lie
  37
  38 iterImprove [] = returnTc ()
  39 iterImprove cfdss
  40   = -- zonkCfdss cfdss `thenTc` \ cfdss' ->
  41     -- pprTrace "iterI" (ppr cfdss') $
  42     instImprove cfdss                   `thenTc` \ change1 ->
  43     selfImprove pairImprove cfdss       `thenTc` \ change2 ->
  44     if change1 || change2 then
  45         iterImprove cfdss
  46     else
  47         returnTc ()
  48
  49 -- ZZ debugging...
  50 zonkCfdss ((c, fds) : cfdss)
  51   = zonkFunDeps fds `thenTc` \ fds' ->
  52     zonkCfdss cfdss `thenTc` \ cfdss' ->
  53     returnTc ((c, fds') : cfdss')
  54 zonkCfdss [] = returnTc []
  55
  56 instImprove (cfds@(clas, fds) : cfdss)
  57   = instImprove1 cfds ins       `thenTc` \ changed ->
  58     instImprove cfdss           `thenTc` \ rest_changed ->
  59     returnTc (changed || rest_changed)
  60   where ins = classInstEnv clas
  61 instImprove [] = returnTc False
  62
  63 instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins)
  64   = -- pprTrace "iI1" (ppr (free, ts, i)) $
  65     checkFds fds1 free fds2     `thenTc` \ changed ->
  66     instImprove1 cfds ins       `thenTc` \ rest_changed ->
  67     returnTc (changed || rest_changed)
  68   where fds2 = instantiateFdClassTys clas ts
  69 instImprove1 _ _ = returnTc False
  70
  71 selfImprove f [] = returnTc False
  72 selfImprove f (cfds : cfdss)
  73   = mapTc (f cfds) cfdss        `thenTc` \ changes ->
  74     anyTc changes               `thenTc` \ changed ->
  75     selfImprove f cfdss         `thenTc` \ rest_changed ->
  76     returnTc (changed || rest_changed)
  77
  78 pairImprove (clas1, fds1) (clas2, fds2)
  79   = if clas1 == clas2 then
  80         checkFds fds1 emptyVarSet fds2
  81     else
  82         returnTc False
  83
  84 checkFds [] free [] = returnTc False
  85 checkFds (fd1 : fd1s) free (fd2 : fd2s) =
  86     checkFd fd1 free fd2        `thenTc` \ change ->
  87     checkFds fd1s free fd2s     `thenTc` \ changes ->
  88     returnTc (change || changes)
  89 --checkFds _ _ = returnTc False
  90
  91 checkFd (t_x, t_y) free (s_x, s_y)
  92   -- we need to zonk each time because unification
  93   -- may happen at any time
  94   = zonkMatchTys t_x free s_x `thenTc` \ msubst ->
  95     case msubst of
  96       Just subst ->
  97         let s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y in
  98             zonkEqTys t_y s_y' `thenTc` \ eq ->
  99             if eq then
 100                 -- they're the same, nothing changes...
 101                 returnTc False
 102             else
 103                 unifyTauTyLists t_y s_y' `thenTc_`
 104                 -- if we get here, something must have unified
 105                 returnTc True
 106       Nothing ->
 107         returnTc False
 108
 109 zonkEqTys ts1 ts2
 110   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
 111     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
 112     returnTc (ts1' == ts2')
 113
 114 zonkMatchTys ts1 free ts2
 115   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
 116     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
 117     -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
 118     case matchTys free ts2' ts1' of
 119       Just (subst, []) -> -- pprTrace "zMT match!" empty $
 120                           returnTc (Just subst)
 121       Nothing -> returnTc Nothing
 122 \end{code}
 123
 124 Utilities:
 125
 126 A monadic version of the standard Prelude `or' function.
 127 \begin{code}
 128 anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
 129 \end{code}