[project @ 2006-01-09 10:31:14 by simonmar]

[ghc-hetmet.git] / ghc / compiler / types / Unify.lhs

diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs
index 255a7f1..d5d6d1d 100644 (file)
--- a/ghc/compiler/types/Unify.lhs
+++ b/ghc/compiler/types/Unify.lhs
@@ -1,7 +1,7 @@
 \begin{code}
 module Unify ( 
        -- Matching and unification
-       tcMatchTys, tcMatchTyX, tcMatchPreds, MatchEnv(..), 
+       tcMatchTys, tcMatchTyX, ruleMatchTyX, tcMatchPreds, MatchEnv(..), 
 
        tcUnifyTys, 
 
@@ -20,9 +20,10 @@ import VarEnv
 import VarSet
 import Kind            ( isSubKind )
 import Type            ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys,
-                         TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX )
+                         TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX,
+                         tcView )
 import TypeRep          ( Type(..), PredType(..), funTyCon )
-import DataCon                 ( DataCon, dataConResTy )
+import DataCon                 ( DataCon, dataConInstResTy )
 import Util            ( snocView )
 import ErrUtils                ( Message )
 import Outputable
@@ -81,6 +82,19 @@ tcMatchTys tmpls tys1 tys2
        -- We're assuming that all the interesting 
        -- tyvars in tys1 are in tmpls
 
+-- This is similar, but extends a substitution
+tcMatchTyX :: TyVarSet                 -- Template tyvars
+          -> TvSubst           -- Substitution to extend
+          -> Type              -- Template
+          -> Type              -- Target
+          -> Maybe TvSubst
+tcMatchTyX tmpls (TvSubst in_scope subst_env) ty1 ty2
+  = case match menv subst_env ty1 ty2 of
+       Just subst_env -> Just (TvSubst in_scope subst_env)
+       Nothing        -> Nothing
+  where
+    menv = ME {me_tmpls = tmpls, me_env = mkRnEnv2 in_scope}
+
 tcMatchPreds
        :: [TyVar]                      -- Bind these
        -> [PredType] -> [PredType]
@@ -92,13 +106,13 @@ tcMatchPreds tmpls ps1 ps2
     in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2)
 
 -- This one is called from the expression matcher, which already has a MatchEnv in hand
-tcMatchTyX :: MatchEnv 
+ruleMatchTyX :: MatchEnv 
         -> TvSubstEnv          -- Substitution to extend
         -> Type                -- Template
         -> Type                -- Target
         -> Maybe TvSubstEnv
 
-tcMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2       -- Rename for export
+ruleMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2     -- Rename for export
 \end{code}
 
 Now the internals of matching
@@ -114,8 +128,8 @@ match :: MatchEnv   -- For the most part this is pushed downwards
 -- This matcher works on source types; that is, 
 -- it respects NewTypes and PredType
 
-match menv subst (NoteTy _ ty1) ty2 = match menv subst ty1 ty2
-match menv subst ty1 (NoteTy _ ty2) = match menv subst ty1 ty2
+match menv subst ty1 ty2 | Just ty1' <- tcView ty1 = match menv subst ty1' ty2
+match menv subst ty1 ty2 | Just ty2' <- tcView ty2 = match menv subst ty1 ty2'
 
 match menv subst (TyVarTy tv1) ty2
   | tv1 `elemVarSet` me_tmpls menv
@@ -231,7 +245,7 @@ coreRefineTys in_scope con tvs scrut_ty
                
        ; return (subst_env_fixpt, all_bound_here subst_env) }
   where
-    pat_res_ty = dataConResTy con (mkTyVarTys tvs)
+    pat_res_ty = dataConInstResTy con (mkTyVarTys tvs)
 
        -- 'tvs' are the tyvars bound by the pattern
     tv_set            = mkVarSet tvs
@@ -281,8 +295,8 @@ unify subst ty1 ty2 = -- pprTrace "unify" (ppr subst <+> pprParendType ty1 <+> p
 unify_ subst (TyVarTy tv1) ty2  = uVar False subst tv1 ty2
 unify_ subst ty1 (TyVarTy tv2)  = uVar True  subst tv2 ty1
 
-unify_ subst (NoteTy _ ty1) ty2  = unify subst ty1 ty2
-unify_ subst ty1 (NoteTy _ ty2)  = unify subst ty1 ty2
+unify_ subst ty1 ty2 | Just ty1' <- tcView ty1 = unify subst ty1' ty2
+unify_ subst ty1 ty2 | Just ty2' <- tcView ty2 = unify subst ty1 ty2'
 
 unify_ subst (PredTy p1) (PredTy p2) = unify_pred subst p1 p2
 
@@ -355,8 +369,9 @@ uUnrefined :: TvSubstEnv          -- An existing substitution to extend
 
 -- We know that tv1 isn't refined
 
-uUnrefined subst tv1 ty2 (NoteTy _ ty2')
-  = uUnrefined subst tv1 ty2 ty2'      -- Unwrap synonyms
+uUnrefined subst tv1 ty2 ty2'
+  | Just ty2'' <- tcView ty2'
+  = uUnrefined subst tv1 ty2 ty2''     -- Unwrap synonyms
                -- This is essential, in case we have
                --      type Foo a = a
                -- and then unify a :=: Foo a