import RnHsSyn ( RenamedHsExpr )
-import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
+import HsSyn ( HsExpr(..), Pat(..), mkSimpleMatch, placeHolderType )
import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
mkTyVarTys, mkForAllTys, mkTyConApp,
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(..),
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
+import FastString
#include "HsVersions.h"
\end{code}
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
| dc <- datacons ]
= Nothing
+ | null datacons -- There are no constructors;
+ = Nothing -- there are no values of this type
+
| otherwise
- = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
- toEP = mkVanillaGlobal to_name to_ty to_id_info })
+ = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons
+ 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]
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)
(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,
----------------------
-- 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
-------------------
-- 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))
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
-------------------
genericNames :: [Name]
-genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
+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}