- tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
- data_cons sel_ids
- flavour is_rec gen_info
- -- It's not strictly necesary to mark newtypes as
- -- recursive if the loop is broken via a data type.
- -- But I'm not sure it's worth the hassle of discovering that.
-
- gen_info | not (dopt Opt_Generics dflags) = Nothing
- | otherwise = mkTyConGenInfo tycon sys_names
-
- DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
-
- tycon_kind = lookupNameEnv_NF kenv tycon_name
- tyvars = mkTyClTyVars tycon_kind tyvar_names
- argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
-
- -- Watch out! mkTyConApp asks whether the tycon is a NewType,
- -- so flavour has to be able to answer this question without consulting rec_details
- flavour = case data_or_new of
- NewType -> NewTyCon (mkNewTyConRep tycon)
- DataType | all_nullary data_cons -> EnumTyCon
- | otherwise -> DataTyCon
-
- all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
- all_nullary other = False -- Safe choice for unknown data types
- -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
- -- but that looks at the *representation* arity, and that in turn
- -- depends on deciding whether to unpack the args, and that
- -- depends on whether it's a data type or a newtype --- so
- -- in the recursive case we can get a loop. This version is simple!
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
- = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
-
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
- tcdFDs = fundeps, tcdSysNames = name_list} )
- = AClass clas
+ 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 :: Bool -- True <=> -funbox-strict_fields
+ -> NewOrData -> TyCon -> [TyVar]
+ -> ConDecl Name -> TcM DataCon
+
+tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes
+ (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
+ = do { let tc_datacon field_lbls arg_ty
+ = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
+ ; buildDataCon (unLoc name) False {- Prefix -}
+ True {- Vanilla -} [NotMarkedStrict]
+ (map unLoc field_lbls)
+ tc_tvs [] [arg_ty']
+ tycon (mkTyVarTys tc_tvs) }
+
+ -- Check that a newtype has no existential stuff
+ ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
+
+ ; case details of
+ PrefixCon [arg_ty] -> tc_datacon [] arg_ty
+ RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
+ other -> failWithTc (newtypeFieldErr name (length (hsConArgs details)))
+ -- Check that the constructor has exactly one field
+ }
+
+tcConDecl unbox_strict DataType tycon tc_tvs -- Data types
+ (ConDecl name _ tvs ctxt details res_ty)
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { ctxt' <- tcHsKindedContext ctxt
+ ; (data_tc, res_ty_args) <- tcResultType tycon tc_tvs res_ty
+ ; let
+ con_tvs = case res_ty of
+ ResTyH98 -> tc_tvs ++ tvs'
+ ResTyGADT _ -> tryVanilla tvs' res_ty_args
+
+ -- Vanilla iff result type matches the quantified vars exactly,
+ -- and there is no existential context
+ -- Must check the context too because of implicit params; e.g.
+ -- data T = (?x::Int) => MkT Int
+ is_vanilla = res_ty_args `tcEqTypes` mkTyVarTys con_tvs
+ && null (unLoc ctxt)
+
+ tc_datacon is_infix field_lbls btys
+ = do { let bangs = map getBangStrictness btys
+ ; arg_tys <- mappM tcHsBangType btys
+ ; buildDataCon (unLoc name) is_infix is_vanilla
+ (argStrictness unbox_strict tycon bangs arg_tys)
+ (map unLoc field_lbls)
+ con_tvs ctxt' arg_tys
+ data_tc res_ty_args }
+ -- NB: we put data_tc, the type constructor gotten from the constructor
+ -- type signature into the data constructor; that way
+ -- checkValidDataCon can complain if it's wrong.
+
+ ; case details of
+ PrefixCon btys -> tc_datacon False [] btys
+ InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
+ RecCon fields -> tc_datacon False field_names btys
+ where
+ (field_names, btys) = unzip fields
+
+ }
+
+tcResultType :: TyCon -> [TyVar] -> ResType Name -> TcM (TyCon, [TcType])
+tcResultType tycon tvs ResTyH98 = return (tycon, mkTyVarTys tvs)
+tcResultType _ _ (ResTyGADT res_ty) = tcLHsConResTy res_ty
+
+tryVanilla :: [TyVar] -> [TcType] -> [TyVar]
+-- (tryVanilla tvs tys) returns a permutation of tvs.
+-- It tries to re-order the tvs so that it exactly
+-- matches the [Type], if that is possible
+tryVanilla tvs (ty:tys) | Just tv <- tcGetTyVar_maybe ty -- The type is a tyvar
+ , tv `elem` tvs -- That tyvar is in the list
+ = tv : tryVanilla (delete tv tvs) tys
+tryVanilla tvs tys = tvs -- Fall through case
+
+
+-------------------
+argStrictness :: Bool -- True <=> -funbox-strict_fields
+ -> TyCon -> [HsBang]
+ -> [TcType] -> [StrictnessMark]
+argStrictness unbox_strict tycon bangs arg_tys
+ = ASSERT( length bangs == length arg_tys )
+ zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs
+
+-- 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