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