[project @ 1999-01-14 17:58:41 by sof]

[ghc-hetmet.git] / ghc / compiler / basicTypes / MkId.lhs

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index cd0ec9b..669be86 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -20,6 +20,7 @@ module MkId (
 
        mkDataConId,
        mkRecordSelId,
+       mkNewTySelId,
        mkPrimitiveId
     ) where
 
@@ -242,6 +243,40 @@ mkRecordSelId field_label selector_ty
 
 %************************************************************************
 %*                                                                     *
+\subsection{Newtype field selectors}
+%*                                                                     *
+%************************************************************************
+
+Possibly overkill to do it this way:
+
+\begin{code}
+mkNewTySelId field_label selector_ty = sel_id
+  where
+    sel_id = mkId (fieldLabelName field_label) selector_ty
+                 (RecordSelId field_label) info
+
+    info = exactArity 1        `setArityInfo` (
+          unfolding    `setUnfoldingInfo`
+          noIdInfo)
+       -- ToDo: consider adding further IdInfo
+
+    unfolding = mkUnfolding sel_rhs
+
+    (tyvars, theta, tau)  = splitSigmaTy selector_ty
+    (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
+                                       -- tau is of form (T a b c -> field-type)
+    (tycon, _, data_cons) = splitAlgTyConApp data_ty
+    tyvar_tys            = mkTyVarTys tyvars
+       
+    [data_id] = mkTemplateLocals [data_ty]
+    sel_rhs   = mkLams tyvars $ Lam data_id $
+               Note (Coerce rhs_ty data_ty) (Var data_id)
+
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
 \subsection{Dictionary selectors}
 %*                                                                     *
 %************************************************************************