X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=8c1b9da7e758d780305c0ad3a6aa3bc5b130aead;hb=136d634590dfed8008c084e2418e7c1663924829;hp=5efdb208f0bcb88bc08c70349cdca200efb86669;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 5efdb20..8c1b9da 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -4,55 +4,38 @@
 \section[TcTyDecls]{Typecheck type declarations}
 
 \begin{code}
-module TcTyDecls (
-	tcTyDecl1, 
-	kcConDetails, 
-	mkImplicitDataBinds, mkNewTyConRep
-    ) where
+module TcTyDecls ( tcTyDecl, kcConDetails, tcMkDataCon ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( MonoBinds(..), 
-			  TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
-			  andMonoBindList, getBangType
+import HsSyn		( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType,
+			  getBangType, getBangStrictness, conDetailsTys
 			)
 import RnHsSyn		( RenamedTyClDecl, RenamedConDecl, RenamedContext )
-import TcHsSyn		( TcMonoBinds, idsToMonoBinds )
-import BasicTypes	( RecFlag(..), NewOrData(..) )
+import BasicTypes	( NewOrData(..), StrictnessMark )
 
-import TcMonoType	( tcHsSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext,
-			  kcHsContext, kcHsSigType
+import TcMonoType	( tcHsTyVars, tcHsTheta, tcHsType, 
+			  kcHsContext, kcHsSigType, kcHsLiftedSigType
 			)
-import TcEnv		( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) )
-import TcMonad
-import TcUnify		( unifyKind )
-
-import Class		( Class, ClassContext )
-import DataCon		( DataCon, mkDataCon, 
-			  dataConFieldLabels, dataConId, dataConWrapId,
-			  markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
-			)
-import MkId		( mkDataConId, mkDataConWrapId, mkRecordSelId )
-import FieldLabel
-import Var		( Id, TyVar )
-import Name		( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
+import TcEnv		( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) )
+import TcType		( Type, tyVarsOfTypes, tyVarsOfPred, ThetaType )
+import RnEnv		( lookupSysName )
+import TcRnMonad
+
+import DataCon		( DataCon, mkDataCon, dataConFieldLabels )
+import FieldLabel	( FieldLabel, fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel )
+import MkId		( mkDataConWorkId, mkDataConWrapId, mkRecordSelId )
+import Var		( TyVar )
+import Name		( Name )
+import OccName		( mkDataConWrapperOcc, mkDataConWorkerOcc,
+			  mkGenOcc1, mkGenOcc2, setOccNameSpace )
 import Outputable
-import TyCon		( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, 
-			  tyConDataConsIfAvailable, tyConTyVars,
-			  isSynTyCon, isNewTyCon
-			)
-import Type		( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
-			  mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
-			  mkTyVarTy, splitAlgTyConApp_maybe,
-			  mkArrowKind, mkArrowKinds, boxedTypeKind,
-			  isUnboxedType, Type, ThetaType, classesOfPreds
-			)
-import TysWiredIn	( unitTy )
-import Var		( tyVarKind )
+import TyCon		( TyCon, DataConDetails(..), visibleDataCons,
+			  tyConTyVars, tyConName )
 import VarSet		( intersectVarSet, isEmptyVarSet )
-import Unique		( unpackCStringIdKey )
-import Util		( equivClasses )
-import FiniteMap        ( FiniteMap, lookupWithDefaultFM )
+import Generics		( mkTyConGenInfo )
+import CmdLineOpts	( DynFlag(..) )
+import List		( nubBy )
 \end{code}
 
 %************************************************************************
@@ -62,57 +45,56 @@ import FiniteMap        ( FiniteMap, lookupWithDefaultFM )
 %************************************************************************
 
 \begin{code}
-tcTyDecl1 :: RenamedTyClDecl -> TcM s (Name, TyThingDetails)
-tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc)
-  = tcLookupTy tycon_name			`thenNF_Tc` \ (ATyCon tycon) ->
+tcTyDecl :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcTyDecl (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
+  = tcLookupTyCon tycon_name			`thenM` \ tycon ->
     tcExtendTyVarEnv (tyConTyVars tycon)	$
-    tcHsSigType 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 now do that here without falling into
-	-- a black hole, we still do it in rnDecl (TySynonym case)
-    returnTc (tycon_name, SynTyDetails rhs_ty)
+    tcHsType rhs				`thenM` \ rhs_ty ->
+    returnM (tycon_name, SynTyDetails rhs_ty)
 
-tcTyDecl1 (TyData _ context tycon_name _ con_decls _ derivings _  src_loc)
-  = tcLookupTy tycon_name			`thenNF_Tc` \ (ATyCon tycon) ->
+tcTyDecl (TyData {tcdND = new_or_data, tcdCtxt = context,
+		  tcdName = tycon_name, tcdCons = con_decls,
+		  tcdGeneric = generic})
+  = tcLookupTyCon tycon_name			`thenM` \ tycon ->
     let
 	tyvars = tyConTyVars tycon
     in
     tcExtendTyVarEnv tyvars				$
+    tcHsTheta context					`thenM` \ ctxt ->
+    tcConDecls new_or_data tycon tyvars ctxt con_decls	`thenM` \ data_cons ->
+    let
+	sel_ids = mkRecordSelectors tycon data_cons
+    in
+    tcGenericInfo tycon generic				`thenM` \ gen_info ->
+    returnM (tycon_name, DataTyDetails ctxt data_cons sel_ids gen_info)
 
-	-- Typecheck the pieces
-    tcClassContext context				`thenTc` \ ctxt ->
-    tc_derivs derivings					`thenTc` \ derived_classes ->
-    mapTc (tcConDecl tycon tyvars ctxt) con_decls	`thenTc` \ data_cons ->
-
-    returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes)
-  where
-    tc_derivs Nothing   = returnTc []
-    tc_derivs (Just ds) = mapTc tc_deriv ds
-
-    tc_deriv name = tcLookupTy name `thenTc` \ (AClass clas) ->
-		    returnTc clas
-\end{code}
+tcTyDecl (ForeignType {tcdName = tycon_name})
+  = returnM (tycon_name, ForeignTyDetails)
 
-\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)))
+tcGenericInfo tycon generics	-- Source code decl: consult the flag
+  = do_we_want	generics	`thenM` \ want_generics ->
+    if want_generics then
+	mapM (lookupSysName (tyConName tycon))
+	     [mkGenOcc1, mkGenOcc2]		`thenM` \ gen_sys_names ->
+	returnM (mkTyConGenInfo tycon gen_sys_names)
+    else
+	returnM Nothing
   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
