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 )
  11 import InstEnv  ( classInstEnv )
  12 import TcMonad
  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 )
  18 import List             ( nub )
  19 \end{code}
  20
  21 \begin{code}
  22 tcImprove :: LIE -> TcM ()
  23 -- Do unifications based on functional dependencies in the LIE
  24 tcImprove lie
  25   = tcGetInstEnv        `thenNF_Tc` \ inst_env ->
  26     let
  27         nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
  28         nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
  29
  30         cfdss :: [(Class, [FunDep TcType])]
  31         cfdss      = getFunDepsOfLIE lie
  32         clas_nfdss = [(emptyVarSet, className c, fds) | (c,fds) <- cfdss]
  33
  34         classes    = nub (map fst cfdss)
  35         inst_nfdss = [ (free, className c, instantiateFdClassTys c ts)
  36                      | c <- classes,
  37                        (free, ts, i) <- classInstEnv inst_env c
  38                      ]
  39
  40         ip_nfdss = [(emptyVarSet, n, [([], [ty])]) | (n,ty) <- getIPsOfLIE lie]
  41
  42         {- Example: we have
  43                 class C a b c  |  a->b where ...
  44                 instance C Int Bool c
  45
  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])]
  49
  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)]
  53
  54            iterImprove then matches up the C and Int, and unifies t <-> Bool
  55         -}
  56
  57     in
  58     iterImprove nfdss
  59
  60
  61 iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM ()
  62 iterImprove [] = returnTc ()
  63 iterImprove cfdss
  64   = selfImprove pairImprove cfdss       `thenTc` \ change2 ->
  65     if {- change1 || -} change2 then
  66         iterImprove cfdss
  67     else
  68         returnTc ()
  69
  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
  75 -- were avoided
  76 -- you could then also use this to check for consistency of new instances
  77
  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)
  84
  85 pairImprove (free1, n1, fds1) (free2, n2, fds2)
  86   = if n1 == n2 then
  87         checkFds (free1 `unionVarSet` free2) fds1 fds2
  88     else
  89         returnTc False
  90
  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
  97
  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 ->
 102     case msubst of
 103       Just subst ->
 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
 107         in
 108             zonkEqTys t_y' s_y' `thenTc` \ eq ->
 109             if eq then
 110                 -- they're the same, nothing changes...
 111                 returnTc False
 112             else
 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
 116                 returnTc True
 117       Nothing ->
 118         returnTc False
 119
 120 zonkEqTys ts1 ts2
 121   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
 122     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
 123     returnTc (ts1' == ts2')
 124
 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
 132 \end{code}