[project @ 2001-06-25 14:36:04 by simonpj]

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

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 7b65447..41a5660 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -7,36 +7,35 @@ module Generics ( mkTyConGenInfo, mkGenericRhs,
 import RnHsSyn         ( RenamedHsExpr )
 import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch )
 
-import Type             ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
+import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
                          mkTyVarTys, mkForAllTys, mkTyConApp, 
                          mkFunTy, isTyVarTy, getTyVar_maybe,
-                         splitSigmaTy, splitTyConApp_maybe, funTyCon
+                         funTyCon
                        )
-
+import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
 import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
 
 import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )
 import Name            ( Name, mkSysLocalName )
-import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
+import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), 
                          mkConApp, Alt, mkTyApps, mkVarApps )
 import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
 import VarSet          ( varSetElems )
-import Id               ( Id, mkTemplateLocal, idType, idName, 
-                         mkTemplateLocalsNum, mkId
+import Id               ( Id, mkVanillaGlobal, idType, idName, 
+                         mkTemplateLocal, mkTemplateLocalsNum
                        ) 
 import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )
-import IdInfo           ( vanillaIdInfo, setUnfoldingInfo )
+import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 
 import Unique          ( mkBuiltinUnique )
 import SrcLoc          ( builtinSrcLoc )
-import Maybes          ( expectJust )
 import Outputable 
 
 #include "HsVersions.h"
@@ -187,7 +186,7 @@ validGenericInstanceType :: Type -> Bool
   --   f {| a + Int |}
 
 validGenericInstanceType inst_ty
-  = case splitTyConApp_maybe inst_ty of
+  = case tcSplitTyConApp_maybe inst_ty of
        Just (tycon, tys) ->  all isTyVarTy tys && tycon `elem` genericTyCons
        Nothing           ->  False
 
@@ -202,12 +201,12 @@ validGenericMethodType :: Type -> Bool
 validGenericMethodType ty 
   = valid tau
   where
-    (local_tvs, _, tau) = splitSigmaTy ty
+    (local_tvs, _, tau) = tcSplitSigmaTy ty
 
     valid ty
       | isTyVarTy ty    = True
       | no_tyvars_in_ty        = True
-      | otherwise      = case splitTyConApp_maybe ty of
+      | otherwise      = case tcSplitTyConApp_maybe ty of
                                Just (tc,tys) -> valid_tycon tc && all valid tys
                                Nothing       -> False
       where
@@ -225,7 +224,7 @@ validGenericMethodType ty
 %************************************************************************
 
 \begin{code}
-mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
 -- mkTyConGenInfo is called twice
 --     once from TysWiredIn for Tuples
 --     once the typechecker TcTyDecls 
@@ -236,7 +235,7 @@ mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
 -- The two names are the names constructed by the renamer
 -- for the fromT and toT conversion functions.
 
-mkTyConGenInfo tycon from_name to_name
+mkTyConGenInfo tycon [from_name, to_name]
   | null datacons      -- Abstractly imported types don't have
   = Nothing            -- to/from operations, (and should not need them)
 
@@ -250,23 +249,23 @@ mkTyConGenInfo tycon from_name to_name
   = Nothing
 
   | otherwise
-  = Just (EP { fromEP = mkId from_name from_ty from_id_info,
-              toEP   = mkId to_name   to_ty   to_id_info })
+  = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
+              toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })
   where
     tyvars      = tyConTyVars tycon                    -- [a, b, c]
     datacons    = tyConDataConsIfAvailable tycon       -- [C, D]
     tycon_ty    = mkTyConApp tycon tyvar_tys           -- T a b c
     tyvar_tys    = mkTyVarTys tyvars
 
-    from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
-    to_id_info   = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+    from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+    to_id_info   = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
 
     from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
     to_ty   = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
 
     (from_fn, to_fn, rep_ty) 
        | isNewTyCon tycon
-       = ( mkLams tyvars $ Lam x  $ Note (Coerce newrep_ty tycon_ty) (Var x),
+       = ( mkLams tyvars $ Lam x  $ Var x,
            Var (dataConWrapId the_datacon),
            newrep_ty )
 
@@ -281,7 +280,7 @@ mkTyConGenInfo tycon from_name to_name
            ----------------------
            --  Newtypes only
     [the_datacon]  = datacons
-    newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
+    (_, newrep_ty) = newTyConRep tycon
        
            ----------------------
            --  Non-newtypes only
@@ -340,13 +339,6 @@ mk_sum_stuff i tyvars datacons
        where
          datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
 
-
--- This constructs the c_of datatype from a DataCon and a Type
--- The identity function at the moment.
-cOfConstr :: DataCon -> Type -> Type
-cOfConstr y z = z
-
-
 ----------------------------------------------------
 --     Dealing with products
 ----------------------------------------------------
@@ -470,11 +462,11 @@ mkGenericRhs sel_id tyvar tycon
 
         -- Takes out the ForAll and the Class restrictions 
         -- in front of the type of the method.
-       (_,_,op_ty) = splitSigmaTy (idType sel_id)
+       (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
 
         -- Do it again!  This deals with the case where the method type 
        -- is polymorphic -- see notes above
-       (local_tvs,_,final_ty) = splitSigmaTy op_ty
+       (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 
        -- Now we probably have a tycon in front
         -- of us, quite probably a FunTyCon.
@@ -495,7 +487,7 @@ generate_bimap env@(tv,ep,local_tvs) ty
        Just tv1 |  tv == tv1 -> ep                             -- The class tyvar
                 |  otherwise -> ASSERT( tv1 `elem` local_tvs)  -- One of the polymorphic tyvars of the method
                                 idEP   
-       Nothing  -> bimapApp env (splitTyConApp_maybe ty)
+       Nothing  -> bimapApp env (tcSplitTyConApp_maybe ty)
 
 -------------------
 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr