[project @ 2000-05-23 13:16:51 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcTyDecls.lhs

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 78c6f32..450dad9 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -7,7 +7,7 @@
 module TcTyDecls (
        tcTyDecl, kcTyDecl, 
        tcConDecl,
-       mkImplicitDataBinds
+       mkImplicitDataBinds, mkNewTyConRep
     ) where
 
 #include "HsVersions.h"
@@ -21,7 +21,7 @@ import TcHsSyn                ( TcMonoBinds, idsToMonoBinds )
 import BasicTypes      ( RecFlag(..), NewOrData(..) )
 
 import TcMonoType      ( tcExtendTopTyVarScope, tcExtendTyVarScope, 
-                         tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
+                         tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType,
                          tcContext, tcHsTopTypeKind
                        )
 import TcType          ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
@@ -30,30 +30,31 @@ import TcMonad
 import TcUnify         ( unifyKind )
 
 import Class           ( Class )
-import DataCon         ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
+import DataCon         ( DataCon, mkDataCon, isNullaryDataCon,
                          dataConFieldLabels, dataConId, dataConWrapId,
-                         markedStrict, notMarkedStrict, markedUnboxed
+                         markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
                        )
 import MkId            ( mkDataConId, mkDataConWrapId, mkRecordSelId )
-import Id              ( idUnfolding )
-import CoreUnfold      ( unfoldingTemplate )
 import FieldLabel
 import Var             ( Id, TyVar )
 import Name            ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
 import Outputable
-import TyCon           ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, 
-                         isSynTyCon, tyConDataCons, isNewTyCon
+import TyCon           ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, 
+                         tyConDataCons, tyConTyVars,
+                         isSynTyCon, isNewTyCon
                        )
-import Type            ( getTyVar, tyVarsOfTypes,
+import Type            ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
                          mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
-                         mkTyVarTy,
+                         mkTyVarTy, splitAlgTyConApp_maybe,
                          mkArrowKind, mkArrowKinds, boxedTypeKind,
                          isUnboxedType, Type, ThetaType, classesOfPreds
                        )
+import TysWiredIn      ( unitTy )
 import Var             ( tyVarKind )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import Util            ( equivClasses )
 import FiniteMap        ( FiniteMap, lookupWithDefaultFM )
+import CmdLineOpts     ( opt_GlasgowExts )
 \end{code}
 
 %************************************************************************
@@ -88,12 +89,12 @@ kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc)
   where
     kc_con (VanillaCon btys)    = mapTc kc_bty btys            `thenTc_` returnTc ()
     kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2]     `thenTc_` returnTc ()
-    kc_con (NewCon ty _)        = tcHsType ty                  `thenTc_` returnTc ()
+    kc_con (NewCon ty _)        = kcHsType ty
     kc_con (RecCon flds)        = mapTc kc_field flds          `thenTc_` returnTc ()
 
-    kc_bty (Banged ty)   = tcHsType ty
-    kc_bty (Unbanged ty) = tcHsType ty
-    kc_bty (Unpacked ty) = tcHsType ty
+    kc_bty (Banged ty)   = kcHsType ty
+    kc_bty (Unbanged ty) = kcHsType ty
+    kc_bty (Unpacked ty) = kcHsType ty
 
     kc_field (_, bty)    = kc_bty bty
 \end{code}
@@ -112,6 +113,10 @@ tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
   = tcLookupTy tycon_name                              `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
     tcExtendTopTyVarScope tycon_kind tyvar_names       $ \ tyvars _ ->
     tcHsTopTypeKind rhs                                        `thenTc` \ (_, rhs_ty) ->
+       -- If the RHS mentions tyvars that aren't in scope, we'll 
+       -- quantify over them.  With gla-exts that's right, but for H98
+       -- we should complain. We can't do that here without falling into
+       -- a black hole, so we do it in rnDecl (TySynonym case)
     let
        -- Construct the tycon
         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
@@ -134,10 +139,10 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_
 
     let
        -- Construct the tycon
-       real_data_or_new = case data_or_new of
-                               NewType -> NewType
-                               DataType | all isNullaryDataCon data_cons -> EnumType
-                                        | otherwise                      -> DataType
+       flavour = case data_or_new of
+                       NewType -> NewTyCon (mkNewTyConRep tycon)
+                       DataType | all isNullaryDataCon data_cons -> EnumTyCon
+                                | otherwise                      -> DataTyCon
 
         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
                                       tycon_name
@@ -145,8 +150,7 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_
        tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
                           data_cons
                           derived_classes
-                          Nothing              -- Not a dictionary
-                          real_data_or_new is_rec
+                          flavour is_rec
     in
     returnTc tycon
   where
@@ -157,6 +161,27 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_
                        returnTc clas
 \end{code}
 
+\begin{code}
+mkNewTyConRep :: TyCon -> Type
+-- Find the representation type for this newtype TyCon
+-- The trick is to to deal correctly with recursive newtypes
+-- such as     newtype T = MkT T
+
+mkNewTyConRep tc
+  = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs)))
+  where
+    tvs = tyConTyVars tc
+    loop tcs ty = case splitAlgTyConApp_maybe ty of {
+                       Nothing -> ty ;
+                       Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty
+                                                 | tc `elem` tcs       -> unitTy
+                                                 | otherwise           ->
+
+                 case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of
+                       (rep_ty, _) -> loop (tc:tcs) rep_ty
+                 }
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
@@ -199,7 +224,7 @@ tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details
          field_label =
            case mb_f of
              Nothing -> []
-             Just f  -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)]
+             Just f  -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)]
         in           
        mk_data_con [notMarkedStrict] [arg_ty] field_label
 
@@ -211,7 +236,7 @@ tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details
            arg_stricts       = [strict | (_, _, strict) <- field_label_infos]
            arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 
-           field_labels      = [ mkFieldLabel (getName name) ty tag 
+           field_labels      = [ mkFieldLabel (getName name) tycon ty tag 
                              | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
        in
        mk_data_con arg_stricts arg_tys field_labels