ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[TcTyDecls]{Typecheck type declarations}
   5
   6 \begin{code}
   7 module TcTyDecls (
   8         tcTyDecl, kcTyDecl,
   9         tcConDecl,
  10         mkDataBinds
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import HsSyn            ( MonoBinds(..),
  16                           TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
  17                           andMonoBindList
  18                         )
  19 import RnHsSyn          ( RenamedTyClDecl, RenamedConDecl )
  20 import TcHsSyn          ( TcMonoBinds )
  21 import BasicTypes       ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
  22
  23 import TcMonoType       ( tcExtendTopTyVarScope, tcExtendTyVarScope,
  24                           tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
  25                           tcContext
  26                         )
  27 import TcEnv            ( tcLookupTy, TcTyThing(..) )
  28 import TcMonad
  29 import TcUnify          ( unifyKind )
  30
  31 import Class            ( Class )
  32 import DataCon          ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
  33                           dataConFieldLabels, dataConId
  34                         )
  35 import MkId             ( mkDataConId, mkRecordSelId )
  36 import Id               ( getIdUnfolding )
  37 import CoreUnfold       ( getUnfoldingTemplate )
  38 import FieldLabel
  39 import Var              ( Id, TyVar )
  40 import Name             ( isLocallyDefined, OccName, NamedThing(..) )
  41 import Outputable
  42 import TyCon            ( TyCon, mkSynTyCon, mkAlgTyCon, isAlgTyCon,
  43                           isSynTyCon, tyConDataCons
  44                         )
  45 import Type             ( getTyVar, tyVarsOfTypes,
  46                           mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
  47                           mkTyVarTy,
  48                           mkArrowKind, mkArrowKinds, boxedTypeKind,
  49                           isUnboxedType, Type, ThetaType
  50                         )
  51 import Var              ( tyVarKind )
  52 import VarSet           ( intersectVarSet, isEmptyVarSet )
  53 import Util             ( equivClasses )
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{Kind checking}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 kcTyDecl :: RenamedTyClDecl -> TcM s ()
  64
  65 kcTyDecl (TySynonym name tyvar_names rhs src_loc)
  66   = tcLookupTy name                             `thenNF_Tc` \ (kind, _, _) ->
  67     tcExtendTopTyVarScope kind tyvar_names      $ \ _ result_kind ->
  68     tcHsTypeKind rhs                            `thenTc` \ (rhs_kind, _) ->
  69     unifyKind result_kind rhs_kind
  70
  71 kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc)
  72   = tcLookupTy tycon_name                       `thenNF_Tc` \ (kind, _, _) ->
  73     tcExtendTopTyVarScope kind tyvar_names      $ \ result_kind _ ->
  74     tcContext context                           `thenTc_`
  75     mapTc kcConDecl con_decls                   `thenTc_`
  76     returnTc ()
  77
  78 kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc)
  79   = tcAddSrcLoc loc                     (
  80     tcExtendTyVarScope ex_tvs           ( \ tyvars ->
  81     tcContext ex_ctxt                   `thenTc_`
  82     kc_con details                      `thenTc_`
  83     returnTc ()
  84     ))
  85   where
  86     kc_con (VanillaCon btys)    = mapTc kc_bty btys             `thenTc_` returnTc ()
  87     kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2]      `thenTc_` returnTc ()
  88     kc_con (NewCon ty)          = tcHsType ty                   `thenTc_` returnTc ()
  89     kc_con (RecCon flds)        = mapTc kc_field flds           `thenTc_` returnTc ()
  90
  91     kc_bty (Banged ty)   = tcHsType ty
  92     kc_bty (Unbanged ty) = tcHsType ty
  93
  94     kc_field (_, bty)    = kc_bty bty
  95 \end{code}
  96
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{Type checking}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 tcTyDecl :: RecFlag -> RenamedTyClDecl -> TcM s TyCon
 106
 107 tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
 108   = tcLookupTy tycon_name                               `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
 109     tcExtendTopTyVarScope tycon_kind tyvar_names        $ \ tyvars _ ->
 110     tcHsTopType rhs                                     `thenTc` \ rhs_ty ->
 111     let
 112         -- Construct the tycon
 113         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty
 114     in
 115     returnTc tycon
 116
 117
 118 tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
 119   =     -- Lookup the pieces
 120     tcLookupTy tycon_name                               `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) ->
 121     tcExtendTopTyVarScope tycon_kind tyvar_names        $ \ tyvars _ ->
 122
 123         -- Typecheck the pieces
 124     tcContext context                                   `thenTc` \ ctxt ->
 125     mapTc (tcConDecl rec_tycon tyvars ctxt) con_decls   `thenTc` \ data_cons ->
 126     tc_derivs derivings                                 `thenTc` \ derived_classes ->
 127
 128     let
 129         -- Construct the tycon
 130         real_data_or_new = case data_or_new of
 131                                 NewType -> NewType
 132                                 DataType | all isNullaryDataCon data_cons -> EnumType
 133                                          | otherwise                      -> DataType
 134
 135         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt
 136                            data_cons
 137                            derived_classes
 138                            Nothing              -- Not a dictionary
 139                            real_data_or_new is_rec
 140     in
 141     returnTc tycon
 142   where
 143         tc_derivs Nothing   = returnTc []
 144         tc_derivs (Just ds) = mapTc tc_deriv ds
 145
 146         tc_deriv name = tcLookupTy name `thenTc` \ (_, _, AClass clas) ->
 147                         returnTc clas
 148 \end{code}
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{Type check constructors}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 \begin{code}
 158 tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s DataCon
 159
 160 tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc)
 161   = tcAddSrcLoc src_loc                 $
 162     tcExtendTyVarScope ex_tvs           $ \ ex_tyvars ->
 163     tcContext ex_ctxt                   `thenTc` \ ex_theta ->
 164     tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
 165
 166 tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
 167   = case details of
 168         VanillaCon btys    -> tc_datacon btys
 169         InfixCon bty1 bty2 -> tc_datacon [bty1,bty2]
 170         NewCon ty          -> tc_newcon ty
 171         RecCon fields      -> tc_rec_con fields
 172   where
 173     tc_datacon btys
 174       = let
 175             arg_stricts = map get_strictness btys
 176             tys         = map get_pty btys
 177         in
 178         mapTc tcHsTopType tys `thenTc` \ arg_tys ->
 179         returnTc (mk_data_con arg_stricts arg_tys [])
 180
 181     tc_newcon ty
 182       = tcHsTopBoxedType ty     `thenTc` \ arg_ty ->
 183             -- can't allow an unboxed type here, because we're effectively
 184             -- going to remove the constructor while coercing it to a boxed type.
 185         returnTc (mk_data_con [NotMarkedStrict] [arg_ty] [])
 186
 187     tc_rec_con fields
 188       = checkTc (null ex_tyvars) (exRecConErr name)         `thenTc_`
 189         mapTc tc_field fields   `thenTc` \ field_label_infos_s ->
 190         let
 191             field_label_infos = concat field_label_infos_s
 192             arg_stricts       = [strict | (_, _, strict) <- field_label_infos]
 193             arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 194
 195             field_labels      = [ mkFieldLabel (getName name) ty tag
 196                               | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 197         in
 198         returnTc (mk_data_con arg_stricts arg_tys field_labels)
 199
 200     tc_field (field_label_names, bty)
 201       = tcHsTopType (get_pty bty)       `thenTc` \ field_ty ->
 202         returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 203
 204     mk_data_con arg_stricts arg_tys fields = data_con
 205         where
 206            data_con = mkDataCon name arg_stricts fields
 207                            tyvars (thinContext arg_tys ctxt)
 208                            ex_tyvars ex_theta
 209                            arg_tys
 210                            tycon data_con_id
 211            data_con_id = mkDataConId data_con
 212
 213
 214 -- The context for a data constructor should be limited to
 215 -- the type variables mentioned in the arg_tys
 216 thinContext arg_tys ctxt
 217   = filter in_arg_tys ctxt
 218   where
 219       arg_tyvars = tyVarsOfTypes arg_tys
 220       in_arg_tys (clas,tys) = not $ isEmptyVarSet $
 221                               tyVarsOfTypes tys `intersectVarSet` arg_tyvars
 222
 223 get_strictness (Banged   _) = MarkedStrict
 224 get_strictness (Unbanged _) = NotMarkedStrict
 225
 226 get_pty (Banged ty)   = ty
 227 get_pty (Unbanged ty) = ty
 228 \end{code}
 229
 230
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection{Generating constructor/selector bindings for data declarations}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 \begin{code}
 239 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
 240 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
 241 mkDataBinds (tycon : tycons)
 242   | isSynTyCon tycon = mkDataBinds tycons
 243   | otherwise        = mkDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 244                        mkDataBinds tycons       `thenTc` \ (ids2, b2) ->
 245                        returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
 246
 247 mkDataBinds_one tycon
 248   = ASSERT( isAlgTyCon tycon )
 249     mapTc (mkRecordSelector tycon) groups       `thenTc` \ sel_ids ->
 250     let
 251         data_ids = map dataConId data_cons ++ sel_ids
 252
 253         -- For the locally-defined things
 254         -- we need to turn the unfoldings inside the Ids into bindings,
 255         binds = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
 256                 | data_id <- data_ids, isLocallyDefined data_id
 257                 ]
 258     in
 259     returnTc (data_ids, andMonoBindList binds)
 260   where
 261     data_cons = tyConDataCons tycon
 262     fields = [ (con, field) | con   <- data_cons,
 263                               field <- dataConFieldLabels con
 264              ]
 265
 266         -- groups is list of fields that share a common name
 267     groups = equivClasses cmp_name fields
 268     cmp_name (_, field1) (_, field2)
 269         = fieldLabelName field1 `compare` fieldLabelName field2
 270 \end{code}
 271
 272 \begin{code}
 273 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 274                 -- These fields all have the same name, but are from
 275                 -- different constructors in the data type
 276         -- Check that all the fields in the group have the same type
 277         -- This check assumes that all the constructors of a given
 278         -- data type use the same type variables
 279   = checkTc (all (== field_ty) other_tys)
 280             (fieldTypeMisMatch field_name)      `thenTc_`
 281     returnTc selector_id
 282   where
 283     field_ty   = fieldLabelType first_field_label
 284     field_name = fieldLabelName first_field_label
 285     other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 286     (tyvars, _, _, _, _, _) = dataConSig first_con
 287     data_ty  = mkTyConApp tycon (mkTyVarTys tyvars)
 288     -- tyvars of first_con may be free in field_ty
 289     -- Now build the selector
 290
 291     selector_ty :: Type
 292     selector_ty  = mkForAllTys tyvars $
 293                    mkFunTy data_ty $
 294                    field_ty
 295
 296     selector_id :: Id
 297     selector_id = mkRecordSelId first_field_label selector_ty
 298 \end{code}
 299
 300
 301 Errors and contexts
 302 ~~~~~~~~~~~~~~~~~~~
 303 \begin{code}
 304 fieldTypeMisMatch field_name
 305   = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
 306
 307 exRecConErr name
 308   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
 309     $$
 310     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 311 \end{code}