[project @ 2003-02-21 14:52:54 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 b868c2a..20bc33a 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -5,7 +5,7 @@ module Generics ( mkTyConGenInfo, mkGenericRhs,
 
 
 import RnHsSyn         ( RenamedHsExpr )
-import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
+import HsSyn           ( HsExpr(..), Pat(..), mkSimpleMatch, placeHolderType )
 
 import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
                          mkTyVarTys, mkForAllTys, mkTyConApp, 
@@ -16,7 +16,7 @@ import TcType         ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
 import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon )
 
 import TyCon            ( TyCon, tyConTyVars, tyConDataCons_maybe, 
-                         tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
+                         tyConGenInfo, isNewTyCon, isBoxedTupleTyCon
                        )
 import Name            ( Name, mkSystemName )
 import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), 
@@ -25,17 +25,17 @@ import CoreUtils    ( exprArity )
 import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
 import VarSet          ( varSetElems )
-import Id               ( Id, mkVanillaGlobal, idType, idName, mkSysLocal )
+import Id               ( Id, mkGlobalId, idType, idName, mkSysLocal )
 import MkId            ( mkReboxingAlt, mkNewTypeBody )
 import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )
-import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
+import IdInfo           ( GlobalIdDetails(..), noCafIdInfo, setUnfoldingInfo, setArityInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 
 import Maybe           ( isNothing )
-import SrcLoc          ( builtinSrcLoc )
+import SrcLoc          ( noSrcLoc )
 import Unique          ( Unique, builtinUniques, mkBuiltinUnique )
 import Util             ( takeList, dropList )
 import Outputable 
@@ -82,7 +82,8 @@ patterns (not Unit, this is done differently) is done in mk_inst_info
 HsOpTy is tied to Generic definitions which is not a very good design
 feature, indeed a bug. However, the check is easy to move from
 tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5.
+bug #5. [I don't think that this is the case anymore after SPJ's latest
+changes in that regard.  Delete this comment?  -=chak/7Jun2]
 
 Generics.lhs
 
@@ -260,9 +261,11 @@ mkTyConGenInfo tycon [from_name, to_name]
 
   | otherwise
   = ASSERT( not (null datacons) )      -- mk_sum_stuff loops if no datacons
-    Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
-              toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })
+    Just (EP { fromEP = mk_id from_name from_ty from_id_info,
+              toEP   = mk_id to_name   to_ty   to_id_info })
   where
+    mk_id = mkGlobalId (GenericOpId tycon)
+
     maybe_datacons = tyConDataCons_maybe tycon
     Just datacons  = maybe_datacons            -- [C, D]
 
@@ -270,9 +273,9 @@ mkTyConGenInfo tycon [from_name, to_name]
     tycon_ty      = mkTyConApp tycon tyvar_tys -- T a b c
     tyvar_tys      = mkTyVarTys tyvars
 
-    from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+    from_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
                                      `setArityInfo`     exprArity from_fn
-    to_id_info   = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+    to_id_info   = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
                                      `setArityInfo`     exprArity to_fn
        -- It's important to set the arity info, so that
        -- the calling convention (gotten from arity) 
@@ -283,9 +286,9 @@ mkTyConGenInfo tycon [from_name, to_name]
 
     (from_fn, to_fn, rep_ty) 
        | isNewTyCon tycon
-       = ( mkLams tyvars $ Lam x  $ mkNewTypeBody tycon newrep_ty (Var x),
+       = ( mkLams tyvars $ Lam x  $ mkNewTypeBody tycon the_arg_ty (Var x),
            Var (dataConWrapId the_datacon),
-           newrep_ty )
+           the_arg_ty )
 
        | otherwise
        = ( mkLams tyvars $ Lam x     $ Case (Var x) x from_alts,
@@ -299,8 +302,12 @@ mkTyConGenInfo tycon [from_name, to_name]
            ----------------------
            --  Newtypes only
     [the_datacon]  = datacons
-    (_, newrep_ty) = newTyConRep tycon
-       
+    the_arg_ty    = head (dataConOrigArgTys the_datacon)
+               -- NB: we use the arg type of the data constructor, rather than
+               --     the representation type of the newtype; in degnerate (recursive)
+               --     cases the rep type might be (), but the arg type is still T:
+               --              newtype T = MkT T
+
            ----------------------
            --  Non-newtypes only
     -- Recurse over the sum first
@@ -536,8 +543,8 @@ bimapApp env (Just (tycon, ty_args))
 -------------------
 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
 bimapArrow [ep1, ep2]
-  = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, 
-        toEP   = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
+  = EP { fromEP = mk_hs_lam [VarPat g1, VarPat g2] from_body, 
+        toEP   = mk_hs_lam [VarPat g1, VarPat g2] to_body }
   where
     from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP   ep1 `HsApp` HsVar g2))
     to_body   = toEP   ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
@@ -548,7 +555,7 @@ bimapTuple eps
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where
     names      = takeList eps genericNames
-    tuple_pat  = TuplePatIn (map VarPatIn names) Boxed
+    tuple_pat  = TuplePat (map VarPat names) Boxed
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
     from_body   = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
@@ -558,10 +565,10 @@ genericNames :: [Name]
 genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]
 (g1:g2:g3:_) = genericNames
 
-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType noSrcLoc))
 
 idEP :: EP RenamedHsExpr
 idEP = EP idexpr idexpr
      where
-       idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)
+       idexpr = mk_hs_lam [VarPat g3] (HsVar g3)
 \end{code}