-mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets`
- get_cons condecls `unionUniqSets`
- get_deriv derivs))
-
-mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets`
- get_con condecl `unionUniqSets`
- get_deriv derivs))
-
-mk_edges (TyD (TySynonym name _ rhs _))
- = (uniqueOf name, set_to_bag (get_ty rhs))
-
-mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
-
-get_ctxt ctxt
- = unionManyUniqSets (map (set_name.fst) ctxt)
-
-get_deriv Nothing = emptyUniqSet
-get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
-
-get_cons cons
- = unionManyUniqSets (map get_con cons)
-
-get_con (ConDecl _ btys _)
- = unionManyUniqSets (map get_bty btys)
-get_con (ConOpDecl bty1 _ bty2 _)
- = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con (NewConDecl _ ty _)
- = get_ty ty
-get_con (RecConDecl _ nbtys _)
- = unionManyUniqSets (map (get_bty.snd) nbtys)
-
-get_bty (Banged ty) = get_ty ty
-get_bty (Unbanged ty) = get_ty ty
-
-get_ty (MonoTyVar name)
- = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
-get_ty (MonoTyApp ty1 ty2)
- = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoFunTy ty1 ty2)
- = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy tc ty)
- = set_name tc `unionUniqSets` get_ty ty
-get_ty (MonoTupleTy tc tys)
- = set_name tc `unionUniqSets` get_tys tys
-get_ty (HsForAllTy _ ctxt mty)
- = get_ctxt ctxt `unionUniqSets` get_ty mty
-get_ty other = panic "TcTyClsDecls:get_ty"
-
-get_tys tys
- = unionManyUniqSets (map get_ty tys)
-
-get_sigs sigs
- = unionManyUniqSets (map get_sig sigs)
- where
- get_sig (ClassOpSig _ _ ty _) = get_ty ty
- get_sig other = panic "TcTyClsDecls:get_sig"
-
-set_name name = unitUniqSet (uniqueOf name)
-
-set_to_bag set = listToBag (uniqSetToList set)
+tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing]
+tcSynDecls calc_vrcs [] = return []
+tcSynDecls calc_vrcs (decl : decls)
+ = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl
+ ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls)
+ ; return (syn_tc : syn_tcs) }
+
+tcSynDecl calc_vrcs
+ (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { traceTc (text "tcd1" <+> ppr tc_name)
+ ; rhs_ty' <- tcHsKindedType rhs_ty
+ ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) }
+
+--------------------
+tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
+ -> TyClDecl Name -> TcM TyThing
+
+tcTyClDecl calc_vrcs calc_isrec decl
+ = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
+
+tcTyClDecl1 calc_vrcs calc_isrec
+ (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
+ tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { extra_tvs <- tcDataKindSig mb_ksig
+ ; let final_tvs = tvs' ++ extra_tvs
+ ; stupid_theta <- tcHsKindedContext ctxt
+ ; want_generic <- doptM Opt_Generics
+ ; unbox_strict <- doptM Opt_UnboxStrictFields
+ ; gla_exts <- doptM Opt_GlasgowExts
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+
+ -- Check that we don't use GADT syntax in H98 world
+ ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
+
+ -- Check that there's at least one condecl,
+ -- or else we're reading an interface file, or -fglasgow-exts
+ ; checkTc (not (null cons) || gla_exts || is_boot)
+ (emptyConDeclsErr tc_name)
+
+ -- Check that a newtype has exactly one constructor
+ ; checkTc (new_or_data == DataType || isSingleton cons)
+ (newtypeConError tc_name (length cons))
+
+ ; tycon <- fixM (\ tycon -> do
+ { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
+ tycon final_tvs))
+ cons
+ ; let tc_rhs
+ | null cons && is_boot -- In a hs-boot file, empty cons means
+ = AbstractTyCon -- "don't know"; hence Abstract
+ | otherwise
+ = case new_or_data of
+ DataType -> mkDataTyConRhs data_cons
+ NewType -> ASSERT( isSingleton data_cons )
+ mkNewTyConRhs tycon (head data_cons)
+ ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec
+ (want_generic && canDoGenerics data_cons)
+ })
+ ; return (ATyCon tycon)
+ }
+ where
+ arg_vrcs = calc_vrcs tc_name
+ is_rec = calc_isrec tc_name
+ h98_syntax = case cons of -- All constructors have same shape
+ L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
+ other -> True
+
+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 :: 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
+ where
+ can_unbox = case splitTyConApp_maybe arg_ty of
+ Nothing -> False
+ Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
+ isProductTyCon arg_tycon