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         mkImplicitDataBinds, mkNewTyConRep
  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, idsToMonoBinds )
  21 import BasicTypes       ( RecFlag(..), NewOrData(..) )
  22
  23 import TcMonoType       ( tcExtendTopTyVarScope, tcExtendTyVarScope,
  24                           tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType,
  25                           tcContext, tcHsTopTypeKind
  26                         )
  27 import TcType           ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
  28 import TcEnv            ( tcLookupTy, tcLookupValueByKey, TcTyThing(..) )
  29 import TcMonad
  30 import TcUnify          ( unifyKind )
  31
  32 import Class            ( Class )
  33 import DataCon          ( DataCon, mkDataCon, isNullaryDataCon,
  34                           dataConFieldLabels, dataConId, dataConWrapId,
  35                           markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
  36                         )
  37 import MkId             ( mkDataConId, mkDataConWrapId, mkRecordSelId )
  38 import FieldLabel
  39 import Var              ( Id, TyVar )
  40 import Name             ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
  41 import Outputable
  42 import TyCon            ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon,
  43                           tyConDataConsIfAvailable, tyConTyVars,
  44                           isSynTyCon, isNewTyCon
  45                         )
  46 import Type             ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
  47                           mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
  48                           mkTyVarTy, splitAlgTyConApp_maybe,
  49                           mkArrowKind, mkArrowKinds, boxedTypeKind,
  50                           isUnboxedType, Type, ThetaType, classesOfPreds
  51                         )
  52 import TysWiredIn       ( unitTy )
  53 import Var              ( tyVarKind )
  54 import VarSet           ( intersectVarSet, isEmptyVarSet )
  55 import Unique           ( unpackCStringIdKey )
  56 import Util             ( equivClasses )
  57 import FiniteMap        ( FiniteMap, lookupWithDefaultFM )
  58 import CmdLineOpts      ( opt_GlasgowExts )
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection{Kind checking}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 kcTyDecl :: RenamedTyClDecl -> TcM s ()
  69
  70 kcTyDecl (TySynonym name tyvar_names rhs src_loc)
  71   = tcLookupTy name                             `thenNF_Tc` \ (kind, _) ->
  72     tcExtendTopTyVarScope kind tyvar_names      $ \ _ result_kind ->
  73     tcHsTypeKind rhs                            `thenTc` \ (rhs_kind, _) ->
  74     unifyKind result_kind rhs_kind
  75
  76 kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ _ src_loc)
  77   = tcLookupTy tycon_name                       `thenNF_Tc` \ (kind, _) ->
  78     tcExtendTopTyVarScope kind tyvar_names      $ \ result_kind _ ->
  79     tcContext context                           `thenTc_`
  80     mapTc kcConDecl con_decls                   `thenTc_`
  81     returnTc ()
  82
  83 kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc)
  84   = tcAddSrcLoc loc                     (
  85     tcExtendTyVarScope ex_tvs           ( \ tyvars ->
  86     tcContext ex_ctxt                   `thenTc_`
  87     kc_con details                      `thenTc_`
  88     returnTc ()
  89     ))
  90   where
  91     kc_con (VanillaCon btys)    = mapTc kc_bty btys             `thenTc_` returnTc ()
  92     kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2]      `thenTc_` returnTc ()
  93     kc_con (NewCon ty _)        = kcHsType ty
  94     kc_con (RecCon flds)        = mapTc kc_field flds           `thenTc_` returnTc ()
  95
  96     kc_bty (Banged ty)   = kcHsType ty
  97     kc_bty (Unbanged ty) = kcHsType ty
  98     kc_bty (Unpacked ty) = kcHsType ty
  99
 100     kc_field (_, bty)    = kc_bty bty
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{Type checking}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
 112
 113 tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
 114   = tcLookupTy tycon_name                               `thenNF_Tc` \ (tycon_kind, ASynTyCon _ arity) ->
 115     tcExtendTopTyVarScope tycon_kind tyvar_names        $ \ tyvars _ ->
 116     tcHsTopTypeKind rhs                                 `thenTc` \ (_, rhs_ty) ->
 117         -- If the RHS mentions tyvars that aren't in scope, we'll
 118         -- quantify over them.  With gla-exts that's right, but for H98
 119         -- we should complain. We can't do that here without falling into
 120         -- a black hole, so we do it in rnDecl (TySynonym case)
 121     let
 122         -- Construct the tycon
 123         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
 124                                       tycon_name
 125         tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
 126     in
 127     returnTc (tycon_name, ASynTyCon tycon arity)
 128
 129
 130 tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls nconstrs derivings pragmas src_loc)
 131   =     -- Lookup the pieces
 132     tcLookupTy tycon_name                               `thenNF_Tc` \ (tycon_kind, ADataTyCon rec_tycon) ->
 133     tcExtendTopTyVarScope tycon_kind tyvar_names        $ \ tyvars _ ->
 134
 135         -- Typecheck the pieces
 136     tcContext context                                   `thenTc` \ ctxt ->
 137     let ctxt' = classesOfPreds ctxt in
 138     mapTc (tcConDecl rec_tycon tyvars ctxt') con_decls  `thenTc` \ data_cons ->
 139     tc_derivs derivings                                 `thenTc` \ derived_classes ->
 140
 141     let
 142         -- Construct the tycon
 143         flavour = case data_or_new of
 144                         NewType -> NewTyCon (mkNewTyConRep tycon)
 145                         DataType | all isNullaryDataCon data_cons -> EnumTyCon
 146                                  | otherwise                      -> DataTyCon
 147
 148         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
 149                                       tycon_name
 150
 151         tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
 152                            data_cons nconstrs
 153                            derived_classes
 154                            flavour is_rec
 155     in
 156     returnTc (tycon_name, ADataTyCon tycon)
 157   where
 158         tc_derivs Nothing   = returnTc []
 159         tc_derivs (Just ds) = mapTc tc_deriv ds
 160
 161         tc_deriv name = tcLookupTy name `thenTc` \ (_, AClass clas _) ->
 162                         returnTc clas
 163 \end{code}
 164
 165 \begin{code}
 166 mkNewTyConRep :: TyCon -> Type
 167 -- Find the representation type for this newtype TyCon
 168 -- The trick is to to deal correctly with recursive newtypes
 169 -- such as      newtype T = MkT T
 170
 171 mkNewTyConRep tc
 172   = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs)))
 173   where
 174     tvs = tyConTyVars tc
 175     loop tcs ty = case splitAlgTyConApp_maybe ty of {
 176                         Nothing -> ty ;
 177                         Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty
 178                                                   | tc `elem` tcs       -> unitTy
 179                                                   | otherwise           ->
 180
 181                   case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of
 182                         (rep_ty, _) -> loop (tc:tcs) rep_ty
 183                   }
 184 \end{code}
 185
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection{Type check constructors}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 \begin{code}
 194 tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon
 195
 196 tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
 197   = tcAddSrcLoc src_loc                 $
 198     tcExtendTyVarScope ex_tvs           $ \ ex_tyvars ->
 199     tcContext ex_ctxt                   `thenTc` \ ex_theta ->
 200     let
 201         ex_ctxt' = classesOfPreds ex_theta
 202     in
 203     tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_ctxt' details
 204
 205 tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details
 206   = case details of
 207         VanillaCon btys    -> tc_datacon btys
 208         InfixCon bty1 bty2 -> tc_datacon [bty1,bty2]
 209         NewCon ty mb_f     -> tc_newcon ty mb_f
 210         RecCon fields      -> tc_rec_con fields
 211   where
 212     tc_datacon btys
 213       = let
 214             arg_stricts = map get_strictness btys
 215             tys         = map get_pty btys
 216         in
 217         mapTc tcHsTopType tys `thenTc` \ arg_tys ->
 218         mk_data_con arg_stricts arg_tys []
 219
 220     tc_newcon ty mb_f
 221       = tcHsTopBoxedType ty     `thenTc` \ arg_ty ->
 222             -- can't allow an unboxed type here, because we're effectively
 223             -- going to remove the constructor while coercing it to a boxed type.
 224         let
 225           field_label =
 226             case mb_f of
 227               Nothing -> []
 228               Just f  -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)]
 229         in
 230         mk_data_con [notMarkedStrict] [arg_ty] field_label
 231
 232     tc_rec_con fields
 233       = checkTc (null ex_tyvars) (exRecConErr name)         `thenTc_`
 234         mapTc tc_field fields   `thenTc` \ field_label_infos_s ->
 235         let
 236             field_label_infos = concat field_label_infos_s
 237             arg_stricts       = [strict | (_, _, strict) <- field_label_infos]
 238             arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 239
 240             field_labels      = [ mkFieldLabel (getName name) tycon ty tag
 241                               | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 242         in
 243         mk_data_con arg_stricts arg_tys field_labels
 244
 245     tc_field (field_label_names, bty)
 246       = tcHsTopType (get_pty bty)       `thenTc` \ field_ty ->
 247         returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 248
 249     mk_data_con arg_stricts arg_tys fields
 250       =         -- Now we've checked all the field types we must
 251                 -- zonk the existential tyvars to finish the kind
 252                 -- inference on their kinds, and commit them to being
 253                 -- immutable type variables.  (The top-level tyvars are
 254                 -- already fixed, by the preceding kind-inference pass.)
 255         mapNF_Tc zonkTcTyVarToTyVar ex_tyvars   `thenNF_Tc` \ ex_tyvars' ->
 256         zonkTcClassConstraints  ex_theta        `thenNF_Tc` \ ex_theta' ->
 257         let
 258            data_con = mkDataCon name arg_stricts fields
 259                            tyvars (thinContext arg_tys ctxt)
 260                            ex_tyvars' ex_theta'
 261                            arg_tys
 262                            tycon data_con_id data_con_wrap_id
 263            data_con_id      = mkDataConId wkr_name data_con
 264            data_con_wrap_id = mkDataConWrapId data_con
 265         in
 266         returnNF_Tc data_con
 267
 268 -- The context for a data constructor should be limited to
 269 -- the type variables mentioned in the arg_tys
 270 thinContext arg_tys ctxt
 271   = filter in_arg_tys ctxt
 272   where
 273       arg_tyvars = tyVarsOfTypes arg_tys
 274       in_arg_tys (clas,tys) = not $ isEmptyVarSet $
 275                               tyVarsOfTypes tys `intersectVarSet` arg_tyvars
 276
 277 get_strictness (Banged   _) = markedStrict
 278 get_strictness (Unbanged _) = notMarkedStrict
 279 get_strictness (Unpacked _) = markedUnboxed
 280
 281 get_pty (Banged ty)   = ty
 282 get_pty (Unbanged ty) = ty
 283 get_pty (Unpacked ty) = ty
 284 \end{code}
 285
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection{Generating constructor/selector bindings for data declarations}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
 296 mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds)
 297 mkImplicitDataBinds (tycon : tycons)
 298   | isSynTyCon tycon = mkImplicitDataBinds tycons
 299   | otherwise        = mkImplicitDataBinds_one tycon    `thenTc` \ (ids1, b1) ->
 300                        mkImplicitDataBinds tycons       `thenTc` \ (ids2, b2) ->
 301                        returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
 302
 303 mkImplicitDataBinds_one tycon
 304   = mapTc (mkRecordSelector tycon) groups       `thenTc` \ sel_ids ->
 305     let
 306         unf_ids = sel_ids ++ data_con_wrapper_ids
 307         all_ids = map dataConId data_cons ++ unf_ids
 308
 309         -- For the locally-defined things
 310         -- we need to turn the unfoldings inside the selector Ids into bindings,
 311         -- and build bindigns for the constructor wrappers
 312         binds | isLocallyDefined tycon = idsToMonoBinds unf_ids
 313               | otherwise              = EmptyMonoBinds
 314     in
 315     returnTc (all_ids, binds)
 316   where
 317     data_cons = tyConDataConsIfAvailable tycon
 318         -- Abstract types mean we don't bring the
 319         -- data cons into scope, which should be fine
 320
 321     data_con_wrapper_ids = map dataConWrapId data_cons
 322
 323     fields = [ (con, field) | con   <- data_cons,
 324                               field <- dataConFieldLabels con
 325              ]
 326
 327         -- groups is list of fields that share a common name
 328     groups = equivClasses cmp_name fields
 329     cmp_name (_, field1) (_, field2)
 330         = fieldLabelName field1 `compare` fieldLabelName field2
 331 \end{code}
 332
 333 \begin{code}
 334 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 335                 -- These fields all have the same name, but are from
 336                 -- different constructors in the data type
 337         -- Check that all the fields in the group have the same type
 338         -- This check assumes that all the constructors of a given
 339         -- data type use the same type variables
 340   = checkTc (all (== field_ty) other_tys)
 341             (fieldTypeMisMatch field_name)      `thenTc_`
 342     tcLookupValueByKey unpackCStringIdKey       `thenTc` \ unpack_id ->
 343     returnTc (mkRecordSelId tycon first_field_label unpack_id)
 344   where
 345     field_ty   = fieldLabelType first_field_label
 346     field_name = fieldLabelName first_field_label
 347     other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 348 \end{code}
 349
 350
 351 Errors and contexts
 352 ~~~~~~~~~~~~~~~~~~~
 353 \begin{code}
 354 fieldTypeMisMatch field_name
 355   = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
 356
 357 exRecConErr name
 358   = ptext SLIT("Can't combine named fields with locally-quantified type variables")
 359     $$
 360     (ptext SLIT("In the declaration of data constructor") <+> ppr name)
 361 \end{code}