+tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
+ -> LTyClDecl Name -> TcM TyThing
+
+tcTyClDecl calc_vrcs calc_isrec decl
+ = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec (unLoc decl))
+
+tcTyClDecl1 calc_vrcs calc_isrec
+ (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { rhs_ty' <- tcHsKindedType rhs_ty
+ ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) }
+ where
+ arg_vrcs = calc_vrcs tc_name
+
+tcTyClDecl1 calc_vrcs calc_isrec
+ (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
+ tcdLName = L _ tc_name, tcdCons = cons})
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { ctxt' <- tcHsKindedContext ctxt
+ ; want_generic <- doptM Opt_Generics
+ ; tycon <- fixM (\ tycon -> do
+ { cons' <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons
+ ; buildAlgTyCon new_or_data tc_name tvs' ctxt'
+ (DataCons cons') arg_vrcs is_rec
+ (want_generic && canDoGenerics cons')
+ })
+ ; return (ATyCon tycon)
+ }
+ where
+ arg_vrcs = calc_vrcs tc_name
+ is_rec = calc_isrec tc_name
+
+tcTyClDecl1 calc_vrcs calc_isrec
+ (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
+ tcdCtxt = ctxt, tcdMeths = meths,
+ tcdFDs = fundeps, tcdSigs = sigs} )
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { ctxt' <- tcHsKindedContext ctxt
+ ; fds' <- mappM (addLocM tc_fundep) fundeps
+ ; sig_stuff <- tcClassSigs class_name sigs meths
+ ; clas <- fixM (\ clas ->
+ let -- This little knot is just so we can get
+ -- hold of the name of the class TyCon, which we
+ -- need to look up its recursiveness and variance
+ tycon_name = tyConName (classTyCon clas)
+ tc_isrec = calc_isrec tycon_name
+ tc_vrcs = calc_vrcs tycon_name
+ in
+ buildClass class_name tvs' ctxt' fds'
+ sig_stuff tc_isrec tc_vrcs)
+ ; return (AClass clas) }
+ where
+ tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
+ ; tvs2' <- mappM tcLookupTyVar tvs2 ;
+ ; return (tvs1', tvs2') }
+
+
+tcTyClDecl1 calc_vrcs calc_isrec
+ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
+ = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
+
+-----------------------------------
+tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType
+ -> ConDecl Name -> TcM DataCon
+
+tcConDecl new_or_data tycon tyvars ctxt
+ (ConDecl name ex_tvs ex_ctxt details)
+ = tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do
+ { ex_ctxt' <- tcHsKindedContext ex_ctxt
+ ; unbox_strict <- doptM Opt_UnboxStrictFields
+ ; let
+ tc_datacon field_lbls btys
+ = do { let { ubtys = map unLoc btys }
+ ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys
+ ; buildDataCon (unLoc name)
+ (argStrictness unbox_strict tycon ubtys arg_tys)
+ (map unLoc field_lbls)
+ tyvars ctxt ex_tvs' ex_ctxt'
+ arg_tys tycon }
+ ; case details of
+ PrefixCon btys -> tc_datacon [] btys
+ InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2]
+ RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name)
+ ; let { (field_names, btys) = unzip fields }
+ ; tc_datacon field_names btys } }
+
+argStrictness :: Bool -- True <=> -funbox-strict_fields
+ -> TyCon -> [BangType Name]
+ -> [TcType] -> [StrictnessMark]
+argStrictness unbox_strict tycon btys arg_tys
+ = zipWith (chooseBoxingStrategy unbox_strict tycon)
+ arg_tys
+ (map getBangStrictness btys ++ repeat HsNoBang)
+
+-- We attempt to unbox/unpack a strict field when either:
+-- (i) The field is marked '!!', or
+-- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
+
+chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
+chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
+ = case bang of
+ HsNoBang -> NotMarkedStrict
+ HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
+ HsUnbox | can_unbox -> MarkedUnboxed
+ other -> MarkedStrict