Fix bug in type checking interface DataAlts

Mon Sep 18 17:05:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fix bug in type checking interface DataAlts
  Sun Aug  6 20:11:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fix bug in type checking interface DataAlts
    Mon Jul 31 05:30:02 EDT 2006  kevind@bu.edu

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index d4033f3..1bd0acd 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -33,7 +33,7 @@ module CoreUtils (
        -- Equality
        cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
 
-        dataConInstPat
+        dataConInstPat, dataConOccInstPat
     ) where
 
 #include "HsVersions.h"
@@ -46,6 +46,7 @@ import CoreFVs                ( exprFreeVars )
 import PprCore         ( pprCoreExpr )
 import Var             ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique,
                           mkCoVar, mkTyVar, mkCoVar )
+import OccName          ( OccName, occNameFS, mkVarOcc )
 import VarSet          ( unionVarSet )
 import VarEnv
 import Name            ( hashName, mkSysTvName )
@@ -86,6 +87,7 @@ import Outputable
 import DynFlags                ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
 import TysPrim         ( alphaTy )     -- Debugging only
 import Util             ( equalLength, lengthAtLeast, foldl2 )
+import FastString       ( mkFastString )
 \end{code}
 
 
@@ -678,7 +680,7 @@ deepCast ty tyVars co
     coArgs = decomposeCo (length tyVars) co
 
 -- This goes here to avoid circularity between DataCon and Id
-dataConInstPat :: [Unique]                  -- An infinite list of uniques
+dataConInstPat :: [Unique]                  -- A long enough list of uniques, at least one for each binder
                -> DataCon
               -> [Type]                    -- Types to instantiate the universally quantified tyvars
               -> ([TyVar], [CoVar], [Id])  -- Return instantiated variables
@@ -709,6 +711,23 @@ dataConInstPat :: [Unique]                  -- An infinite list of uniques
 --
 --  where the double-primed variables are created from the unique list input
 dataConInstPat uniqs con inst_tys 
+  = dataConOccInstPat uniqs occs con inst_tys
+  where
+     -- dataConOccInstPat doesn't actually make use of the OccName directly for
+     -- existential and coercion variable binders, so it is right to just
+     -- use the VarName namespace for all of the OccNames
+    occs      = mk_occs 1
+    mk_occs n = mkVarOcc ("ipv" ++ show n) : mk_occs (n+1)
+
+dataConOccInstPat :: [Unique]                  -- A long enough list of uniques, at least one for each binder
+                  -> [OccName]                 -- An equally long list of OccNames to use
+                  -> DataCon
+                 -> [Type]                    -- Types to instantiate the universally quantified tyvars
+              -> ([TyVar], [CoVar], [Id])  -- Return instantiated variables
+-- This function actually does the job specified in the comment for 
+-- dataConInstPat, but uses the specified list of OccNames.  This is 
+-- is necessary for use in e.g. tcIfaceDataAlt
+dataConOccInstPat uniqs occs con inst_tys 
   = (ex_bndrs, co_bndrs, id_bndrs)
   where 
     univ_tvs = dataConUnivTyVars con
@@ -721,29 +740,34 @@ dataConInstPat uniqs con inst_tys
     n_co = length eq_spec
     n_id = length arg_tys
 
-      -- split the uniques
-    (ex_uniqs, uniqs') = splitAt n_ex uniqs
+      -- split the Uniques and OccNames
+    (ex_uniqs, uniqs')   = splitAt n_ex uniqs
     (co_uniqs, id_uniqs) = splitAt n_co uniqs'
 
+    (ex_occs, occs')     = splitAt n_ex occs
+    (co_occs, id_occs)   = splitAt n_co occs'
+
       -- make existential type variables
-    mk_ex_var uniq var = setVarUnique var uniq
-    ex_bndrs = zipWith mk_ex_var ex_uniqs ex_tvs
+    mk_ex_var uniq occ var = mkTyVar new_name kind
+      where
+        new_name = mkSysTvName uniq (occNameFS occ)
+        kind     = tyVarKind var
+
+    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_occs ex_tvs
 
       -- make the instantiation substitution
     inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 
       -- make new coercion vars, instantiating kind
-    mk_co_var uniq eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred))
+    mk_co_var uniq occ eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred))
        where
-         new_name = mkSysTvName uniq FSLIT("co")
+         new_name = mkSysTvName uniq (occNameFS occ)
 
-    co_bndrs               = zipWith mk_co_var co_uniqs eq_preds
+    co_bndrs               = zipWith3 mk_co_var co_uniqs co_occs eq_preds
 
       -- make value vars, instantiating types
-    mk_id_var uniq ty = mkSysLocal FSLIT("ca") uniq (inst_subst ty)
-
-    id_bndrs = zipWith mk_id_var id_uniqs arg_tys
-
+    mk_id_var uniq occ ty = mkUserLocal occ uniq (inst_subst ty) noSrcLoc
+    id_bndrs = zipWith3 mk_id_var id_uniqs id_occs arg_tys
 
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 -- Returns (Just (dc, [x1..xn])) if the argument expression is 
@@ -1133,6 +1157,7 @@ eta_expand n us expr ty
   = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
     case splitForAllTy_maybe ty of { 
          Just (tv,ty') -> 
+
               Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
                   where 
                     lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv)

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 94e0dcb..051ec04 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -35,7 +35,7 @@ import HscTypes               ( ExternalPackageState(..),
                          emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv         ( Instance(..), mkImportedInstance )
 import CoreSyn
-import CoreUtils       ( exprType, dataConInstPat )
+import CoreUtils       ( exprType, dataConOccInstPat )
 import CoreUnfold
 import CoreLint                ( lintUnfolding )
 import WorkWrap                ( mkWrapper )
@@ -680,7 +680,7 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
 tcIfaceDataAlt con inst_tys arg_strs rhs
   = do { us <- newUniqueSupply
        ; let uniqs = uniqsFromSupply us
-       ; let   (ex_tvs, co_tvs, arg_ids) = dataConInstPat uniqs con inst_tys
+       ; let   (ex_tvs, co_tvs, arg_ids) = dataConOccInstPat uniqs arg_occs con inst_tys
                 all_tvs                   = ex_tvs ++ co_tvs
 
        ; rhs' <- extendIfaceTyVarEnv all_tvs   $