-		  }
+    do_we_want (Just g) = returnM g		-- Interface file decl
+						-- so look at decl
+    do_we_want Nothing  = doptM Opt_Generics	-- Source code decl
+						-- so look at flag
+
+mkRecordSelectors tycon data_cons
+  = 	-- We'll check later that fields with the same name 
+	-- from different constructors have the same type.
+     [ mkRecordSelId tycon field 
+     | field <- nubBy eq_name fields ]
+  where
+    fields = [ field | con <- visibleDataCons data_cons, 
+		       field <- dataConFieldLabels con ]
+    eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
 \end{code}
 
 
@@ -123,82 +105,90 @@ mkNewTyConRep tc
 %************************************************************************
 
 \begin{code}
-kcConDetails :: RenamedContext -> ConDetails Name -> TcM s ()
-kcConDetails ex_ctxt details
-  = kcHsContext ex_ctxt		`thenTc_`
-    kc_con_details details
+kcConDetails :: NewOrData -> RenamedContext 
+	     -> HsConDetails Name (BangType Name) -> TcM ()
+kcConDetails new_or_data ex_ctxt details
+  = kcHsContext ex_ctxt		`thenM_`
+    mappM_ kc_sig_type (conDetailsTys details)
   where
-    kc_con_details (VanillaCon btys)    = mapTc_ kc_bty btys
-    kc_con_details (InfixCon bty1 bty2) = mapTc_ kc_bty [bty1,bty2]
-    kc_con_details (NewCon ty _)        = kcHsSigType ty
-    kc_con_details (RecCon flds)        = mapTc_ kc_field flds
-
-    kc_field (_, bty) = kc_bty bty
-
-    kc_bty bty = kcHsSigType (getBangType bty)
-
-tcConDecl :: TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon
-
-tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
-  = tcAddSrcLoc src_loc					$
-    kcTyVarScope ex_tvs (kcConDetails ex_ctxt details)	`thenTc` \ ex_tyvars -> 
-    tcExtendTyVarEnv ex_tyvars				$
-    tcClassContext ex_ctxt				`thenTc` \ ex_theta ->
-    case details of
-	VanillaCon btys    -> tc_datacon ex_tyvars ex_theta btys
-	InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
-	NewCon ty mb_f	   -> tc_newcon  ex_tyvars ex_theta ty mb_f
-	RecCon fields	   -> tc_rec_con ex_tyvars ex_theta fields
+    kc_sig_type = case new_or_data of
+		    DataType -> kcHsSigType
+		    NewType  -> kcHsLiftedSigType
+	    -- Can't allow an unlifted type here, because we're effectively
+	    -- going to remove the constructor while coercing it to a lifted type.
+
+
+tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType 
+	   -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon)
+
+tcConDecls new_or_data tycon tyvars ctxt con_decls
+  = case con_decls of
+	Unknown     -> returnM Unknown
+	HasCons n   -> returnM (HasCons n)
+	DataCons cs -> mappM tc_con_decl cs	`thenM` \ data_cons ->
+		       returnM (DataCons data_cons)
   where
