make dataConInstPat take a list of FastStrings rather than OccNames, remove out-of...

[ghc-hetmet.git] / compiler / coreSyn / CoreUtils.lhs

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index d4033f3..b798379 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
+        dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
     ) 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, mkVarOccFS )
 import VarSet          ( unionVarSet )
 import VarEnv
 import Name            ( hashName, mkSysTvName )
@@ -54,9 +55,10 @@ import Packages              ( isDllName )
 #endif
 import Literal         ( hashLiteral, literalType, litIsDupable, 
                          litIsTrivial, isZeroLit, Literal( MachLabel ) )
-import DataCon         ( DataCon, dataConRepArity, 
+import DataCon         ( DataCon, dataConRepArity, eqSpecPreds, 
                          isVanillaDataCon, dataConTyCon, dataConRepArgTys,
-                          dataConUnivTyVars, dataConExTyVars, dataConEqSpec )
+                          dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
+                          dataConOrigArgTys )
 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
                          mkWildId, idArity, idName, idUnfolding, idInfo,
@@ -86,6 +88,7 @@ import Outputable
 import DynFlags                ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
 import TysPrim         ( alphaTy )     -- Debugging only
 import Util             ( equalLength, lengthAtLeast, foldl2 )
+import FastString       ( FastString )
 \end{code}
 
 
@@ -677,12 +680,19 @@ deepCast ty tyVars co
     -- coArgs = [right (left (left co)), right (left co), right co]
     coArgs = decomposeCo (length tyVars) co
 
--- This goes here to avoid circularity between DataCon and Id
-dataConInstPat :: [Unique]                  -- An infinite list of uniques
-               -> DataCon
-              -> [Type]                    -- Types to instantiate the universally quantified tyvars
-              -> ([TyVar], [CoVar], [Id])  -- Return instantiated variables
--- dataConInstPat us con inst_tys returns a triple (ex_tvs, co_tvs, arg_ids),
+-- These InstPat functions go here to avoid circularity between DataCon and Id
+dataConOrigInstPat   = dataConInstPat dataConOrigArgTys (repeat (FSLIT("ipv")))
+dataConRepInstPat    = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
+dataConRepFSInstPat = dataConInstPat dataConRepArgTys
+
+dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
+                  -> [FastString]          -- A long enough list of FSs to use for names
+                  -> [Unique]              -- An equally long list of uniques, at least one for each binder
+                  -> DataCon
+                 -> [Type]                -- Types to instantiate the universally quantified tyvars
+              -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
+-- dataConInstPat arg_fun us fss con inst_tys returns a triple 
+-- (ex_tvs, co_tvs, arg_ids),
 --
 --   ex_tvs are intended to be used as binders for existential type args
 --
@@ -708,42 +718,48 @@ dataConInstPat :: [Unique]                  -- An infinite list of uniques
 --  ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b''])
 --
 --  where the double-primed variables are created from the unique list input
-dataConInstPat uniqs con inst_tys 
+--  getting names from the FS list input
+dataConInstPat arg_fun fss uniqs con inst_tys 
   = (ex_bndrs, co_bndrs, id_bndrs)
   where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
-    arg_tys  = dataConRepArgTys con
+    arg_tys  = arg_fun con
     eq_spec  = dataConEqSpec con
-    eq_preds = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- eq_spec ]
+    eq_preds = eqSpecPreds eq_spec
 
     n_ex = length ex_tvs
     n_co = length eq_spec
     n_id = length arg_tys
 
-      -- split the uniques
-    (ex_uniqs, uniqs') = splitAt n_ex uniqs
+      -- split the Uniques and FastStrings
+    (ex_uniqs, uniqs')   = splitAt n_ex uniqs
     (co_uniqs, id_uniqs) = splitAt n_co uniqs'
 
+    (ex_fss, fss')     = splitAt n_ex fss
+    (co_fss, id_fss)   = splitAt n_co fss'
+
       -- 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 fs var = mkTyVar new_name kind
+      where
+        new_name = mkSysTvName uniq fs
+        kind     = tyVarKind var
+
+    ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss 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 fs eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred))
        where
-         new_name = mkSysTvName uniq FSLIT("co")
+         new_name = mkSysTvName uniq fs
 
-    co_bndrs               = zipWith mk_co_var co_uniqs eq_preds
+    co_bndrs = zipWith3 mk_co_var co_uniqs co_fss 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 fs ty = mkUserLocal (mkVarOccFS fs) uniq (inst_subst ty) noSrcLoc
+    id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 -- Returns (Just (dc, [x1..xn])) if the argument expression is 
@@ -1133,11 +1149,11 @@ 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)
-                    (uniq:us2) = us
-
+                    (uniq:us2) = us 
        ; Nothing ->
   
        case splitFunTy_maybe ty of {