Rewrite the unsafe code dealing with unboxed primitives in RtClosureInspect

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

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 9b49f5c..b8c82f8 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -6,10 +6,12 @@ FamInstEnv: Type checked family instance declarations
 
 \begin{code}
 module FamInstEnv (
-       FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts, 
+       FamInst(..), famInstTyCon, famInstTyVars, 
+       pprFamInst, pprFamInstHdr, pprFamInsts, 
        famInstHead, mkLocalFamInst, mkImportedFamInst,
 
-       FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, 
+       FamInstEnvs, FamInstEnv, emptyFamInstEnv, 
+       extendFamInstEnv, extendFamInstEnvList, 
        famInstEnvElts, familyInstances,
 
        lookupFamInstEnv, lookupFamInstEnvUnify
@@ -32,7 +34,6 @@ import UniqFM
 import Outputable
 
 import Maybe
-import Monad
 \end{code}
 
 
@@ -45,13 +46,19 @@ import Monad
 \begin{code}
 data FamInst 
   = FamInst { fi_fam   :: Name         -- Family name
+               -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
+               --                         Just (tc, tys) -> tc
 
                -- Used for "rough matching"; same idea as for class instances
            , fi_tcs   :: [Maybe Name]  -- Top of type args
+               -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
 
                -- Used for "proper matching"; ditto
            , fi_tvs   :: TyVarSet      -- Template tyvars for full match
            , fi_tys   :: [Type]        -- Full arg types
+               -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
+               --            fi_tys = case tyConFamInst_maybe fi_tycon of
+               --                         Just (_, tys) -> tys
 
            , fi_tycon :: TyCon         -- Representation tycon
            }
@@ -60,6 +67,8 @@ data FamInst
 --
 famInstTyCon :: FamInst -> TyCon
 famInstTyCon = fi_tycon
+
+famInstTyVars = fi_tvs
 \end{code}
 
 \begin{code}
@@ -73,14 +82,13 @@ instance Outputable FamInst where
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)
-       2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
+       2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst)))
 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
-    pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> 
-             sep (map pprParendType tys)
+    pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
                 | isNewTyCon  tycon = ptext SLIT("newtype instance")
                 | isSynTyCon  tycon = ptext SLIT("type instance")
@@ -140,6 +148,9 @@ InstEnv maps a family name to the list of known instances for that family.
 \begin{code}
 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
 
+type FamInstEnvs = (FamInstEnv, FamInstEnv)
+       -- External package inst-env, Home-package inst-env
+
 data FamilyInstEnv
   = FamIE [FamInst]    -- The instances for a particular family, in any order
          Bool          -- True <=> there is an instance of form T a b c
@@ -174,7 +185,7 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
     add (FamIE items tyvar) _ = FamIE (ins_item:items)
                                      (ins_tyvar || tyvar)
     ins_tyvar = not (any isJust mb_tcs)
-\end{code}                   
+\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -187,11 +198,24 @@ Multiple matches are only possible in case of type families (not data
 families), and then, it doesn't matter which match we choose (as the
 instances are guaranteed confluent).
 
+We return the matching family instances and the type instance at which it
+matches.  For example, if we lookup 'T [Int]' and have a family instance
+
+  data instance T [a] = ..
+
+desugared to
+
+  data :R42T a = ..
+  coe :Co:R42T a :: T [a] ~ :R42T a
+
+we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
+
 \begin{code}
-lookupFamInstEnv :: (FamInstEnv        -- External package inst-env
-                   ,FamInstEnv)        -- Home-package inst-env
+type FamInstMatch = (FamInst, [Type])           -- Matching type instance
+
+lookupFamInstEnv :: FamInstEnvs
                 -> TyCon -> [Type]             -- What we are looking for
-                -> [(TvSubst, FamInst)]        -- Successful matches
+                -> [FamInstMatch]              -- Successful matches
 lookupFamInstEnv (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where
@@ -221,7 +245,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys
 
         -- Proper check
       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
-      = (subst, item) : find rest
+      = (item, substTyVars subst (tyConTyVars tycon)) : find rest
 
         -- No match => try next
       | otherwise
@@ -240,7 +264,7 @@ indexed synonyms and we don't want to slow that down by needless unification.
 
 \begin{code}
 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
-                     -> [(TvSubst, FamInst)]
+                     -> [(FamInstMatch)]
 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where
@@ -276,7 +300,9 @@ lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
                -- Unification will break badly if the variables overlap
                -- They shouldn't because we allocate separate uniques for them
         case tcUnifyTys bind_fn tpl_tys tys of
-           Just subst -> (subst, item) : find rest
+           Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
+                          in
+                          (item, rep_tys) : find rest
            Nothing    -> find rest
 
 -- See explanation at @InstEnv.bind_fn@.