-    tc_datacon ex_tyvars ex_theta btys
-      = let
-	    arg_stricts = map getBangStrictness btys
-	    tys	        = map getBangType btys
-        in
-	mapTc tcHsSigType tys 	`thenTc` \ arg_tys ->
-	mk_data_con ex_tyvars ex_theta arg_stricts arg_tys []
-
-    tc_newcon ex_tyvars ex_theta ty mb_f
-      = tcHsBoxedSigType ty	`thenTc` \ arg_ty ->
-	    -- can't allow an unboxed type here, because we're effectively
-	    -- going to remove the constructor while coercing it to a boxed type.
-	let
-	  field_label =
-	    case mb_f of
-	      Nothing -> []
-	      Just f  -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)]
-        in	      
-	mk_data_con ex_tyvars ex_theta [notMarkedStrict] [arg_ty] field_label
-
-    tc_rec_con ex_tyvars ex_theta fields
-      = checkTc (null ex_tyvars) (exRecConErr name)	`thenTc_`
-	mapTc tc_field (fields `zip` allFieldLabelTags)	`thenTc` \ field_labels_s ->
-	let
-	    field_labels = concat field_labels_s
-	    arg_stricts = [str | (ns, bty) <- fields, 
-				  let str = getBangStrictness bty, 
-				  n <- ns		-- One for each.  E.g   x,y,z :: !Int
-			  ]
-	in
-	mk_data_con ex_tyvars ex_theta arg_stricts 
-		    (map fieldLabelType field_labels) field_labels
-
-    tc_field ((field_label_names, bty), tag)
-      = tcHsSigType (getBangType bty)	`thenTc` \ field_ty ->
-	returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
-
-    mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
-      = let
-	   data_con = mkDataCon name arg_stricts fields
-		      	   tyvars (thinContext arg_tys ctxt)
-			   ex_tyvars ex_theta
-		      	   arg_tys
-		      	   tycon data_con_id data_con_wrap_id
-
-	   data_con_id      = mkDataConId wkr_name data_con
-	   data_con_wrap_id = mkDataConWrapId data_con
-	in
-	returnNF_Tc data_con
+    tc_con_decl (ConDecl name ex_tvs ex_ctxt details src_loc)
+      = addSrcLoc src_loc						$
+	tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details)	$ \ ex_tyvars ->
+	tcHsTheta ex_ctxt						`thenM` \ ex_theta ->
+	case details of
+	    PrefixCon btys     -> tc_datacon ex_tyvars ex_theta btys
+	    InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
+	    RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
+      where
+	
+	tc_datacon ex_tyvars ex_theta btys
+	  = mappM tcHsType (map getBangType btys)	`thenM` \ arg_tys ->
+	    tcMkDataCon name 
+			(map getBangStrictness btys)
+			[{- No field labels -}] 
+			tyvars ctxt ex_tyvars ex_theta 
+			arg_tys tycon
+    
+	tc_rec_con ex_tyvars ex_theta fields
+	  = checkTc (null ex_tyvars) (exRecConErr name)		`thenM_`
+	    mappM tc_field (fields `zip` allFieldLabelTags)	`thenM` \ field_labels ->
+	    let
+		arg_stricts = [getBangStrictness bty | (n, bty) <- fields] 
+		arg_tys     = map fieldLabelType field_labels
+	    in
+	    tcMkDataCon name arg_stricts field_labels
+			tyvars ctxt ex_tyvars ex_theta 
+			arg_tys tycon
+    
+	tc_field ((field_label_name, bty), tag)
+	  = tcHsType (getBangType bty)		`thenM` \ field_ty ->
+	    returnM (mkFieldLabel field_label_name tycon field_ty tag)
+    
+tcMkDataCon :: Name
+	    -> [StrictnessMark] -> [FieldLabel]
+	    -> [TyVar] -> ThetaType
+	    -> [TyVar] -> ThetaType
+	    -> [Type] -> TyCon
+	    -> TcM DataCon
+-- A wrapper for DataCon.mkDataCon that
+--   a) makes the worker Id
+--   b) makes the wrapper Id if necessary, including
+--	allocating its unique (hence monadic)
+tcMkDataCon src_name arg_stricts fields 
+	    tyvars ctxt ex_tyvars ex_theta 
+	    arg_tys tycon
+  = lookupSysName src_name mkDataConWrapperOcc	`thenM` \ wrap_name ->
+    lookupSysName src_name mkDataConWorkerOcc 	`thenM` \ work_name -> 
+	-- This last one takes the name of the data constructor in the source
+	-- code, which (for Haskell source anyway) will be in the SrcDataName name
+	-- space, and makes it into a "real data constructor name"
+    let
+	data_con = mkDataCon src_name arg_stricts fields
+			     tyvars (thinContext arg_tys ctxt) 
+			     ex_tyvars ex_theta
+			     arg_tys tycon 
+			     data_con_work_id data_con_wrap_id
+	data_con_work_id = mkDataConWorkId work_name data_con
+	data_con_wrap_id = mkDataConWrapId wrap_name data_con
+    in
+    returnM data_con	
 
 -- The context for a data constructor should be limited to
 -- the type variables mentioned in the arg_tys
