[project @ 2000-05-25 12:41:14 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcImprove.lhs

diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index 1451d44..74f38b9 100644 (file)
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -4,14 +4,13 @@ module TcImprove ( tcImprove ) where
 #include "HsVersions.h"
 
 import Name            ( Name )
-import Type            ( Type, tyVarsOfTypes )
-import Class           ( className, classInstEnv, classExtraBigSig )
+import Class           ( Class, FunDep, className, classInstEnv, classExtraBigSig )
 import Unify           ( unifyTyListsX, matchTys )
 import Subst           ( mkSubst, substTy )
 import TcMonad
-import TcType          ( zonkTcType, zonkTcTypes )
+import TcType          ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
 import TcUnify         ( unifyTauTyLists )
-import Inst            ( Inst, LookupInstResult(..),
+import Inst            ( LIE, Inst, LookupInstResult(..),
                          lookupInst, getFunDepsOfLIE, getIPsOfLIE,
                          zonkLIE, zonkFunDeps {- for debugging -} )
 import InstEnv         ( InstEnv )             -- Reqd for 4.02; InstEnv is a synonym, and
@@ -24,65 +23,57 @@ import List         ( elemIndex, nub )
 \end{code}
 
 \begin{code}
-tcImprove lie =
-    if null nfdss then
-       returnTc ()
-    else
-       -- zonkCfdss cfdss `thenTc` \ cfdss' ->
-       -- pprTrace "tcI" (ppr cfdss') $
-       iterImprove nfdss
-    where
+tcImprove :: LIE -> TcM s ()
+-- Do unifications based on functional dependencies in the LIE
+tcImprove lie 
+  | null nfdss = returnTc ()
+  | otherwise  = iterImprove nfdss
+  where
+       nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
+       nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
+
+       cfdss :: [(Class, [FunDep TcType])]
        cfdss = getFunDepsOfLIE lie
        clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss
+
        classes = nub (map fst cfdss)
        inst_nfdss = concatMap getInstNfdssOf classes
+
        ips = getIPsOfLIE lie
        ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
-       nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
 
-getInstNfdssOf clas = nfdss
-    where
+{- Example: we have
+       class C a b c  |  a->b where ...
+       instance C Int Bool c 
+
+   Given the LIE       FD C (Int->t)
+   we get      clas_nfdss = [({}, C, [Int->t,     t->Int])
+               inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
+
+   Another way would be to flatten a bit
+   we get      clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
+               inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
+
+   iterImprove then matches up the C and Int, and unifies t <-> Bool
+-}
+
+getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])]
+getInstNfdssOf clas 
+  = [ (free, nm, instantiateFdClassTys clas ts)
+    | (free, ts, i) <- classInstEnv clas
+    ]
+  where
        nm = className clas
-       ins = classInstEnv clas
-       mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts)
-       nfdss = map mk_nfds ins
 
-iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s ()
+iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
 iterImprove [] = returnTc ()
 iterImprove cfdss
-  = -- zonkCfdss cfdss `thenTc` \ cfdss' ->
-    -- pprTrace "iterI" (ppr cfdss') $
-    -- instImprove cfdss                       `thenTc` \ change1 ->
-    selfImprove pairImprove cfdss      `thenTc` \ change2 ->
+  = selfImprove pairImprove cfdss      `thenTc` \ change2 ->
     if {- change1 || -} change2 then
        iterImprove cfdss
     else
        returnTc ()
 
--- ZZ debugging...
-zonkCfdss ((c, fds) : cfdss)
-  = zonkFunDeps fds `thenTc` \ fds' ->
-    zonkCfdss cfdss `thenTc` \ cfdss' ->
-    returnTc ((c, fds') : cfdss')
-zonkCfdss [] = returnTc []
-
-{-
-instImprove (cfds@(clas, fds) : cfdss)
-  = instImprove1 cfds ins      `thenTc` \ changed ->
-    instImprove cfdss          `thenTc` \ rest_changed ->
-    returnTc (changed || rest_changed)
-  where ins = classInstEnv clas
-instImprove [] = returnTc False
-
-instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins)
-  = -- pprTrace "iI1" (ppr (free, ts, i)) $
-    checkFds fds1 free fds2    `thenTc` \ changed ->
-    instImprove1 cfds ins      `thenTc` \ rest_changed ->
-    returnTc (changed || rest_changed)
-  where fds2 = instantiateFdClassTys clas ts
-instImprove1 _ _ = returnTc False
--}
-
 -- ZZ this will do a lot of redundant checking wrt instances
 -- it would do to make this operate over two lists, the first
 -- with only clas_nfds and ip_nfds, and the second with everything
@@ -90,12 +81,13 @@ instImprove1 _ _ = returnTc False
 -- caller could control whether the redundant inst improvements
 -- were avoided
 -- you could then also use this to check for consistency of new instances
+
+-- selfImprove is really just doing a cartesian product of all the fds
 selfImprove f [] = returnTc False
 selfImprove f (nfds : nfdss)
   = mapTc (f nfds) nfdss       `thenTc` \ changes ->
-    anyTc changes              `thenTc` \ changed ->
     selfImprove f nfdss                `thenTc` \ rest_changed ->
-    returnTc (changed || rest_changed)
+    returnTc (or changes || rest_changed)
 
 pairImprove (free1, n1, fds1) (free2, n2, fds2)
   = if n1 == n2 then
@@ -150,14 +142,6 @@ zonkUnifyTys free ts1 ts2
     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
     -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
     case unifyTyListsX free ts2' ts1' of
-      Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $
-                         returnTc (Just subst)
-      Nothing -> returnTc Nothing
-\end{code}
-
-Utilities:
-
-A monadic version of the standard Prelude `or' function.
-\begin{code}
-anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
+      Just subst -> returnTc (Just subst)
+      Nothing    -> returnTc Nothing
 \end{code}