[project @ 1996-07-15 16:16:46 by partain]

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

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 5811679..4ae211d 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -21,7 +21,7 @@ module Type (
 
        SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
        mkDictTy,
-       mkRhoTy, splitRhoTy, mkTheta,
+       mkRhoTy, splitRhoTy, mkTheta, isDictTy,
        mkSigmaTy, splitSigmaTy,
 
        maybeAppTyCon, getAppTyCon,
@@ -41,9 +41,9 @@ module Type (
     ) where
 
 IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop)         -- for paranoia checking
-IMPORT_DELOOPER(TyLoop)         -- for paranoia checking
-IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
+--IMPORT_DELOOPER(IdLoop)       -- for paranoia checking
+IMPORT_DELOOPER(TyLoop)
+--IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
 
 -- friends:
 import Class   ( classSig, classOpLocalType, GenClass{-instances-} )
@@ -72,8 +72,8 @@ import        {-mumble-}
        Pretty
 import  {-mumble-}
        PprStyle
-import {-mumble-}
-       PprType --(pprType )
+--import       {-mumble-}
+--     PprType --(pprType )
 import  {-mumble-}
        UniqFM (ufmToList )
 import {-mumble-}
@@ -281,8 +281,8 @@ mkTyConTy tycon
 
 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
 applyTyCon tycon tys
-  = --ASSERT (not (isSynTyCon tycon))
-    (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
+  = ASSERT (not (isSynTyCon tycon))
+    --(if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
     foldl AppTy (TyConTy tycon usageOmega) tys
 
 getTyCon_maybe              :: GenType t u -> Maybe TyCon
@@ -348,7 +348,11 @@ mkTheta dict_tys
   = map cvt dict_tys
   where
     cvt (DictTy clas ty _) = (clas, ty)
-    cvt other             = pprPanic "mkTheta:" (pprType PprDebug other)
+    cvt other             = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
+
+isDictTy (DictTy _ _ _) = True
+isDictTy (SynTy  _ _ t) = isDictTy t
+isDictTy _             = False
 \end{code}
 
 
@@ -686,7 +690,7 @@ typePrimRep (AppTy ty _)    = typePrimRep ty
 typePrimRep (TyConTy tc _)  
   | isPrimTyCon tc         = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
                                   Just xx -> xx
-                                  Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+                                  Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
 
   | otherwise              = case maybeNewTyCon tc of
                                  Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
@@ -732,30 +736,38 @@ types.
 matchTy :: GenType t1 u1               -- Template
        -> GenType t2 u2                -- Proposed instance of template
        -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
+                                       
 
 matchTys :: [GenType t1 u1]            -- Templates
         -> [GenType t2 u2]             -- Proposed instance of template
-        -> Maybe [(t1,GenType t2 u2)]  -- Matching substitution
+        -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
+                  [GenType t2 u2])     -- Left over instance types
+
+matchTy  ty1  ty2  = match  ty1 ty2 (\s -> Just s) []
+matchTys tys1 tys2 = go [] tys1 tys2
+                  where
+                    go s []        tys2        = Just (s,tys2)
+                    go s (ty1:tys1) []         = panic "matchTys"
+                    go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
+                                                   
 
-matchTy  ty1  ty2  = match  [] [] ty1 ty2
-matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
 \end{code}
 
 @match@ is the main function.
 
 \begin{code}
-match :: [(t1, GenType t2 u2)]                 -- r, the accumulating result
-      -> [(GenType t1 u1, GenType t2 u2)]      -- w, the work list
-      -> GenType t1 u1 -> GenType t2 u2                -- Current match pair
-      -> Maybe [(t1, GenType t2 u2)]
-
-match r w (TyVarTy v)         ty                   = match' ((v,ty) : r) w
-match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
-match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
-match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
-match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
-match r w (SynTy _ _ ty1)      ty2                 = match r w ty1 ty2
-match r w ty1                 (SynTy _ _ ty2)      = match r w ty1 ty2
+match :: GenType t1 u1 -> GenType t2 u2                        -- Current match pair
+      -> ([(t1, GenType t2 u2)] -> Maybe result)       -- Continuation
+      -> [(t1, GenType t2 u2)]                         -- Current substitution
+      -> Maybe result
+
+match (TyVarTy v)         ty                   k = \s -> k ((v,ty) : s)
+match (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  k = match fun1 fun2 (match arg1 arg2 k)
+match (AppTy fun1 arg1)    (AppTy fun2 arg2)    k = match fun1 fun2 (match arg1 arg2 k)
+match (TyConTy con1 _)     (TyConTy con2 _)     k | con1  == con2  = k
+match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
+match (SynTy _ _ ty1)      ty2                 k = match ty1 ty2 k
+match ty1                     (SynTy _ _ ty2)  k = match ty1 ty2 k
 
        -- With type synonyms, we have to be careful for the exact
        -- same reasons as in the unifier.  Please see the
@@ -763,10 +775,7 @@ match r w ty1                     (SynTy _ _ ty2)      = match r w ty1 ty2
        -- here! (WDP 95/05)
 
 -- Catch-all fails
-match _ _ _ _ = Nothing
-
-match' r []           = Just r
-match' r ((ty1,ty2):w) = match r w ty1 ty2
+match _ _ _ = \s -> Nothing
 \end{code}
 
 %************************************************************************