@@ -206,85 +196,19 @@ thinContext arg_tys ctxt
   = filter in_arg_tys ctxt
   where
       arg_tyvars = tyVarsOfTypes arg_tys
-      in_arg_tys (clas,tys) = not $ isEmptyVarSet $ 
-			      tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-
-getBangStrictness (Banged   _) = markedStrict
-getBangStrictness (Unbanged _) = notMarkedStrict
-getBangStrictness (Unpacked _) = markedUnboxed
+      in_arg_tys pred = not $ isEmptyVarSet $ 
+			tyVarsOfPred pred `intersectVarSet` arg_tyvars
 \end{code}
 
 
-
 %************************************************************************
 %*									*
-\subsection{Generating constructor/selector bindings for data declarations}
+\subsection{Errors and contexts}
 %*									*
 %************************************************************************
 
-\begin{code}
-mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
-mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds)
-mkImplicitDataBinds (tycon : tycons) 
-  | isSynTyCon tycon = mkImplicitDataBinds tycons
-  | otherwise	     = mkImplicitDataBinds_one tycon	`thenTc` \ (ids1, b1) ->
-		       mkImplicitDataBinds tycons	`thenTc` \ (ids2, b2) ->
-		       returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
-
-mkImplicitDataBinds_one tycon
-  = mapTc (mkRecordSelector tycon) groups	`thenTc` \ sel_ids ->
-    let
-	unf_ids = sel_ids ++ data_con_wrapper_ids
-	all_ids = map dataConId data_cons ++ unf_ids 
-
-	-- For the locally-defined things
-	-- we need to turn the unfoldings inside the selector Ids into bindings,
-	-- and build bindigns for the constructor wrappers
-	binds | isLocallyDefined tycon = idsToMonoBinds unf_ids
-	      | otherwise	       = EmptyMonoBinds
-    in	
-    returnTc (all_ids, binds)
-  where
-    data_cons = tyConDataConsIfAvailable tycon
-	-- Abstract types mean we don't bring the 
-	-- data cons into scope, which should be fine
-
-    data_con_wrapper_ids = map dataConWrapId data_cons
-
-    fields = [ (con, field) | con   <- data_cons,
-			      field <- dataConFieldLabels con
-	     ]
-
-	-- groups is list of fields that share a common name
-    groups = equivClasses cmp_name fields
-    cmp_name (_, field1) (_, field2) 
-	= fieldLabelName field1 `compare` fieldLabelName field2
-\end{code}
-
-\begin{code}
-mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
-		-- These fields all have the same name, but are from
-		-- different constructors in the data type
-	-- Check that all the fields in the group have the same type
-	-- This check assumes that all the constructors of a given
-	-- data type use the same type variables
-  = checkTc (all (== field_ty) other_tys)
-	    (fieldTypeMisMatch field_name)	`thenTc_`
-    tcLookupValueByKey unpackCStringIdKey	`thenTc` \ unpack_id ->
-    returnTc (mkRecordSelId tycon first_field_label unpack_id)
-  where
-    field_ty   = fieldLabelType first_field_label
-    field_name = fieldLabelName first_field_label
-    other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
-\end{code}
 
-
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
 \begin{code}
-fieldTypeMisMatch field_name
-  = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
-
 exRecConErr name
   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
     $$