module TcTyDecls (
tcTyDecl, kcTyDecl,
tcConDecl,
- mkImplicitDataBinds
+ mkImplicitDataBinds, mkNewTyConRep
) where
#include "HsVersions.h"
tcContext, tcHsTopTypeKind
)
import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
-import TcEnv ( tcLookupTy, TcTyThing(..) )
+import TcEnv ( tcLookupTy, tcLookupValueByKey, TcTyThing(..) )
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 FieldLabel
import Var ( Id, TyVar )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
import Outputable
-import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon,
- isSynTyCon, tyConDataCons, isNewTyCon
+import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon,
+ tyConDataConsIfAvailable, tyConTyVars,
+ isSynTyCon, isNewTyCon
)
-import Type ( getTyVar, tyVarsOfTypes,
+import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- mkTyVarTy, splitForAllTys, isForAllTy,
+ mkTyVarTy, splitAlgTyConApp_maybe,
mkArrowKind, mkArrowKinds, boxedTypeKind,
isUnboxedType, Type, ThetaType, classesOfPreds
)
+import TysWiredIn ( unitTy )
import Var ( tyVarKind )
import VarSet ( intersectVarSet, isEmptyVarSet )
+import Unique ( unpackCStringIdKey )
import Util ( equivClasses )
import FiniteMap ( FiniteMap, lookupWithDefaultFM )
import CmdLineOpts ( opt_GlasgowExts )
kcTyDecl :: RenamedTyClDecl -> TcM s ()
kcTyDecl (TySynonym name tyvar_names rhs src_loc)
- = tcLookupTy name `thenNF_Tc` \ (kind, _, _) ->
+ = tcLookupTy name `thenNF_Tc` \ (kind, _) ->
tcExtendTopTyVarScope kind tyvar_names $ \ _ result_kind ->
tcHsTypeKind rhs `thenTc` \ (rhs_kind, _) ->
unifyKind result_kind rhs_kind
-kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _, _) ->
+kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ _ src_loc)
+ = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _) ->
tcExtendTopTyVarScope kind tyvar_names $ \ result_kind _ ->
tcContext context `thenTc_`
mapTc kcConDecl con_decls `thenTc_`
%************************************************************************
\begin{code}
-tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon
+tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
+ = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ASynTyCon _ arity) ->
tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) ->
-- If the RHS mentions tyvars that aren't in scope, we'll
tycon_name
tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
in
- returnTc tycon
+ returnTc (tycon_name, ASynTyCon tycon arity)
-tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
+tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls nconstrs derivings pragmas src_loc)
= -- Lookup the pieces
- tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) ->
+ tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ADataTyCon rec_tycon) ->
tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
-- Typecheck the pieces
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
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
- data_cons
+ data_cons nconstrs
derived_classes
- Nothing -- Not a dictionary
- real_data_or_new is_rec
+ flavour is_rec
in
- returnTc tycon
+ returnTc (tycon_name, ADataTyCon tycon)
where
tc_derivs Nothing = returnTc []
tc_derivs (Just ds) = mapTc tc_deriv ds
- tc_deriv name = tcLookupTy name `thenTc` \ (_, _, AClass clas) ->
+ tc_deriv name = tcLookupTy name `thenTc` \ (_, AClass clas _) ->
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}
+
%************************************************************************
%* *
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
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
in
returnTc (all_ids, binds)
where
- data_cons = tyConDataCons tycon
+ 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
-- data type use the same type variables
= checkTc (all (== field_ty) other_tys)
(fieldTypeMisMatch field_name) `thenTc_`
- returnTc (mkRecordSelId tycon first_field_label)
+ 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
projects / ghc-hetmet.git / blobdiff