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