[project @ 2000-11-13 10:34:52 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index 74f38b9..6c7c51c 100644 (file)
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -4,68 +4,61 @@ module TcImprove ( tcImprove ) where
 #include "HsVersions.h"
 
 import Name            ( Name )
-import Class           ( Class, FunDep, className, classInstEnv, classExtraBigSig )
-import Unify           ( unifyTyListsX, matchTys )
-import Subst           ( mkSubst, substTy )
+import Class           ( Class, FunDep, className )
+import Unify           ( unifyTyListsX )
+import Subst           ( mkSubst, emptyInScopeSet, substTy )
+import TcEnv           ( tcGetInstEnv )
+import InstEnv ( classInstEnv )
 import TcMonad
-import TcType          ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
+import TcType          ( TcType, TcTyVarSet, zonkTcType )
 import TcUnify         ( unifyTauTyLists )
-import Inst            ( LIE, Inst, LookupInstResult(..),
-                         lookupInst, getFunDepsOfLIE, getIPsOfLIE,
-                         zonkLIE, zonkFunDeps {- for debugging -} )
-import InstEnv         ( InstEnv )             -- Reqd for 4.02; InstEnv is a synonym, and
-                                               -- 4.02 doesn't "see" it soon enough
+import Inst            ( LIE, getFunDepsOfLIE, getIPsOfLIE )
 import VarSet          ( VarSet, emptyVarSet, unionVarSet )
-import VarEnv          ( emptyVarEnv )
 import FunDeps         ( instantiateFdClassTys )
-import Outputable
-import List            ( elemIndex, nub )
+import List            ( nub )
 \end{code}
 
 \begin{code}
-tcImprove :: LIE -> TcM s ()
+tcImprove :: LIE -> TcM ()
 -- Do unifications based on functional dependencies in the LIE
 tcImprove lie 
-  | null nfdss = returnTc ()
-  | otherwise  = iterImprove nfdss
-  where
+  = tcGetInstEnv       `thenNF_Tc` \ inst_env ->
+    let
        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
-
-{- 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
-
-iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
+       cfdss      = getFunDepsOfLIE lie
+       clas_nfdss = [(emptyVarSet, className c, fds) | (c,fds) <- cfdss]
+
+       classes    = nub (map fst cfdss)
+       inst_nfdss = [ (free, className c, instantiateFdClassTys c ts)
+                    | c <- classes,
+                      (free, ts, i) <- classInstEnv inst_env c
+                    ]
+
+       ip_nfdss = [(emptyVarSet, n, [([], [ty])]) | (n,ty) <- getIPsOfLIE lie]
+
+       {- 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
+       -}      
+
+    in
+    iterImprove nfdss
+
+
+iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM ()
 iterImprove [] = returnTc ()
 iterImprove cfdss
   = selfImprove pairImprove cfdss      `thenTc` \ change2 ->
@@ -108,8 +101,9 @@ checkFd free (t_x, t_y) (s_x, s_y)
   = zonkUnifyTys free t_x s_x `thenTc` \ msubst ->
     case msubst of
       Just subst ->
-       let t_y' = map (substTy (mkSubst emptyVarEnv subst)) t_y
-           s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y
+       let full_subst = mkSubst emptyInScopeSet subst
+           t_y' = map (substTy full_subst) t_y
+           s_y' = map (substTy full_subst) s_y
        in
            zonkEqTys t_y' s_y' `thenTc` \ eq ->
            if eq then
@@ -128,15 +122,6 @@ zonkEqTys ts1 ts2
     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
     returnTc (ts1' == ts2')
 
-zonkMatchTys ts1 free ts2
-  = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
-    mapTc zonkTcType ts2 `thenTc` \ ts2' ->
-    -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
-    case matchTys free ts2' ts1' of
-      Just (subst, []) -> -- pprTrace "zMT match!" empty $
-                         returnTc (Just subst)
-      Nothing -> returnTc Nothing
-
 zonkUnifyTys free ts1 ts2
   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
     mapTc zonkTcType ts2 `thenTc` \ ts2' ->